vbcgi.bas

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

Attribute VB_Name = "Module1"
'----------------------------------------------------------------------
'       *************
'       * CGI32.BAS *
'       *************
'
' VERSION: 1.5  (November 20, 1995)
'
' AUTHOR:  Robert B. Denny <[e-mail]>
'
' Common routines needed to establish a VB environment for
' Windows CGI programs that run behind the WebSite Server.
'
' INTRODUCTION
'
' The Common Gateway Interface (CGI) version 1.1 specifies a minimal
' set of data that is made available to the back-end application by
' an HTTP (Web) server. It also specifies the details for passing this
' information to the back-end. The latter part of the CGI spec is
' specific to Unix-like environments. The NCSA httpd for Windows does
' supply the data items (and more) specified by CGI/1.1, however it
' uses a different method for passing the data to the back-end.
'
' DEVELOPMENT
'
' WebSite requires any Windows back-end program to be an
' executable image. This means that you must convert your VB
' application into an executable (.EXE) before it can be tested
' with the server.
'
' ENVIRONMENT
'
' The WebSite server executes script requests by doing a
' CreateProcess with a command line in the following form:
'
'   prog-name cgi-profile
'
' THE CGI PROFILE FILE
'
' The Unix CGI passes data to the back end by defining environment
' variables which can be used by shell scripts. The WebSite
'---------------------------------------------------------------------------
'
'   InitializeCGI() - Fill in all of the CGI variables, etc.
'
' Read the profile file name from the command line, then fill in
' the CGI globals, the Accept type list and the Extra headers list.
' Then open the input and output files.
'
' Returns True if OK, False if some sort of error. See ReturnError()
' for info on how errors are handled.
'
' NOTE: Assumes that the CGI error handler has been armed with On Error
'---------------------------------------------------------------------------
Sub InitializeCGI()
    Dim sect As String
    Dim argc As Integer
    Static argv(MAX_CMDARGS) As String
    Dim buf As String

    CGI_DebugMode = True    ' Initialization errors are very bad

    '
    ' Parse the command line. We need the profile file name (duh!)
    ' and the output file name NOW, so we can return any errors we
    ' trap. The error handler writes to the output file.
    '
    argc = GetArgs(argv())
    CGI_ProfileFile = argv(0)

    sect = "CGI"
    CGI_ServerSoftware = GetProfile(sect, "Server Software")
    CGI_ServerName = GetProfile(sect, "Server Name")
    CGI_RequestProtocol = GetProfile(sect, "Request Protocol")
    CGI_ServerAdmin = GetProfile(sect, "Server Admin")
    CGI_Version = GetProfile(sect, "CGI Version")
    CGI_RequestMethod = GetProfile(sect, "Request Method")
    buf = GetProfile(sect, "Request Keep-Alive")    ' Y or N
    If (Left$(buf, 1) = "Y") Then                   ' Must start with Y
        CGI_RequestKeepAlive = True
    Else
        CGI_RequestKeepAlive = False
    End If
    CGI_LogicalPath = GetProfile(sect, "Logical Path")
    CGI_PhysicalPath = GetProfile(sect, "Physical Path")
    CGI_ExecutablePath = GetProfile(sect, "Executable Path")
    CGI_QueryString = GetProfile(sect, "Query String")
    CGI_RemoteHost = GetProfile(sect, "Remote Host")
    CGI_RemoteAddr = GetProfile(sect, "Remote Address")
    CGI_Referer = GetProfile(sect, "Referer")
    CGI_From = GetProfile(sect, "From")
    CGI_AuthUser = GetProfile(sect, "Authenticated Username")
    CGI_AuthPass = GetProfile(sect, "Authenticated Password")
    CGI_AuthRealm = GetProfile(sect, "Authentication Realm")
    CGI_AuthType = GetProfile(sect, "Authentication Method")
    CGI_ContentType = GetProfile(sect, "Content Type")
    buf = GetProfile(sect, "Content Length")
    If buf = "" Then
        CGI_ContentLength = 0
    Else
        CGI_ContentLength = CLng(buf)
    End If
    buf = GetProfile(sect, "Server Port")
    If buf = "" Then
        CGI_ServerPort = -1
    Else
        CGI_ServerPort = CInt(buf)
    End If

    sect = "System"
    CGI_ContentFile = GetProfile(sect, "Content File")
    CGI_OutputFile = GetProfile(sect, "Output File")
    CGI_OutputFN = FreeFile
    Open CGI_OutputFile For Output Access Write As #CGI_OutputFN
    buf = GetProfile(sect, "GMT Offset")
    If buf <> "" Then                             ' Protect against errors
        CGI_GMTOffset = CVDate(Val(buf) / 86400#) ' Timeserial GMT offset
    Else
        CGI_GMTOffset = 0
    End If
    buf = GetProfile(sect, "Debug Mode")    ' Y or N
    If (Left$(buf, 1) = "Y") Then           ' Must start with Y
        CGI_DebugMode = True
    Else
        CGI_DebugMode = False
    End If

    GetAcceptTypes          ' Enumerate Accept: types into tuples
    GetExtraHeaders         ' Enumerate extra headers into tuples
    GetFormTuples           ' Decode any POST form input into tuples

End Sub

'----------------------------------------------------------------------
'
' Get the value of a "small" form field given the key
'
' Signals an error if field does not exist
'
'----------------------------------------------------------------------
Function GetSmallField(key As String) As String
    Dim i As Integer

    For i = 0 To (CGI_NumFormTuples - 1)
        If CGI_FormTuples(i).key = key Then
            GetSmallField = Trim$(CGI_FormTuples(i).value)
            Exit Function           ' ** DONE **
        End If
    Next i
    '
    ' Field does not exist
    '
    Error ERR_NO_FIELD
End Function

'---------------------------------------------------------------------------
'
'   GetProfile() - Get a value or enumerate keys in CGI_Profile file
'
' Get a value given the section and key, or enumerate keys given the
' section name and "" for the key. If enumerating, the list of keys for
' the given section is returned as a null-separated string, with a
' double null at the end.
'
' VB handles this with flair! I couldn't believe my eyes when I tried this.
'---------------------------------------------------------------------------
Private Function GetProfile(sSection As String, sKey As String) As String
    Dim retLen As Long
    Dim buf As String * ENUM_BUF_SIZE

    If sKey <> "" Then
        retLen = GetPrivateProfileString(sSection, sKey, "", buf, ENUM_BUF_SIZE, CGI_ProfileFile)
    Else
        retLen = GetPrivateProfileString(sSection, 0&, "", buf, ENUM_BUF_SIZE, CGI_ProfileFile)
    End If
    If retLen = 0 Then
        GetProfile = ""
    Else
        GetProfile = Left$(buf, retLen)
    End If

End Function

'---------------------------------------------------------------------------
'
'   GetFormTuples() - Create the array of POST form input key=value pairs
'
'---------------------------------------------------------------------------
Private Sub GetFormTuples()
    Dim sList As String
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim s As Long
    Dim buf As String
    Dim extName As String
    Dim extFile As Integer
    Dim extlen As Long

    n = 0                                   ' Index in array

    '
    ' Do the easy one first: [Form Literal]
    '
    sList = GetProfile("Form Literal", "")  ' Get key list
    l = Len(sList)                          ' Length incl. trailing null
    i = 1                                   ' Start at 1st character
    Do While ((i < l) And (n < MAX_FORM_TUPLES)) ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_FormTuples(n).key = Mid$(sList, i, j - i) ' Get Key, then value
        CGI_FormTuples(n).value = GetProfile("Form Literal", CGI_FormTuples(n).key)
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop
    '
    ' Now do the external ones: [Form External]
    '
    sList = GetProfile("Form External", "") ' Get key list
    l = Len(sList)                          ' Length incl. trailing null
    i = 1                                   ' Start at 1st character
    extFile = FreeFile
    Do While ((i < l) And (n < MAX_FORM_TUPLES)) ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_FormTuples(n).key = Mid$(sList, i, j - i) ' Get Key, then pathname
        buf = GetProfile("Form External", CGI_FormTuples(n).key)
        k = InStr(buf, " ")                 ' Split file & length
        extName = Mid$(buf, 1, k - 1)           ' Pathname
        k = k + 1
        extlen = CLng(Mid$(buf, k, Len(buf) - k + 1)) ' Length
        '
        ' Use feature of GET to read content in one call
        '
        Open extName For Binary Access Read As #extFile
        CGI_FormTuples(n).value = String$(extlen, " ") ' Breathe in...
        Get #extFile, , CGI_FormTuples(n).value 'GULP!
        Close #extFile
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop

    CGI_NumFormTuples = n                   ' Number of fields decoded
    n = 0                                   ' Reset counter
    '
    ' Next, the [Form Huge] section. Will this ever get executed?
    '
    sList = GetProfile("Form Huge", "")     ' Get key list
    l = Len(sList)                          ' Length incl. trailing null
    i = 1                                   ' Start at 1st character
    Do While ((i < l) And (n < MAX_FORM_TUPLES)) ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_HugeTuples(n).key = Mid$(sList, i, j - i) ' Get Key
        buf = GetProfile("Form Huge", CGI_HugeTuples(n).key) ' "offset length"
        k = InStr(buf, " ")                 ' Delimiter
        CGI_HugeTuples(n).offset = CLng(Mid$(buf, 1, (k - 1)))
        CGI_HugeTuples(n).length = CLng(Mid$(buf, k, (Len(buf) - k + 1)))
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop
    
    CGI_NumHugeTuples = n                   ' Fill in global count

    n = 0                                   ' Reset counter
    '
    ' Finally, the [Form File] section.
    '
    sList = GetProfile("Form File", "")     ' Get key list
    l = Len(sList)                          ' Length incl. trailing null
    i = 1                                   ' Start at 1st character
    Do While ((i < l) And (n < MAX_FILE_TUPLES)) ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_FileTuples(n).key = Mid$(sList, i, j - i) ' Get Key
        buf = GetProfile("Form File", CGI_FileTuples(n).key)
        ParseFileValue buf, CGI_FileTuples(n)  ' Complicated, use Sub
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop
    
    CGI_NumFileTuples = n                   ' Fill in global count

End Sub

'---------------------------------------------------------------------------
'
'   GetExtraHeaders() - Create the array of extra header structs
'
' Enumerate the keys in the [Extra Headers] section of the profile file,
' then get the value for each of the keys.
'---------------------------------------------------------------------------
Private Sub GetExtraHeaders()
    Dim sList As String
    Dim i As Integer, j As Integer, l As Integer, n As Integer

    sList = GetProfile("Extra Headers", "") ' 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_XHDR))   ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_ExtraHeaders(n).key = Mid$(sList, i, j - i) ' Get Key, then value
        CGI_ExtraHeaders(n).value = GetProfile("Extra Headers", CGI_ExtraHeaders(n).key)
        i = j + 1                           ' Bump pointer
        n = n + 1                           ' Bump array index
    Loop
    CGI_NumExtraHeaders = n                 ' Fill in global count

End Sub

'---------------------------------------------------------------------------
'
'   GetExtraHeaders() - Create the array of extra header structs
'
' Enumerate the keys in the [Extra Headers] section of the profile file,
' then get the value for each of the keys.
'---------------------------------------------------------------------------
Private Sub GetExtraHeaders()
    Dim sList As String
    Dim i As Integer, j As Integer, l As Integer, n As Integer

    sList = GetProfile("Extra Headers", "") ' 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_XHDR))   ' Safety stop here
        j = InStr(i, sList, Chr$(0))        ' J -> next null
        CGI_ExtraHeaders(n).key = Mid$(sList, i, j - i) ' Get Key, then value
        CGI_ExtraHeaders(n).value = GetProfile("Extra Headers", CGI_ExtraHeaders(n).key)
        i = j + 1                           ' Bump pointer