ASPBlogBrainOrdure/core/helpers.asp

<%
Function QuoteValue(val)
    if IsWrappedInSingleQuotes(val) then
        QuoteValue = val
        Exit Function
    end if
    Select Case VarType(val)
        Case vbString
            QuoteValue = "'" & Replace(val, "'", "''") & "'"
        Case vbDate
            if conn.Provider = "Microsoft.Jet.OLEDB.4.0" or conn.Provider = "Microsoft.ACE.OLEDB.12.0" then
                QuoteValue = "#" & FormatDateTime(val, 0) & "#"
            else
                ' SQL Server
                QuoteValue = "'" & FormatDateTime(val, 0) & "'"
            end if
        Case vbNull, vbEmpty
            QuoteValue = "Null"
        Case vbBoolean
            ' Return boolean values without quotes
            QuoteValue = "'" & CStr(val) & "'"
        Case Else
            If IsNumeric(val) Then
                QuoteValue = CLng(val)
            Else
                QuoteValue = CStr(val)
            End If
    End Select
End Function

Public Function GetAppSetting(key)
    Dim cacheKey, xml, nodes, node, i
    cacheKey = "AppSetting_" & key

    ' Check Application cache first for performance
    If Not IsEmpty(Application(cacheKey)) Then
        GetAppSetting = Application(cacheKey)
        Exit Function
    End If

    ' Load from web.config only if not cached
    Set xml = Server.CreateObject("Microsoft.XMLDOM")
    xml.Load(Server.MapPath("web.config"))
    Set nodes = xml.selectNodes("//appSettings/add")
    For i = 0 To nodes.Length - 1
        Set node = nodes.Item(i)
        If node.getAttribute("key") = key Then
            GetAppSetting = node.getAttribute("value")
            ' Cache the value for subsequent requests
            Application.Lock
            Application(cacheKey) = GetAppSetting
            Application.Unlock
            Exit Function
        End If
    Next
    GetAppSetting = "nothing"
End Function

Public Function GetEnvironmentValue(name)
    Dim shell, env, value, scopes, scope
    value = ""

    On Error Resume Next
    Set shell = Server.CreateObject("WScript.Shell")
    If Err.Number = 0 Then
        scopes = Array("PROCESS", "SYSTEM", "USER")
        For Each scope In scopes
            Set env = shell.Environment(scope)
            If Err.Number = 0 Then
                value = env(name)
                If Len(Trim(CStr(value))) > 0 Then Exit For
            End If
            Err.Clear
        Next
    Else
        Err.Clear
    End If
    On Error GoTo 0

    GetEnvironmentValue = Trim(CStr(value))
End Function

Public Function GetSecureSetting(key, envName)
    Dim value, envValue

    value = Trim(CStr(GetAppSetting(key)))
    If Len(value) > 0 And LCase(value) <> "nothing" Then
        GetSecureSetting = value
        Exit Function
    End If

    envValue = Trim(CStr(GetEnvironmentValue(envName)))
    If Len(envValue) > 0 Then
        On Error Resume Next
        UpdateAppSetting key, envValue
        Err.Clear
        On Error GoTo 0
        GetSecureSetting = envValue
        Exit Function
    End If

    GetSecureSetting = ""
End Function

Public Function GetGenerationPromptTemplate()
    Dim prompt
    prompt = Trim(CStr(GetAppSetting("AbacusGenerationPrompt")))

    If Len(prompt) = 0 Or LCase(prompt) = "nothing" Then
        prompt = "You are a panel of 150 expert writers, researchers, editors, and subject-matter specialists on the topic: {TITLE}." & vbCrLf & vbCrLf & _
                 "Your task is to write a long, interesting, useful blog post for a general audience and suggest public domain or CC0 image ideas that would fit the article." & vbCrLf & vbCrLf & _
                 "Return only valid JSON with exactly three keys:" & vbCrLf & vbCrLf & _
                 "{""summary"":"""",""body"":"""",""images"":[]}" & vbCrLf & vbCrLf & _
                 "Rules:" & vbCrLf & _
                 "- Return only valid JSON." & vbCrLf & _
                 "- Do not use markdown fences." & vbCrLf & _
                 "- Do not use bullet points." & vbCrLf & _
                 "- Do not use numbered lists." & vbCrLf & _
                 "- Do not include anything outside the JSON object." & vbCrLf & _
                 "- Keep the title unchanged." & vbCrLf & _
                 "- The summary must be 1 to 2 clear, engaging sentences." & vbCrLf & _
                 "- The body must be 900 to 1,400 words." & vbCrLf & _
                 "- The body should be 8 to 12 short-to-medium paragraphs." & vbCrLf & _
                 "- Separate paragraphs with blank lines." & vbCrLf & _
                 "- Make the writing clear, helpful, and interesting." & vbCrLf & _
                 "- Use a warm, human, conversational tone." & vbCrLf & _
                 "- Avoid sounding like AI-generated content." & vbCrLf & _
                 "- Do not exaggerate or make unsupported claims." & vbCrLf & vbCrLf & _
                 "Image rules:" & vbCrLf & _
                 "- Include 3 to 5 image suggestions in the images array." & vbCrLf & _
                 "- Suggest only images that are likely to be available as public domain, CC0, or freely reusable images." & vbCrLf & _
                 "- Prefer image sources such as Wikimedia Commons, Library of Congress, NASA, National Archives, public domain museum collections, or official government archives." & vbCrLf & _
                 "- Do not invent exact image URLs unless they are already provided in the existing content." & vbCrLf & _
                 "- Do not use copyrighted stock photo sites." & vbCrLf & _
                 "- Do not suggest Unsplash as public domain." & vbCrLf & _
                 "- Each image object must include placement, search_query, suggested_source, caption, alt_text, and license_requirement." & vbCrLf & _
                 "- The license_requirement must say: Verify that the image is public domain or CC0 before publishing." & vbCrLf & vbCrLf & _
                 "Use the existing content as source material, but improve it significantly." & vbCrLf & vbCrLf & _
                 "Create blog content for this post title: {TITLE}" & vbCrLf & _
                 "Existing summary: {SUMMARY}" & vbCrLf & _
                 "Existing body: {BODY}"
    End If

    GetGenerationPromptTemplate = prompt
