cgidebug.bas

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

Attribute VB_Name = "cgiDEBUG"
Option Explicit
'=====================================================================
' CGIDEBUG.BAS - debug module to replace CGI4VB.BAS
' Version: 1.5 (September 1997)
' Author : Kevin O'Brien [[e-mail]]
'                        [[e-mail]]
'---------------------------------------------------------------------
' CGIDEBUG.BAS contains the same code as CGI4VB.BAS (version 1.4)
'              except for the following:
'
' - bDebug, sRegName, and sRegSect Public variables have been added.
'
' - GetModuleFileName() API has been added to determine
'                  if the program is running in interactive mode.
' - SetDebugMode() has been added and is called from InitCgi()
' - Environ()      has been added and overrides VB's built-in Environ().
' - Dump()         has been added and can be called from the Debug
'                  window by typing "Dump". This will display the
'                  environment variables, posted data, and array tPair().
' - GetFormData(), Send() and SendB() have been modified
'                  to handle bDebug = True or False.
'---------------------------------------------------------------------
' How to use CGIDEBUG
' 1. Replace CGI4VB.BAS with CGIDEBUG.BAS and recompile your CGI script.
'
' 2. Run the EXE as a cgi script on the web server (as you normally would).
'    All environment variables and posted data will be saved in the
'    Windows Registry.
'
' 3. Run the program interactively from within the VB IDE.
'    All environment variables and form fields will be retrieved from
'    the Windows Registry (as they were written in step 2).
'    Send() and SendB() statements will be written to the Debug Window.
'    Use the VB debugger to step through the program.
'
'    If you want to view or edit the registry -
'    Run regedit.exe, then find:
'    HKEY_USERS\.Default\Software
'              \VB and VBA program settings\cgiDebug\<cgi-script>
'
' 4. Replace CGIDEBUG.BAS with CGI4VB.BAS when you're done
'    and ready to move your script back into "production".
'
' Note: The web server and VB IDE must be on the same operating system.
'       Otherwise you'll be writing to the registry where the
'       web server is installed, and reading from the registry where
'       VB is installed.
'
'       Posted content containing binary data will not get saved
'       properly in the registry, because the data will be truncated
'       at the first hex zero. Content-types like */octet-stream will
'       not work. If you are debugging a file upload script, be aware
'       of this limitation.
'       Content-type is usually not binary. A typical HTML form sends
'       data with a content-type of application/x-www-form-urlencoded,
'       which works fine.
'=====================================================================

Declare Function GetStdHandle Lib "kernel32" _
    (ByVal nStdHandle As Long) As Long
Declare Function ReadFile Lib "kernel32" _
    (ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    lpOverlapped As Any) As Long
Declare Function WriteFile Lib "kernel32" _
    (ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    lpOverlapped As Any) As Long
Declare Function SetFilePointer Lib "kernel32" _
   (ByVal hFile As Long, _
   ByVal lDistanceToMove As Long, _
   lpDistanceToMoveHigh As Long, _
   ByVal dwMoveMethod As Long) As Long
Declare Function SetEndOfFile Lib "kernel32" _
   (ByVal hFile As Long) As Long
Declare Function GetModuleFileName Lib "kernel32" _
   Alias "GetModuleFileNameA" _
   (ByVal hModule As Long, _
   ByVal lpFileName As String, _
   ByVal nSize As Long) As Long

Public Const STD_INPUT_HANDLE = -10&
Public Const STD_OUTPUT_HANDLE = -11&
Public Const FILE_BEGIN = 0&

' environment variables

Public CGI_Accept            As String
Public CGI_AuthType          As String
Public CGI_Cookie            As String
Public CGI_ContentLength     As String
Public CGI_ContentType       As String
Public CGI_GatewayInterface  As String
Public CGI_PathInfo          As String
Public CGI_PathTranslated    As String
Public CGI_QueryString       As String
Public CGI_Referer           As String
Public CGI_RemoteAddr        As String
Public CGI_RemoteHost        As String
Public CGI_RemoteIdent       As String
Public CGI_RemoteUser        As String
Public CGI_RequestMethod     As String
Public CGI_ScriptName        As String
Public CGI_ServerSoftware    As String
Public CGI_ServerName        As String
Public CGI_ServerPort        As String
Public CGI_ServerProtocol    As String
Public CGI_UserAgent         As String

Public lContentLength As Long    ' CGI_ContentLength converted to Long
Public hStdIn         As Long    ' handle of Standard Input
Public hStdOut        As Long    ' handle of Standard Output
Public sErrorDesc     As String  ' constructed error message
Public sEmail         As String  ' webmaster's/your email address
Public sFormData      As String  ' url-encoded data sent by the server
Public sRegName       As String  ' registry name
Public sRegSect       As String  ' registry section
Public bDebug         As Boolean ' debug switch (True = interactive mode)

