vbcgi.bas

编写VB CGI程序所必须的模块。

        n = n + 1                           ' Bump array index
    Loop
    CGI_NumExtraHeaders = n                 ' Fill in global count

End Sub

'---------------------------------------------------------------------------
'
'   GetArgs() - Parse the command line
'
' Chop up the command line, fill in the argument vector, return the
' argument count (similar to the Unix/C argc/argv handling)
'---------------------------------------------------------------------------
Private Function GetArgs(argv() As String) As Integer
    Dim buf As String
    Dim i As Integer, j As Integer, l As Integer, n As Integer

    buf = Trim$(Command$)                   ' Get command line

    l = Len(buf)                            ' Length of command line
    If l = 0 Then                           ' If empty
        GetArgs = 0                         ' Return argc = 0
        Exit Function
    End If

    i = 1                                   ' Start at 1st character
    n = 0                                   ' Index in argvec
    Do While ((i < l) And (n < MAX_CMDARGS)) ' Safety stop here
        j = InStr(i, buf, " ")              ' J -> next space
        If j = 0 Then Exit Do               ' Exit loop on last arg
        argv(n) = Trim$(Mid$(buf, i, j - i)) ' Get this token, trim it
        i = j + 1                           ' Skip that blank
        Do While Mid$(buf, i, 1) = " "      ' Skip any additional whitespace
            i = i + 1
        Loop
        n = n + 1                           ' Bump array index
    Loop

    argv(n) = Trim$(Mid$(buf, i, (l - i + 1))) ' Get last arg
    GetArgs = n + 1                         ' Return arg count

End Function

'---------------------------------------------------------------------------
'
'   GetAcceptTypes() - Create the array of accept type structs
'
' Enumerate the keys in the [Accept] section of the profile file,
' then get the value for each of the keys.
'---------------------------------------------------------------------------
Private Sub GetAcceptTypes()
    Dim sList As String
    Dim i As Integer, j As Integer, l As Integer, n As Integer

    sList = GetProfile("Accept", "") ' Get key list
    l = Len(sList)                          ' Length incl. trailing null
    i = 1                                   ' Start at 1st character
    n = 0                                   ' Index in array
    Do While ((i < l) And (n < MAX_ACCTYPE)) ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_AcceptTypes(n).key = Mid$(sList, i, j - i) ' Get Key, then value
        CGI_AcceptTypes(n).value = GetProfile("Accept", CGI_AcceptTypes(n).key)
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop
    CGI_NumAcceptTypes = n                  ' Fill in global count

End Sub

'---------------------------------------------------------------------------
'
'   FindExtraHeader() - Get the text from an "extra" header
'
' Given the extra header's name, return the stuff after the ":"
' or an empty string if not there.
'---------------------------------------------------------------------------
Public Function FindExtraHeader(key As String) As String
    Dim i As Integer

    For i = 0 To (CGI_NumExtraHeaders - 1)
        If CGI_ExtraHeaders(i).key = key Then
            FindExtraHeader = Trim$(CGI_ExtraHeaders(i).value)
            Exit Function           ' ** DONE **
        End If
    Next i
    '
    ' Not present, return empty string
    '
    FindExtraHeader = ""

End Function


'----------------------------------------------------------------------
'
' ParseFileValue() - Parse [Form File] value strings -> file tuples
'
'----------------------------------------------------------------------
Private Sub ParseFileValue(buf As String, ByRef t As FileTuple)
    Dim i, j, k, l As Integer
    
    l = Len(buf)
    
    i = InStr(buf, " ")                     ' First delimiter
    t.file = Mid$(buf, 1, (i - 1))          ' [file]
    t.file = Mid$(t.file, 2, Len(t.file) - 2)  ' file
    
    j = InStr((i + 1), buf, " ")            ' Next delimiter
    t.length = CLng(Mid$(buf, (i + 1), (j - i - 1)))
    i = j
    
    j = InStr((i + 1), buf, " ")            ' Next delimiter
    t.type = Mid$(buf, (i + 1), (j - i - 1))
    i = j
    
    j = InStr((i + 1), buf, " ")            ' Next delimiter
    t.encoding = Mid$(buf, (i + 1), (j - i - 1))
    i = j
    
    t.name = Mid$(buf, (i + 1), (l - i - 1)) ' [name]
    t.name = Mid$(t.name, 2, Len(t.name) - 1) ' name

End Sub

'----------------------------------------------------------------------
'
' x2c() - Convert hex-escaped character to ASCII
'
'----------------------------------------------------------------------
Private Function x2c(s As String) As String
    Dim t As String
    
    t = "&H" & s
    x2c = Chr$(CInt(t))

End Function

'----------------------------------------------------------------------
'
' Unescape() - Convert HTTP-escaped string to normal form
'
'----------------------------------------------------------------------
Public Function Unescape(s As String)
    Dim i As Integer, l As Integer
    Dim c As String
    
    If InStr(s, "%") = 0 Then               ' Catch simple case
        Unescape = s
        Exit Function
    End If
    
    l = Len(s)
    Unescape = ""
    For i = 1 To l
        c = Mid$(s, i, 1)                   ' Next character
        If c = "%" Then
            If Mid$(s, i + 1, 1) = "%" Then
                c = "%"
                i = i + 1                   ' Loop increments too
            Else
                c = x2c(Mid$(s, i + 1, 2))
                i = i + 2                   ' Loop increments too
            End If
        End If
        Unescape = Unescape & c
    Next i