End Function

Public Function BuildGenerationPrompt(ByRef post)
    Dim template
    template = GetGenerationPromptTemplate()
    template = Replace(template, "{TITLE}", SafePromptText(post.Title))
    template = Replace(template, "{SUMMARY}", SafePromptText(post.Summary))
    template = Replace(template, "{BODY}", SafePromptText(post.Body))
    BuildGenerationPrompt = template
End Function

Public Function SafePromptText(ByVal value)
    If IsNull(value) Or IsEmpty(value) Then
        SafePromptText = ""
    Else
        SafePromptText = CStr(value)
    End If
End Function

Public Function UpdateAppSetting(key, value)
    Dim xml, nodes, node, appSettings, found
    Set xml = Server.CreateObject("Microsoft.XMLDOM")
    xml.async = False
    xml.preserveWhiteSpace = True
    xml.Load Server.MapPath("web.config")

    If xml.parseError.errorCode <> 0 Then
        Err.Raise 1, "UpdateAppSetting", "Unable to load web.config: " & xml.parseError.reason
    End If

    Set nodes = xml.selectNodes("//appSettings/add[@key='" & key & "']")
    found = False
    If Not (nodes Is Nothing) Then
        If nodes.Length > 0 Then
            Set node = nodes.Item(0)
            node.setAttribute "value", value
            found = True
        End If
    End If

    If Not found Then
        Set appSettings = xml.selectSingleNode("//appSettings")
        If appSettings Is Nothing Then
            Err.Raise 1, "UpdateAppSetting", "<appSettings> section not found in web.config."
        End If

        Set node = xml.createElement("add")
        node.setAttribute "key", key
        node.setAttribute "value", value
        appSettings.appendChild node
    End If

    xml.Save Server.MapPath("web.config")
    Application.Contents.Remove("AppSetting_" & key)
    UpdateAppSetting = True
End Function

Public Sub ShowServerVariables
    Dim varName, htmlTable
    htmlTable = "<table border='1' cellspacing='0' cellpadding='5'>"
    htmlTable = htmlTable & "<thead><tr><th>Variable Name</th><th>Value</th></tr></thead><tbody>"

    ' Loop through all server variables
    For Each varName In Request.ServerVariables
        htmlTable = htmlTable & "<tr>"
        htmlTable = htmlTable & "<td>" & Server.HTMLEncode(varName) & "</td>"
        htmlTable = htmlTable & "<td>" & Server.HTMLEncode(Request.ServerVariables(varName)) & "</td>"
        htmlTable = htmlTable & "</tr>"
    Next

    htmlTable = htmlTable & "</tbody></table>"

    ' Output the HTML table
    Response.Write(htmlTable)
End Sub
'------------------------------------------------------------------------------ 
' Utility: IIf Function for VBScript
' Usage:  result = IIf(condition, trueValue, falseValue)
'------------------------------------------------------------------------------ 
Function IIf(condition, trueValue, falseValue)
    On Error Resume Next
    If CBool(condition) Then
        IIf = trueValue
    Else
        IIf = falseValue
    End If
    If Err.Number <> 0 Then
        ' Optional: handle or log error in conversion/evaluation
        Err.Clear
    End If
    On Error GoTo 0
End Function

