cgidebug.bas

加入一个用VB编写CGI的VB源程序。（你需要在Win98上首先安装20Personal WebServer

Sub GetFormData()
'====================================================
' Get the CGI data from STDIN and/or from QueryString
' Store name/value pairs
'====================================================
Dim sBuff      As String    ' buffer to receive POST method data
Dim lBytesRead As Long      ' actual bytes read by ReadFile()
Dim rc         As Long      ' return code

' Method POST - get CGI data from STDIN
' Method GET  - get CGI data from QueryString environment variable
'
If CGI_RequestMethod = "POST" Then
   If bDebug = True Then
      sFormData = GetSetting(sRegName, sRegSect, "sFormData")
   Else
      sBuff = String(lContentLength, Chr$(0))
      Do While Len(sFormData) < lContentLength
         rc = ReadFile(hStdIn, ByVal sBuff, lContentLength, lBytesRead, ByVal 0&)
         sFormData = sFormData & Left$(sBuff, lBytesRead)
      Loop
      
      SaveSetting sRegName, sRegSect, "sFormData", sFormData
   End If
   
   ' Make sure posted data is url-encoded
   ' Multipart content types, for example, are not necessarily encoded.
   '
   If InStr(1, CGI_ContentType, "www-form-urlencoded", 1) Then
      StorePairs sFormData
   End If
End If
StorePairs CGI_QueryString
End Sub

Sub StorePairs(sData As String)
'=====================================================================
' Parse and decode form data and/or query string
' Data is received from server as "name=value&name=value&...name=value"
' Names and values are URL-encoded
'
' Store name/value pairs in array tPair(), and decode them
'
' Note: if an element in the query string does not contain an "=",
'       then it will not be stored.
'
' /cgi-bin/pgm.exe?parm=1   "1" gets stored and can be
'                               retrieved with getCgiValue("parm")
' /cgi-bin/pgm.exe?1        "1" does not get stored, but can be
'                               retrieved with urlDecode(CGI_QueryString)
'
'======================================================================
Dim pointer    As Long      ' sData position pointer
Dim n          As Long      ' name/value pair counter
Dim delim1     As Long      ' position of "="
Dim delim2     As Long      ' position of "&"
Dim lastPair   As Long      ' size of tPair() array
Dim lPairs     As Long      ' number of name=value pairs in sData

lastPair = UBound(tPair)    ' current size of tPair()
delim1 = 0
Do
  delim1 = InStr(delim1 + 1, sData, "=")
  If delim1 = 0 Then Exit Do
  lPairs = lPairs + 1
Loop

If lPairs = 0 Then Exit Sub  'nothing to add

' redim tPair() based on the number of pairs found in sData
ReDim Preserve tPair(lastPair + lPairs) As pair

' assign values to tPair().name and tPair().value
pointer = 1
For n = (lastPair + 1) To UBound(tPair)
   delim1 = InStr(pointer, sData, "=") ' find next equal sign
   If delim1 = 0 Then Exit For         ' parse complete

   tPair(n).Name = UrlDecode(Mid$(sData, pointer, delim1 - pointer))
   
   delim2 = InStr(delim1, sData, "&")

   ' if no trailing ampersand, we are at the end of data
   If delim2 = 0 Then delim2 = Len(sData) + 1
 
   ' value is between the "=" and the "&"
   tPair(n).Value = UrlDecode(Mid$(sData, delim1 + 1, delim2 - delim1 - 1))
   
   pointer = delim2 + 1
Next n
End Sub

Public Function UrlDecode(ByVal sEncoded As String) As String
'========================================================
' Accept url-encoded string
' Return decoded string
'========================================================

Dim pos        As Long      ' position of InStr target

If sEncoded = "" Then Exit Function

' convert "+" to space
pos = 0
Do
   pos = InStr(pos + 1, sEncoded, "+")
   If pos = 0 Then Exit Do
   Mid$(sEncoded, pos, 1) = " "
Loop
    
' convert "%xx" to character
pos = 0

