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 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

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

'------------------------------------------------------------------------------
' 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/" & Server.URLEncode(CStr(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 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 AdminUrl()
    AdminUrl = "/admin"
End Function

Function CommentsUrl()
    CommentsUrl = "/comments"
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 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

%>