'-----------------------------
' Utility: Generic Error Reporter
'-----------------------------
Public Sub ErrorCheck(context)
    If Err.Number <> 0 Then
        Dim errHtml
        errHtml  = "<div style='padding:10px; border:2px solid red; background:#fdd; font-family:Verdana; font-size:12px;'>"
        errHtml = errHtml & "<strong>Error occurred" & IIf(Not IsEmpty(context) And context <> "", ": " & context, "") & "</strong><br />"
        errHtml = errHtml & "<em>Time:</em> " & Now() & "<br />"
        errHtml = errHtml & "<em>Number:</em> " & Err.Number & "<br />"
        errHtml = errHtml & "<em>Description:</em> " & Server.HTMLEncode(Err.Description) & "<br />"
        If Len(Err.Source) > 0 Then
            errHtml = errHtml & "<em>Source:</em> " & Server.HTMLEncode(Err.Source) & "<br />"
        End If
        errHtml = errHtml & "</div>"
        Response.Write errHtml
        Err.Clear
    End If
End Sub

'------------------------------------------------------------------------------
' Utility: TrimQueryParams
'   Removes everything from the first "?" or "&" onward.
' Usage:
'   CleanPath = TrimQueryParams(rawPath)
'------------------------------------------------------------------------------
Function TrimQueryParams(rawPath)
    Dim posQ, posA, cutPos

    ' find the first occurrences of "?" and "&"
    posQ = InStr(rawPath, "?")
    posA = InStr(rawPath, "&")

    ' determine the earliest cut position (>0)
    If posQ > 0 And posA > 0 Then
        cutPos = IIf(posQ < posA, posQ, posA)
    ElseIf posQ > 0 Then
        cutPos = posQ
    ElseIf posA > 0 Then
        cutPos = posA
    Else
        cutPos = 0
    End If

    ' if found, return up to just before that char
    If cutPos > 0 Then
        TrimQueryParams = Left(rawPath, cutPos - 1)
    Else
        TrimQueryParams = rawPath
    End If
End Function

Function DecodeUrlPath(ByVal rawPath)
    Dim current, previous
    current = Trim(CStr(rawPath))

    On Error Resume Next
    Do
        previous = current
        current = Server.URLDecode(current)
        If Err.Number <> 0 Then
            Err.Clear
            current = previous
            Exit Do
        End If
    Loop While current <> previous
    On Error GoTo 0

    current = Replace(current, "%252D", "-")
    current = Replace(current, "%252d", "-")
    current = Replace(current, "%2D", "-")
    current = Replace(current, "%2d", "-")
    current = Replace(current, "%25", "%")

    DecodeUrlPath = current
End Function

Sub Destroy(o)
    if isobject(o) then
        if not o is nothing then
            on error resume next
            o.close
            on error goto 0
            set o = nothing
        end if
    end if
End Sub

    'prepends indents
    Private Sub puti(v)
        put Spaces(m_indent) & v
    End Sub

    Sub put(v)
    Select Case typename(v)
        Case "LinkedList_Class"       : response.write join(v.TO_Array, ", ")
        Case "DynamicArray_Class"     : response.write JoinList(v)
        Case "Variant()"              : response.write join(v, ", ")
        Case else                     : response.write v
    End Select
End Sub

Sub put_
    put "<br>"
End Sub

Sub putl(v)
    put v
    put_
End Sub
'---------------------------------------------------------------------------------------------------------------------
'Wrapper for Server.HTMLEncode() -- makes it easier on the eyes when reading the HTML code
Function H(s)
    If Not IsEmpty(s) and Not IsNull(s) then
        H = Server.HTMLEncode(s)
    Else
        H = ""
    End If
End Function

Function RenderPostBody(ByVal body)
    Dim raw
    If IsNull(body) Or IsEmpty(body) Then
        RenderPostBody = ""
        Exit Function
    End If

    raw = CStr(body)
    If IsHtmlPostBody(raw) Then
        RenderPostBody = raw
    Else
        raw = Server.HTMLEncode(raw)
        raw = Replace(raw, vbCrLf, "<br>")
        raw = Replace(raw, vbCr, "<br>")
        raw = Replace(raw, vbLf, "<br>")
        RenderPostBody = raw
    End If
End Function

Function IsHtmlPostBody(ByVal text)
    Dim lowerText
    lowerText = LCase(CStr(text))
    IsHtmlPostBody = _
        (InStr(lowerText, "<p") > 0) Or _
        (InStr(lowerText, "<div") > 0) Or _
        (InStr(lowerText, "<br") > 0) Or _
        (InStr(lowerText, "<strong") > 0) Or _
        (InStr(lowerText, "<em") > 0) Or _
        (InStr(lowerText, "<ul") > 0) Or _
        (InStr(lowerText, "<ol") > 0) Or _
        (InStr(lowerText, "<li") > 0) Or _
        (InStr(lowerText, "<a ") > 0) Or _
        (InStr(lowerText, "<img") > 0) Or _
        (InStr(lowerText, "<blockquote") > 0) Or _
        (InStr(lowerText, "<h1") > 0) Or _
        (InStr(lowerText, "<h2") > 0) Or _
        (InStr(lowerText, "<h3") > 0) Or _
        (InStr(lowerText, "<h4") > 0) Or _
        (InStr(lowerText, "<h5") > 0) Or _
        (InStr(lowerText, "<h6") > 0) Or _
        (InStr(lowerText, "<code") > 0) Or _
        (InStr(lowerText, "<pre") > 0)
