cgi32.bas

用VB做的CGI程序 用VB做的CGI程序

    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
'---------------------------------------------------------------------------
'
'   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_RequestRange = GetProfile(sect, "Request Range")
    CGI_Referer = GetProfile(sect, "Referer")
    CGI_From = GetProfile(sect, "From")
    CGI_UserAgent = GetProfile(sect, "User Agent")
    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
'----------------------------------------------------------------------
'
'   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
        End                         ' Exit the program
    End If
    
    InitializeCGI       ' Create the CGI environment

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

Cleanup:
    Close #CGI_OutputFN

    End                             ' 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
'----------------------------------------------------------------------
'
'  Send() - Shortcut for writing to output file
'
'----------------------------------------------------------------------
Sub Send(s As String)
    Print #CGI_OutputFN, s
End Sub
'---------------------------------------------------------------------------
'
'   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
'---------------------------------------------------------------------------
'
'   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

'----------------------------------------------------------------------
'
' 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
    
    If (CGI_NumFormTuples = 0) Then Exit Function   ' Stop endless loop
    
    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

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