On Error GoTo errorUrlDecode
Do
   pos = InStr(pos + 1, sEncoded, "%")
   If pos = 0 Then Exit Do
   
   Mid$(sEncoded, pos, 1) = Chr$("&H" & (Mid$(sEncoded, pos + 1, 2)))
   sEncoded = Left$(sEncoded, pos) _
             & Mid$(sEncoded, pos + 3)
Loop
On Error GoTo 0     'reset error handling
UrlDecode = sEncoded
Exit Function

errorUrlDecode:
'--------------------------------------------------------------------
' If this function was mistakenly called with the following:
'    UrlDecode("100% natural")
' a type-mismatch error would be raised when trying
' to convert " n" from hex to character.
' Instead, a more descriptive error message will be generated.
'--------------------------------------------------------------------
Err.Clear
Err.Raise 65001, , "Invalid data passed to UrlDecode() function."
Resume Next
End Function

Function GetCgiValue(cgiName As String) As String
'====================================================================
' Accept the name of a pair
' Return the value matching the name
'
' tPair(0) is always empty.
' An empty string will be returned
'    if cgiName is not defined in the form (programmer error)
'    or, a select type form item was used, but no item was selected.
'
' Multiple values, separated by a semi-colon, will be returned
'     if the form item uses the "multiple" option
'     and, more than one selection was chosen.
'     The calling procedure must parse this string as needed.
'====================================================================
Dim n As Integer

For n = 1 To UBound(tPair)
    If UCase$(cgiName) = UCase$(tPair(n).Name) Then
       If GetCgiValue = "" Then
          GetCgiValue = tPair(n).Value
       Else             ' allow for multiple selections
          GetCgiValue = GetCgiValue & ";" & tPair(n).Value
       End If
    End If
Next n
End Function

Sub SendHeader(sTitle As String)
Send "Status: 200 OK"
Send "Content-type: text/html" & vbCrLf
Send "<HTML><HEAD><TITLE>" & sTitle & "</TITLE></HEAD>"
Send "<BODY>"
End Sub

Sub SendFooter()
'==================================
' standardized footers can be added
'==================================
Send "</BODY></HTML>"
End Sub

Sub Send(s As String)
'======================
' Send output to STDOUT
'======================
Dim rc            As Long
Dim lBytesWritten As Long

If bDebug Then
   Debug.Print s
Else
   s = s & vbCrLf
   rc = WriteFile(hStdOut, s, Len(s), lBytesWritten, ByVal 0&)
End If
End Sub

Sub SendB(s As String)
'============================================
' Send output to STDOUT without vbCrLf.
' Use when sending binary data. For example,
' images sent with "Content-type image/jpeg".
'============================================
Dim rc            As Long
Dim lBytesWritten As Long

If bDebug Then
   Debug.Print s
Else
   rc = WriteFile(hStdOut, s, Len(s), lBytesWritten, ByVal 0&)
End If
End Sub

Public Sub Dump()
'---------------------------------------------
' Dump can be called from the debug window by
' typing "Dump". It will display environment
' variables, posted data, and array tPair()
'---------------------------------------------
Const SEPARATOR As String = "________________________________________"
Dim vVars       As Variant 'array to hold settings
Dim x           As Long    'counter

On Error Resume Next
Debug.Print SEPARATOR

'print stored settings from the registry

If sRegName = "" Or sRegSect = "" Then
   Debug.Print "Registry values have not been retrieved yet"
Else
   vVars = GetAllSettings(sRegName, sRegSect)
   If vVars(0, 0) = "" Then
      Debug.Print "No settings found"
   Else
      For x = 0 To UBound(vVars)
        Debug.Print vVars(x, 0) & "  " & vVars(x, 1)
      Next x
   End If
End If
Debug.Print SEPARATOR

'print tPair()

Debug.Print "tPair() array"
For x = 0 To UBound(tPair)
   If Err.Number = 9 Then  'tPair() is initialized in storePairs()
      Debug.Print "tPair() has not been initialized yet"
      Exit For
   End If
   Debug.Print Str$(x) & "  " & tPair(x).Name & "  " & tPair(x).Value
Next x
Debug.Print SEPARATOR
End Sub