End Function

Function ExtractFirstImageSrc(ByVal html)
    Dim text, imgPos, srcPos, quoteChar, startPos, endPos, fallbackEnd
    If IsNull(html) Or IsEmpty(html) Then
        ExtractFirstImageSrc = ""
        Exit Function
    End If

    text = CStr(html)
    imgPos = InStr(1, text, "<img", vbTextCompare)
    If imgPos = 0 Then
        ExtractFirstImageSrc = ""
        Exit Function
    End If

    srcPos = InStr(imgPos, text, "src=", vbTextCompare)
    If srcPos = 0 Then
        ExtractFirstImageSrc = ""
        Exit Function
    End If

    quoteChar = Mid(text, srcPos + 4, 1)
    If quoteChar = """" Or quoteChar = "'" Then
        startPos = srcPos + 5
        endPos = InStr(startPos, text, quoteChar)
        If endPos > startPos Then
            ExtractFirstImageSrc = Mid(text, startPos, endPos - startPos)
            Exit Function
        End If
    End If

    startPos = srcPos + 4
    fallbackEnd = InStr(startPos, text, " ")
    If fallbackEnd = 0 Then fallbackEnd = InStr(startPos, text, ">")
    If fallbackEnd > startPos Then
        ExtractFirstImageSrc = Mid(text, startPos, fallbackEnd - startPos)
    Else
        ExtractFirstImageSrc = ""
    End If
End Function

Function AiImageUrl(ByVal prompt)
    AiImageUrl = "/ai-image?prompt=" & Server.URLEncode(Trim(CStr(prompt)))
End Function

Function GetAiImageProvider()
    Dim provider
    provider = LCase(Trim(CStr(GetAppSetting("AiImageProvider"))))
    If Len(provider) = 0 Or provider = "nothing" Then
        provider = "pollinations"
    End If
    GetAiImageProvider = provider
End Function

Function GetAiImageRemoteBaseUrl()
    Dim provider, baseUrl
    provider = GetAiImageProvider()

    If provider = "abacus" Then
        baseUrl = Trim(CStr(GetAppSetting("AbacusImageBaseUrl")))
        If Len(baseUrl) = 0 Or LCase(baseUrl) = "nothing" Then
            baseUrl = Trim(CStr(GetAppSetting("AiImageBaseUrl")))
        End If
    Else
        baseUrl = Trim(CStr(GetAppSetting("AiImageBaseUrl")))
    End If

    If Len(baseUrl) = 0 Or LCase(baseUrl) = "nothing" Then
        baseUrl = "https://image.pollinations.ai/prompt/"
    End If

    If Right(baseUrl, 1) <> "/" Then baseUrl = baseUrl & "/"
    GetAiImageRemoteBaseUrl = baseUrl
End Function

Function GetAiImageRemoteUrl(ByVal prompt)
    Dim cleanPrompt
    cleanPrompt = Trim(CStr(prompt))
    If Len(cleanPrompt) = 0 Then
        GetAiImageRemoteUrl = ""
    Else
        GetAiImageRemoteUrl = GetAiImageRemoteBaseUrl() & Server.URLEncode(cleanPrompt)
    End If
End Function

'------------------------------------------------------------------------------
' Canonical application URL helpers
' - Categories use numeric IDs
' - Posts use slug permalinks for public links and numeric IDs for admin actions
'------------------------------------------------------------------------------
Function CategoryUrl(ByVal categoryId)
    CategoryUrl = "/categories/" & Server.URLEncode(CStr(categoryId))
End Function

Function CategoriesUrl()
    CategoriesUrl = "/categories"
End Function

Function CategoryNewUrl()
    CategoryNewUrl = "/categories/new"
End Function

Function CategoryEditUrl(ByVal categoryId)
    CategoryEditUrl = CategoryUrl(categoryId) & "/edit"
End Function

Function CategoryDeleteUrl(ByVal categoryId)
    CategoryDeleteUrl = CategoryUrl(categoryId) & "/delete"
End Function

Function PostUrl(ByVal slug)
    PostUrl = "/posts/" & NormalizeSlug(slug)
End Function

Function PostPath(ByVal slug)
    PostPath = "/posts/" & NormalizeSlug(slug)
End Function

Function PostsUrl()
    PostsUrl = "/posts"
End Function

Function PostNewUrl()
    PostNewUrl = "/posts/new"
End Function

Function PostEditUrl(ByVal postId)
    PostEditUrl = "/posts/" & Server.URLEncode(CStr(postId)) & "/edit"
End Function

Function PostUpdateUrl(ByVal postId)
    PostUpdateUrl = "/posts/" & Server.URLEncode(CStr(postId))
End Function

Function PostDeleteUrl(ByVal postId)
    PostDeleteUrl = "/posts/" & Server.URLEncode(CStr(postId)) & "/delete"
End Function

Function AdminPostPublishUrl(ByVal postId)
    AdminPostPublishUrl = "/admin/posts/" & Server.URLEncode(CStr(postId)) & "/publish"
End Function

Function AdminPostUnpublishUrl(ByVal postId)
    AdminPostUnpublishUrl = "/admin/posts/" & Server.URLEncode(CStr(postId)) & "/unpublish"
End Function

Function AdminPostAIUrl(ByVal postId)
    AdminPostAIUrl = "/admin/posts/" & Server.URLEncode(CStr(postId)) & "/ai"
End Function

Function AdminCommentsUrl()
    AdminCommentsUrl = "/admin/comments"
End Function

Function AdminCommentApproveUrl(ByVal commentId)
    AdminCommentApproveUrl = "/admin/comments/" & Server.URLEncode(CStr(commentId)) & "/approve"
End Function

Function AdminCommentUnapproveUrl(ByVal commentId)
    AdminCommentUnapproveUrl = "/admin/comments/" & Server.URLEncode(CStr(commentId)) & "/unapprove"
End Function

Function AdminCommentDeleteUrl(ByVal commentId)
    AdminCommentDeleteUrl = "/admin/comments/" & Server.URLEncode(CStr(commentId)) & "/delete"
End Function

Function AdminAIPromptUrl()
    AdminAIPromptUrl = "/admin/ai-prompt"
End Function

Function AdminAIPromptUpdateUrl()
    AdminAIPromptUpdateUrl = "/admin/ai-prompt"
End Function

Function AdminUrl()
    AdminUrl = "/admin"
End Function

Function CommentsUrl()
    CommentsUrl = "/comments"
End Function

Function NormalizeSlug(ByVal slug)
    Dim current, previous
    current = Trim(CStr(slug))

    If Len(current) = 0 Then
        NormalizeSlug = ""
        Exit Function
    End If

    On Error Resume Next
    Do
        previous = current
        current = Server.URLDecode(current)
        If Err.Number <> 0 Then
            Err.Clear
            current = previous
            Exit Do
        End If
    Loop While current <> previous
    On Error GoTo 0

    current = Replace(current, "%252D", "-")
    current = Replace(current, "%252d", "-")
    current = Replace(current, "%2D", "-")
    current = Replace(current, "%2d", "-")
    current = Replace(current, "%25", "%")

    NormalizeSlug = current
End Function

Function EstimateReadTime(ByVal body)
    Dim text, re, words, count, minutes
    text = ""
    If Not (IsNull(body) Or IsEmpty(body)) Then
        text = CStr(body)
    End If

    On Error Resume Next
    Set re = Server.CreateObject("VBScript.RegExp")
    If Err.Number = 0 Then
        re.Global = True
        re.IgnoreCase = True
        re.Pattern = "<[^>]+>"
        text = re.Replace(text, " ")
        re.Pattern = "&[a-z0-9#]+;"
        text = re.Replace(text, " ")
        re.Pattern = "\s+"
        text = Trim(re.Replace(text, " "))
    Else
        Err.Clear
        text = Replace(text, vbCrLf, " ")
        text = Replace(text, vbCr, " ")
        text = Replace(text, vbLf, " ")
    End If
    On Error GoTo 0

    If Len(text) = 0 Then
        EstimateReadTime = "1 min read"
        Exit Function
    End If

    words = Split(text, " ")
    count = UBound(words) + 1
    minutes = CLng((count + 149) / 150)
    If minutes < 1 Then minutes = 1
    EstimateReadTime = CStr(minutes) & " min read"
End Function


'=======================================================================================================================
' Adapted from Tolerable library
'=======================================================================================================================
' This subroutine allows us to ignore the difference
' between object and primitive assignments.  This is
' essential for many parts of the engine.
Public Sub Assign(ByRef var, ByVal val)
    If IsObject(val) Then
        Set var = val
    Else
        var = val
    End If
End Sub

' This is similar to the  ? :  operator of other languages.
' Unfortunately, both the  if_true  and  if_false  "branches"
' will be evalauted before the condition is even checked. So,
' you'll only want to use this for simple expressions.
Public Function Choice(ByVal cond, ByVal if_true, ByVal if_false)
    If cond Then
        Assign Choice, if_true
    Else
        Assign Choice, if_false
    End If
End Function

' Allows single-quotes to be used in place of double-quotes.
' Basically, this is a cheap trick that can make it easier
' to specify Lambdas.
Public Function Q(ByVal input)
    Q = Replace(input, "'", """")