Type pair
  Name As String
  Value As String
End Type

Public tPair() As pair           ' array of name=value pairs

Sub Main()

On Error GoTo ErrorRoutine
InitCgi          ' Load environment vars and perform other initialization
GetFormData      ' Read data sent by the server
Cgi_Main         ' Process and return data to server

EndPgm:
   End           ' end program

ErrorRoutine:
   sErrorDesc = Err.Description & " Error Number = " & Str$(Err.Number)
   ErrorHandler
   Resume EndPgm
End Sub

Sub ErrorHandler()
Dim rc As Long

On Error Resume Next
        
' use SetFilePointer API to reset stdOut to BOF
' and SetEndOfFile to reset EOF

rc = SetFilePointer(hStdOut, 0&, 0&, FILE_BEGIN)

SendHeader "Internal Error"
Send "<H1>Error in " & CGI_ScriptName & "</H1>"
    
Send "The following internal error has occurred:"
Send "<PRE>" & sErrorDesc & "</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 "
Send "using, any data you may have entered into a form or search box, "
Send "and anything else that may help us duplicate the problem."
Send "Then contact the administrator of this service: "
Send "<A HREF=""mailto:" & sEmail & """>"
Send "<ADDRESS>&lt;" & sEmail & "&gt;</ADDRESS></A>"
SendFooter
    
rc = SetEndOfFile(hStdOut)

End Sub

Sub InitCgi()

SetDebugMode                    'set debug mode ON or OFF

hStdIn = GetStdHandle(STD_INPUT_HANDLE)
hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)

sEmail = "YourEmailAddress@Here"

'==============================
' Get the environment variables
'==============================
'
' Environment variables will vary depending on the server.
' Replace any variables below with the ones used by your server.
'
CGI_Accept = Environ("HTTP_ACCEPT")
CGI_AuthType = Environ("AUTH_TYPE")
CGI_ContentLength = Environ("CONTENT_LENGTH")
CGI_ContentType = Environ("CONTENT_TYPE")
CGI_Cookie = Environ("HTTP_COOKIE")
CGI_GatewayInterface = Environ("GATEWAY_INTERFACE")
CGI_PathInfo = Environ("PATH_INFO")
CGI_PathTranslated = Environ("PATH_TRANSLATED")
CGI_QueryString = Environ("QUERY_STRING")
CGI_Referer = Environ("HTTP_REFERER")
CGI_RemoteAddr = Environ("REMOTE_ADDR")
CGI_RemoteHost = Environ("REMOTE_HOST")
CGI_RemoteIdent = Environ("REMOTE_IDENT")
CGI_RemoteUser = Environ("REMOTE_USER")
CGI_RequestMethod = Environ("REQUEST_METHOD")
CGI_ScriptName = Environ("SCRIPT_NAME")
CGI_ServerSoftware = Environ("SERVER_SOFTWARE")
CGI_ServerName = Environ("SERVER_NAME")
CGI_ServerPort = Environ("SERVER_PORT")
CGI_ServerProtocol = Environ("SERVER_PROTOCOL")
CGI_UserAgent = Environ("HTTP_USER_AGENT")

lContentLength = Val(CGI_ContentLength)   'convert to long
ReDim tPair(0)                            'initialize name/value array

End Sub

Sub SetDebugMode()
'-------------------------------------------------------
'Determine if program is running interactively
'If running in VB4 IDE then sFileName contains "vb32.exe"
'If running in VB5 IDE then sFileName contains "vb5.exe"
'-------------------------------------------------------
Const LBUFF   As Long = 255 'length of sFileName
Dim rc        As Long       'return code
Dim sFileName As String     'name of program that is executing

sRegName = "cgiDebug"
sRegSect = App.Title
sFileName = String(LBUFF, Chr$(0))

rc = GetModuleFileName(ByVal App.hInstance, ByVal sFileName, LBUFF)

If InStr(1, Left$(sFileName, rc), "vb32.exe", 1) > 0 _
Or InStr(1, Left$(sFileName, rc), "vb5.exe", 1) > 0 Then
    bDebug = True                         'running interactively
Else
    bDebug = False                        'running as a .EXE
    On Error Resume Next                  'first time, nothing to delete
       DeleteSetting sRegName, sRegSect   'clear previous settings
    On Error GoTo 0                       'reset error handling
End If
End Sub

Public Function Environ(sVar As String) As String
'override VBA's Environ function if we are in Debug Mode
If bDebug Then
   Environ = GetSetting(sRegName, sRegSect, sVar)
Else
   Environ = VBA.Environ(sVar)
   SaveSetting sRegName, sRegSect, sVar, Environ
End If
End Function