AI-ASP-CLASSIC/tests/TestSupport.vbs

Option Explicit

Dim g_TestsRun
Dim g_TestsPassed
Dim g_Failures

g_TestsRun = 0
g_TestsPassed = 0
Set g_Failures = CreateObject("Scripting.Dictionary")

Dim ASSERTION_FAILED
ASSERTION_FAILED = vbObjectError + 1999

' Runs the named zero-argument Sub/Function, treating any unhandled error
' (including one raised by a failed Assert*) as a failed test. This mirrors
' exactly the On Error Resume Next / Err.Number pattern already used in
' Public/Default.asp - an error raised in a called procedure with no error
' handling of its own is caught by the caller's active On Error Resume Next.
Sub RunTest(ByVal testName, ByVal procName)
    g_TestsRun = g_TestsRun + 1

    On Error Resume Next
    Err.Clear
    Execute procName & "()"

    If Err.Number <> 0 Then
        RecordFailure testName, Err.Description
    Else
        g_TestsPassed = g_TestsPassed + 1
    End If
    On Error Goto 0
End Sub

Sub RecordFailure(ByVal testName, ByVal message)
    g_Failures.Add g_Failures.Count, testName & " -- " & message
End Sub

Sub PrintSummary()
    Dim failureKey

    WScript.Echo ""
    WScript.Echo "----------------------------------------"
    WScript.Echo g_TestsPassed & " / " & g_TestsRun & " tests passed"

    If g_Failures.Count > 0 Then
        WScript.Echo ""
        WScript.Echo "Failures:"
        For Each failureKey In g_Failures.Keys
            WScript.Echo "  - " & g_Failures.Item(failureKey)
        Next
    End If

    WScript.Echo "----------------------------------------"
End Sub

Function HasFailures()
    HasFailures = (g_Failures.Count > 0)
End Function

' --- Assertions ---

Sub AssertEquals(ByVal expected, ByVal actual, ByVal message)
    If Not (expected = actual) Then
        Fail message & " (expected [" & CStr(expected) & "] but got [" & CStr(actual) & "])"
    End If
End Sub

Sub AssertTrue(ByVal condition, ByVal message)
    If Not condition Then
        Fail message & " (expected True)"
    End If
End Sub

Sub AssertFalse(ByVal condition, ByVal message)
    If condition Then
        Fail message & " (expected False)"
    End If
End Sub

Sub AssertIsNothing(ByVal value, ByVal message)
    If Not (value Is Nothing) Then
        Fail message & " (expected Nothing)"
    End If
End Sub

Sub AssertNotNothing(ByVal value, ByVal message)
    If value Is Nothing Then
        Fail message & " (expected an object, got Nothing)"
    End If
End Sub

Sub Fail(ByVal message)
    Err.Raise ASSERTION_FAILED, "Assert", message
End Sub

' --- Loading Core/*.asp class files outside IIS ---
' These files are plain "<% Class ... End Class %>" blocks with no mixed HTML
' and (deliberately - see CLAUDE.md) no Option Explicit of their own, so
' stripping the ASP delimiters and running the remainder through ExecuteGlobal
' loads the same class definitions IIS would compile, without needing IIS.

Sub IncludeAspClass(ByVal path)
    Dim raw
    Dim code
    Dim openPos
    Dim closePos

    raw = ReadFileText(path)
    openPos = InStr(raw, "<%")
    closePos = InStrRev(raw, "%>")

    If openPos = 0 Or closePos = 0 Or closePos <= openPos Then
        Err.Raise vbObjectError + 1998, "IncludeAspClass", "No <% %> block found in: " & path
    End If

    code = Mid(raw, openPos + 2, closePos - (openPos + 2))
    ExecuteGlobal code
End Sub

Sub IncludeVbsFile(ByVal path)
    ExecuteGlobal ReadFileText(path)
End Sub

Function ReadFileText(ByVal path)
    Dim fso
    Dim stream

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set stream = fso.OpenTextFile(path, 1)
    ReadFileText = stream.ReadAll
    stream.Close
End Function