End Function

Function SurroundString(inputVar)
    If VarType(inputVar) = vbString Then
        SurroundString = """" & inputVar & """"
    Else
        SurroundString = inputVar
    End If
End Function

Function SurroundStringInArray(arr)
    Dim i
    For i = LBound(arr) To UBound(arr)
        If IsString(arr(i)) Then
            arr(i) = """" & arr(i) & """"
        End If
    Next
    SurroundStringInArray = arr
End Function
'-----------------------------------------------------------------------------------------------------------------------
'Boolean type checkers
'Don't forget IsArray is built-in!
Function IsString(value)
    IsString = Choice(typename(value) = "String", true, false)
End Function

Function IsDict(value)
    IsDict = Choice(typename(value) = "Dictionary", true, false)
End Function

Function IsRecordset(value)
    IsRecordset = Choice(typename(value) = "Recordset", true, false)
End Function

Function IsLinkedList(value)
    IsLinkedList = Choice(typename(value) = "LinkedList_Class", true, false)
End Function

Function IsArray(value)
    IsArray = Choice(typename(value) = "Variant()", true, false)
End Function

'--------------------------------------------------------------------
' Returns True when the named key is present in Session.Contents
'   • Handles scalars (String, Integer, etc.), objects, Empty, and Null
'--------------------------------------------------------------------
Function SessionHasKey(keyName)
    'Loop over the existing keys—Session.Contents is like a dictionary
    Dim k
    For Each k In Session.Contents
        If StrComp(k, keyName, vbTextCompare) = 0 Then
            SessionHasKey = True
            Exit Function
        End If
    Next
    SessionHasKey = False      'not found