End Function

'----------------------------------------------------------------------
'
' PlusToSpace() - Remove plus-delimiters from HTTP-encoded string
'
'----------------------------------------------------------------------
Public Sub PlusToSpace(s As String)
    Dim i As Integer
    
    i = 1
    Do While True
        i = InStr(i, s, "+")
        If i = 0 Then Exit Do
        Mid$(s, i) = " "
    Loop

End Sub

'----------------------------------------------------------------------
'
' Return True/False depending on whether a form field is present.
' Typically used to detect if a checkbox in a form is checked or
' not. Unchecked checkboxes are omitted from the form content.
'
'----------------------------------------------------------------------
Function FieldPresent(key As String) As Integer
    Dim i As Integer

    FieldPresent = False            ' Assume failure

    For i = 0 To (CGI_NumFormTuples - 1)
        If CGI_FormTuples(i).key = key Then
            FieldPresent = True     ' Found it
            Exit Function           ' ** DONE **
        End If
    Next i
                                    ' Exit with FieldPresent still False
End Function

'---------------------------------------------------------------------------
'
'   WebDate - Return an HTTP/1.0 compliant date/time string
'
' Inputs:   t = Local time as VB Variant (e.g., returned by Now())
' Returns:  Properly formatted HTTP/1.0 date/time in GMT
'---------------------------------------------------------------------------
Function WebDate(dt As Variant) As String
    Dim t As Variant
    
    t = CVDate(dt - CGI_GMTOffset)      ' Convert time to GMT
    WebDate = Format$(t, "ddd dd mmm yyyy hh:mm:ss") & " GMT"

End Function

'---------------------------------------------------------------------------
'
'   SendNoOp() - Tell browser to do nothing.
'
' Most browsers will do nothing. Netscape 1.0N leaves hourglass
' cursor until the mouse is waved around. Enhanced Mosaic 2.0
' oputs up an alert saying "URL leads nowhere". Your results may
' vary...
'
'---------------------------------------------------------------------------
Sub SendNoOp()

    Send ("HTTP/1.0 204 No Response")
    Send ("Server: " + CGI_ServerSoftware)
    Send ("")

End Sub

'----------------------------------------------------------------------
'
'  Send() - Shortcut for writing to output file
'
'----------------------------------------------------------------------
Sub Send(s As String)
    Print #CGI_OutputFN, s
End Sub

'----------------------------------------------------------------------
'
'   main() - CGI script back-end main procedure
'
' This is the main() for the VB back end. Note carefully how the error
' handling is set up, and how program cleanup is done. If no command
' line args are present, call Inter_Main() and exit.
'----------------------------------------------------------------------
Sub Main()
    On Error GoTo ErrorHandler

    If Trim$(Command$) = "" Then    ' Interactive start
        Inter_Main                  ' Call interactive main
        Exit Sub                    ' Exit the program
    End If

    InitializeCGI       ' Create the CGI environment

    '===========
    CGI_Main            ' Execute the actual "script"
    '===========

Cleanup:
    Close #CGI_OutputFN
    Exit Sub                        ' End the program
'------------
ErrorHandler:
    Select Case Err                 ' Decode our "user defined" errors
        Case ERR_NO_FIELD:
            ErrorString = "Unknown form field"
        Case Else:
            ErrorString = Error$    ' Must be VB error
    End Select

    ErrorString = ErrorString & " (error #" & Err & ")"
    On Error GoTo 0                 ' Prevent recursion
    ErrorHandler (Err)              ' Generate HTTP error result
    Resume Cleanup
'------------
End Sub

'---------------------------------------------------------------------------
'
'   ErrorHandler() - Global error handler
'
' If a VB runtime error occurs dusing execution of the program, this
' procedure generates an HTTP/1.0 HTML-formatted error message into
' the output file, then exits the program.
'
' This should be armed immediately on entry to the program's main()
' procedure. Any errors that occur in the program are caught, and
' an HTTP/1.0 error messsage is generated into the output file. The
' presence of the HTTP/1.0 on the first line of the output file causes
' NCSA httpd for WIndows to send the output file to the client with no
' interpretation or other header parsing.
'---------------------------------------------------------------------------
Sub ErrorHandler(code As Integer)

    On Error Resume Next     ' Give it a good try!

    Seek #CGI_OutputFN, 1    ' Rewind output file just in case
    Send ("HTTP/1.0 500 Internal Error")
    Send ("Server: " + CGI_ServerSoftware)
    Send ("Date: " + WebDate(Now))
    Send ("Content-type: text/html")
    Send ("")
    Send ("<HTML><HEAD>")
    Send ("<TITLE>Error in " + CGI_ExecutablePath + "</TITLE>")
    Send ("</HEAD><BODY>")
    Send ("<H1>Error in " + CGI_ExecutablePath + "</H1>")
    Send ("An internal Visual Basic error has occurred in " + CGI_ExecutablePath + ".")
    Send ("<PRE>" + ErrorString + "</PRE>")
    Send ("<I>Please</I> note what you were doing when this problem occurred,")
    Send ("so we can identify and correct it. Write down the Web page you were using,")
    Send ("any data you may have entered into a form or search box, and")
    Send ("anything else that may help us duplicate the problem. Then contact the")
    Send ("administrator of this service: ")