' --- ASP intrinsic stand-ins ---
' Global variables literally named Server/Response so Core/*.asp's
' "Server.CreateObject(...)" / "Server.HTMLEncode(...)" / "Response.Status = ..."
' resolve to these instead of the real (IIS-only) intrinsics.

Function RealCreateObject(ByVal progId)
    Set RealCreateObject = CreateObject(progId)
End Function

Function SimpleHtmlEncode(ByVal text)
    Dim result
    result = CStr(text)
    result = Replace(result, "&", "&amp;")
    result = Replace(result, "<", "&lt;")
    result = Replace(result, ">", "&gt;")
    result = Replace(result, """", "&quot;")
    SimpleHtmlEncode = result
End Function

Class FakeServer
    Public Function CreateObject(ByVal progId)
        Set CreateObject = RealCreateObject(progId)
    End Function

    Public Function HTMLEncode(ByVal text)
        HTMLEncode = SimpleHtmlEncode(text)
    End Function

    Public Function MapPath(ByVal relativePath)
        MapPath = "C:\fake-physical-root" & relativePath
    End Function
End Class

Class FakeResponse
    Public Status
    Public Buffer
    Public ContentType

    Private m_Output

    Private Sub Class_Initialize()
        Status = "200 OK"
        Buffer = False
        ContentType = ""
        m_Output = ""
    End Sub

    Public Sub Write(ByVal text)
        m_Output = m_Output & text
    End Sub

    Public Property Get Output()
        Output = m_Output
    End Property
End Class

' A neutral dummy object for tests that just need "some object" to register
' as a service - not a stand-in for any real ASP intrinsic.
Class FakeService
    Public Marker
End Class

' A stand-in for the real ASP Request object that Core/HttpRequest.asp's
' Bind() expects - only implements what the current code paths touch.
Class FakeAspRequest
    Private m_ServerVariables
    Private m_QueryString
    Private m_Form
    Private m_Cookies

    Private Sub Class_Initialize()
        Set m_ServerVariables = CreateObject("Scripting.Dictionary")
        Set m_QueryString = CreateObject("Scripting.Dictionary")
        Set m_Form = CreateObject("Scripting.Dictionary")
        Set m_Cookies = CreateObject("Scripting.Dictionary")
    End Sub

    Public Sub SetServerVariable(ByVal key, ByVal value)
        m_ServerVariables.Item(CStr(key)) = value
    End Sub

    Public Sub SetQueryString(ByVal key, ByVal value)
        m_QueryString.Item(CStr(key)) = value
    End Sub

    Public Sub SetForm(ByVal key, ByVal value)
        m_Form.Item(CStr(key)) = value
    End Sub

    Public Sub SetCookie(ByVal key, ByVal value)
        m_Cookies.Item(CStr(key)) = value
    End Sub

    Public Function ServerVariables(ByVal key)
        If m_ServerVariables.Exists(CStr(key)) Then
            ServerVariables = m_ServerVariables.Item(CStr(key))
        Else
            ServerVariables = ""
        End If
    End Function

    Public Function QueryString(ByVal key)
        If m_QueryString.Exists(CStr(key)) Then
            QueryString = m_QueryString.Item(CStr(key))
        Else
            QueryString = ""
        End If
    End Function

    Public Function Form(ByVal key)
        If m_Form.Exists(CStr(key)) Then
            Form = m_Form.Item(CStr(key))
        Else
            Form = ""
        End If
    End Function

    Public Function Cookies(ByVal key)
        If m_Cookies.Exists(CStr(key)) Then
            Cookies = m_Cookies.Item(CStr(key))
        Else
            Cookies = ""
        End If
    End Function

    Public Default Function Item(ByVal key)
        If m_QueryString.Exists(CStr(key)) Then
            Item = m_QueryString.Item(CStr(key))
        ElseIf m_Form.Exists(CStr(key)) Then
            Item = m_Form.Item(CStr(key))
        ElseIf m_Cookies.Exists(CStr(key)) Then
            Item = m_Cookies.Item(CStr(key))
        ElseIf m_ServerVariables.Exists(CStr(key)) Then
            Item = m_ServerVariables.Item(CStr(key))
        Else
            Item = ""
        End If
    End Function
End Class

Dim Server
Dim Response

Set Server = New FakeServer
Set Response = New FakeResponse