End Function

Function RenderObjectsAsTable(arr,boolUseTabulator)
    Dim html, propNames, i, j, obj, val, pkName, isPk

    If IsEmpty(arr) Or Not IsArray(arr) Then
        RenderObjectsAsTable = "<!-- no data -->"
        Exit Function
    End If

    Set obj = arr(0)
    On Error Resume Next
    propNames = obj.Properties
    pkName = obj.PrimaryKey
    On Error GoTo 0

    If IsEmpty(propNames) Or Len(pkName) = 0 Then
        RenderObjectsAsTable = "<!-- missing properties or primary key -->"
        Exit Function
    End If

    html = "<div class='table-wrapper'>" & vbCrLf
    html = html & "<table class='pobo-table' id='pobo-table'>" & vbCrLf
    html = html & "  <thead><tr>" & vbCrLf
    For i = 0 To UBound(propNames)
        html = html & "    <th>" & Server.HTMLEncode(propNames(i)) & "</th>" & vbCrLf
    Next
    html = html & "  </tr></thead>" & vbCrLf
    html = html & "  <tbody>" & vbCrLf

    For j = 0 To UBound(arr)
        Set obj = arr(j)
        html = html & "    <tr>" & vbCrLf
        For i = 0 To UBound(propNames)
            val = GetDynamicProperty(obj, propNames(i))
            isPk = (StrComp(propNames(i), pkName, vbTextCompare) = 0)

            If IsNull(val) Or IsEmpty(val) Then
                val = "&nbsp;"
            ElseIf IsDate(val) Then
                val = FormatDateTime(val, vbShortDate)
            ElseIf VarType(val) = vbBoolean Then
                val = IIf(val, "True", "False")
            Else
                val = CStr(val)
                Dim maxLen : maxLen = CInt(GetAppSetting("TableCellMaxLength"))
                If maxLen <= 0 Then maxLen = 90
                If Len(val) > maxLen Then
                    val = Left(val, maxLen - 3) & "..."
                End If
                val = Server.HTMLEncode(val)
            End If

            If isPk and boolUseTabulator = False Then
                val = "<a href=""" & obj.Tablename & "/edit/" & GetDynamicProperty(obj, pkName) & """ class=""table-link"">" & val & "</a>"
            End If

            html = html & "      <td>" & val & "</td>" & vbCrLf
        Next
        html = html & "    </tr>" & vbCrLf
    Next

    html = html & "  </tbody>" & vbCrLf & "</table>" & vbCrLf & "</div>"
    RenderObjectsAsTable = html
End Function

Function RenderFormFromObject(obj)
    Dim html, propNames, i, name, val, inputType
    Dim pkName, tableName, checkedAttr

    On Error Resume Next
    propNames = obj.Properties
    pkName = obj.PrimaryKey
    tableName = obj.TableName
    On Error GoTo 0

    If IsEmpty(propNames) Or Len(pkName) = 0 Then
        RenderFormFromObject = "<!-- Invalid object -->"
        Exit Function
    End If

    html = "<form method='post' action='/" & tableName & "/save' class='article-content'>" & vbCrLf

    For i = 0 To UBound(propNames)
        name = propNames(i)
        val = GetDynamicProperty(obj, name)

        ' Handle nulls
        If IsNull(val) Then val = ""

        ' Primary key → hidden input
        If StrComp(name, pkName, vbTextCompare) = 0 Then
            html = html & "  <input type='hidden' name='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
            'Continue For
        End If

        html = html & "  <div class='form-group'>" & vbCrLf
        html = html & "    <label for='" & name & "'>" & name & "</label>" & vbCrLf

        Select Case True
            Case VarType(val) = vbBoolean
                checkedAttr = ""
                If val = True Then checkedAttr = " checked"
                html = html & "    <input type='checkbox' class='form-check-input' name='" & name & "' id='" & name & "' value='true'" & checkedAttr & " />" & vbCrLf

            Case IsDate(val)
                html = html & "    <input type='date' class='form-control' name='" & name & "' id='" & name & "' value='" & FormatDateForInput(val) & "' />" & vbCrLf

            Case IsNumeric(val)
                html = html & "    <input type='number' class='form-control' name='" & name & "' id='" & name & "' value='" & val & "' />" & vbCrLf

            Case Len(val) > CInt(GetAppSetting("FormTextareaThreshold"))
                html = html & "    <textarea class='form-control' name='" & name & "' id='" & name & "' rows='6'>" & Server.HTMLEncode(val) & "</textarea>" & vbCrLf

            Case Else
                html = html & "    <input type='text' class='form-control' name='" & name & "' id='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
        End Select

        html = html & "  </div>" & vbCrLf
    Next

    html = html & "  <button type='submit' class='btn btn-primary btn-lg'>Save</button>" & vbCrLf
    html = html & "</form>" & vbCrLf

    RenderFormFromObject = html
End Function


Function GetDynamicProperty(obj, propName)
    On Error Resume Next
    Dim result
    Execute "result = obj." & propName
    If Err.Number <> 0 Then
        result = ""
        Err.Clear
    End If
    GetDynamicProperty = result
    On Error GoTo 0
End Function

Function FormatDateForInput(val)
    If IsDate(val) Then
        Dim yyyy, mm, dd
        yyyy = Year(val)
        mm = Right("0" & Month(val), 2)
        dd = Right("0" & Day(val), 2)
        FormatDateForInput = yyyy & "-" & mm & "-" & dd
    Else
        FormatDateForInput = ""
    End If
End Function


'-------------------------------------------------------------
' Returns obj.<propName> for any public VBScript class property
'-------------------------------------------------------------
Function GetObjProp(o, pName)
    Dim tmp
    ' Build a tiny statement like:   tmp = o.UserID
    Execute "tmp = o." & pName
    GetObjProp = tmp
End Function

Function GenerateSlug(title)
    Dim slug
    slug = LCase(title)                                ' Convert to lowercase
    slug = Replace(slug, "&", "and")                   ' Replace ampersands
    slug = Replace(slug, "'", "")                      ' Remove apostrophes
    slug = Replace(slug, """", "")                     ' Remove quotes
    slug = Replace(slug, "–", "-")                     ' Replace en dash
    slug = Replace(slug, "—", "-")                     ' Replace em dash
    slug = Replace(slug, "/", "-")                     ' Replace slashes
    slug = Replace(slug, "\", "-")                     ' Replace backslashes

    ' Remove all non-alphanumeric and non-hyphen/space characters
    Dim i, ch, clean
    clean = ""
    For i = 1 To Len(slug)
        ch = Mid(slug, i, 1)
        If (ch >= "a" And ch <= "z") Or (ch >= "0" And ch <= "9") Or ch = " " Or ch = "-" Then
            clean = clean & ch
        End If
    Next

    ' Replace multiple spaces or hyphens with single hyphen
    Do While InStr(clean, "  ") > 0
        clean = Replace(clean, "  ", " ")
    Loop
    clean = Replace(clean, " ", "-")
    Do While InStr(clean, "--") > 0
        clean = Replace(clean, "--", "-")
    Loop

    ' Trim leading/trailing hyphens
    Do While Left(clean, 1) = "-"
        clean = Mid(clean, 2)
    Loop
    Do While Right(clean, 1) = "-"
        clean = Left(clean, Len(clean) - 1)
    Loop

    GenerateSlug = clean
End Function

Function GetRawJsonFromRequest()
    Dim stream, rawJson
    Set stream = Server.CreateObject("ADODB.Stream")
    stream.Type = 1 ' adTypeBinary
    stream.Open
    stream.Write Request.BinaryRead(Request.TotalBytes)
    stream.Position = 0
    stream.Type = 2 ' adTypeText
    stream.Charset = "utf-8"
    rawJson = stream.ReadText
    stream.Close
    Set stream = Nothing

    GetRawJsonFromRequest = rawJson
End Function

Function EnsureFolderExists(ByVal folderPath)
    Dim fso, parentPath
    Set fso = Server.CreateObject("Scripting.FileSystemObject")

    If Len(Trim(CStr(folderPath))) = 0 Then
        EnsureFolderExists = False
        Exit Function
    End If

    If Not fso.FolderExists(folderPath) Then
        parentPath = fso.GetParentFolderName(folderPath)
        If Len(parentPath) > 0 And Not fso.FolderExists(parentPath) Then
            Call EnsureFolderExists(parentPath)
        End If
        If Not fso.FolderExists(folderPath) Then
            fso.CreateFolder folderPath
        End If
    End If

    EnsureFolderExists = True
End Function

Function FileExists(ByVal filePath)
    Dim fso
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    FileExists = fso.FileExists(filePath)
End Function

Function BuildAiImageFileName(ByVal prompt)
    Dim slug, stamp
    slug = GenerateSlug(prompt)
    If Len(slug) = 0 Then slug = "image"
    If Len(slug) > 40 Then slug = Left(slug, 40)

    stamp = Year(Now()) & Right("0" & Month(Now()), 2) & Right("0" & Day(Now()), 2) & _
            Right("0" & Hour(Now()), 2) & Right("0" & Minute(Now()), 2) & Right("0" & Second(Now()), 2)

    BuildAiImageFileName = slug & "-" & stamp & ".jpg"
End Function

Function GetOrCreateAiImageUrl(ByVal prompt)
    Dim cleanPrompt, folderPath, fileName, filePath, localUrl, remoteUrl, shell, command, exitCode
    cleanPrompt = Trim(CStr(prompt))
    If Len(cleanPrompt) = 0 Then
        GetOrCreateAiImageUrl = ""
        Exit Function
    End If

    folderPath = Server.MapPath("/uploads/ai-images")
    Call EnsureFolderExists(folderPath)

    fileName = BuildAiImageFileName(cleanPrompt)
    filePath = folderPath & "\" & fileName
    localUrl = "/uploads/ai-images/" & fileName

    If FileExists(filePath) Then
        GetOrCreateAiImageUrl = localUrl
        Exit Function
    End If

    remoteUrl = GetAiImageRemoteUrl(cleanPrompt)
    If Len(remoteUrl) = 0 Then
        GetOrCreateAiImageUrl = ""
        Exit Function
    End If

    On Error Resume Next
    Set shell = Server.CreateObject("WScript.Shell")
    If Err.Number = 0 Then
        command = "cmd /c curl.exe -L --fail --silent --show-error --output """ & filePath & """ """ & remoteUrl & """"
        exitCode = shell.Run(command, 0, True)
        If exitCode = 0 And FileExists(filePath) Then
            GetOrCreateAiImageUrl = localUrl
            Exit Function
        End If
    End If
    Err.Clear
    On Error GoTo 0

    GetOrCreateAiImageUrl = remoteUrl
End Function

Function GetPostFeatureImageUrl(ByVal title, ByVal summary, ByVal body)
    Dim existing, promptText
    existing = ExtractFirstImageSrc(body)
    If Len(Trim(CStr(existing))) > 0 Then
        GetPostFeatureImageUrl = existing
        Exit Function
    End If

    promptText = "A polished editorial feature image for a blog post titled '" & Trim(CStr(title)) & "'"
    If Len(Trim(CStr(summary))) > 0 Then
        promptText = promptText & ". " & Trim(CStr(summary))
    End If
    promptText = promptText & " Use a magazine-style composition with a clean, modern, photorealistic look."

    GetPostFeatureImageUrl = GetOrCreateAiImageUrl(promptText)
End Function

Function Active(controllerName)
    On Error Resume Next
    If Replace(Lcase(router.Resolve(Request.ServerVariables("REQUEST_METHOD"), TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")))(0)),"controller","") = LCase(controllerName) Then
        Active = "active"
    Else
        Active = ""
    End If
    On Error GoTo 0
End Function

'====================================================================
' FormatDateForSql
' Converts a VBScript Date to a SQL Server-compatible string
' Output: 'YYYY-MM-DD HH:MM:SS'
'====================================================================
Function FormatDateForSql(vbDate)
    If IsNull(vbDate) Or vbDate = "" Then
        FormatDateForSql = "NULL"
        Exit Function
    End If
    
    ' Ensure vbDate is a valid date
    If Not IsDate(vbDate) Then
        Err.Raise vbObjectError + 1000, "FormatDateForSql", "Invalid date: " & vbDate
    End If
    
    Dim yyyy, mm, dd, hh, nn, ss
    yyyy = Year(vbDate)
    mm   = Right("0" & Month(vbDate), 2)
    dd   = Right("0" & Day(vbDate), 2)
    hh   = Right("0" & Hour(vbDate), 2)
    nn   = Right("0" & Minute(vbDate), 2)
    ss   = Right("0" & Second(vbDate), 2)

    ' Construct SQL Server datetime literal
    FormatDateForSql = "'" & yyyy & "-" & mm & "-" & dd & " " & hh & ":" & nn & ":" & ss & "'"
End Function

%>