Web Extender サンプルコード

このサンプルプログラムソースコードはリンクタグにより起動され、CGI環境変数の値をHTML形式ででブラウザに返すものです。
コンパイル後のDLL名はAllResponse.dllとした場合、リンクタグは以下の内容になります。
<A HREF="/scripts/gwiisole.dll/AllResponse.MainClass.Action">

----------------------------------------------------------------------------
VERSION 1.0 CLASS
----------------------------------------------------------------------------
BEGIN
  MultiUse = -1  'True
END
----------------------------------------------------------------------------
Attribute VB_Name = "MainClass"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
----------------------------------------------------------------------------
Option Explicit
Public AUTH_TYPE As String
Public CONTENT_LENGTH As String
Public CONTENT_TYPE As String
Public GATEWAY_INTERFACE As String
Public PATH_INFO As String
Public PATH_TRANSLATED As String
Public QUERY_STRING As String
Public REMOTE_ADDR As String
Public REMOTE_HOST As String
Public REMOTE_USER As String
Public REQUEST_METHOD As String
Public SCRIPT_NAME As String
Public SERVER_NAME As String
Public SERVER_PORT As String
Public SERVER_PROTOCOL As String
Public SERVER_SOFTWARE As String
Public AUTH_PASS As String
Public ALL_HTTP As String
Public HTTP_ACCEPT As String
Public HTTP_USER_AGENT As String
Public AUTH_USER As String
Public HTTP_COOKIE As String

'ヘッダー定義
Const ContentTypeMsg = "Content-Type: text/html" & vbCrLf & vbCrLf

'//基本認証に関する定義
Const USERAUTHNEED = False
Const AUTHMSG = "WWW-Authenticate: Basic realm="" PWTEST Example"""
Const RefuseMsg = "<HTML><body> <H1>認証できませんでした。<P>" _
                  & "正しいアカウントを取得してください</H1></body></HTML> "

'//ダイレクト URL レスポンスに関する定義
Const DirectResponce = False
Const ArrowURL = ""

'//COOKIEに関する定義
Const NEEDCOOKIE = False

----------------------------------------------------------------------------
Private Function CheckAuth() As Integer
'//ユーザー認証のコードを記述します。
CheckAuth = True
End Function
----------------------------------------------------------------------------
Private Function CreateCookie() As String
'//COOKIEを使用する場合ここに記述します。

If NEEDCOOKIE Then
    CreateCookie = "Set-Cookie: NAME=""aBcDe""" & vbCrLf
Else
    CreateCookie = ""
End If
End Function
----------------------------------------------------------------------------
Private Function CreateHeader() As String
'//ヘッダーを作成します。

Dim ResponseNo As String
If Not USERAUTHNEED Then
        ResponseNo = "0"
    ElseIf Trim$(AUTH_USER) = "" Then
        ResponseNo = "1"
    ElseIf CheckAuth Then
        ResponseNo = "0"
    Else
        ResponseNo = "1"
    End If
    
    If DirectResponce And ResponseNo = "0" Then ResponseNo = "2"
    
    If ResponseNo = "0" Then
        CreateHeader = ResponseNo & CreateCookie() & ContentTypeMsg
    ElseIf ResponseNo = "1" Then
        CreateHeader = ResponseNo & AUTHMSG & ContentTypeMsg & RefuseMsg
    Else
        CreateHeader = ResponseNo & ArrowURL
    End If
End Function
----------------------------------------------------------------------------
Private Function CreateResponse(request As String) As String
Dim Response As String
Dim ResponseNo As String
Dim Heder As String
    Heder = CreateHeader()
    If Left$(Heder, 1) = "0" Then
        '//ここに認証できた場合のHTMLをヘッダーを含めて記述します。
        Response = Heder & _
                   "<body><h1>すべてのCGI環境変数を返しました。" & "</h1>" _
                   & "<H4>"
        Response = Response & "REQUEST :" & request & "<BR>"
        Response = Response & "AUTH_TYPE :" & AUTH_TYPE & "<BR>"
        Response = Response & "CONTENT_LENGTH :" & CONTENT_LENGTH & "<BR>"
        Response = Response & "CONTENT_TYPE :" & CONTENT_TYPE & "<BR>"
        Response = Response & "GATEWAY_INTERFACE :" & GATEWAY_INTERFACE & "<BR>"
        Response = Response & "PATH_INFO :" & PATH_INFO & "<BR>"
        Response = Response & "PATH_TRANSLATED :" & PATH_TRANSLATED & "<BR>"
        Response = Response & "QUERY_STRING :" & QUERY_STRING & "<BR>"
        Response = Response & "REMOTE_ADDR :" & REMOTE_ADDR & "<BR>"
        Response = Response & "REMOTE_HOST :" & REMOTE_HOST & "<BR>"
        Response = Response & "REMOTE_USER :" & REMOTE_USER & "<BR>"
        Response = Response & "REQUEST_METHOD :" & REQUEST_METHOD & "<BR>"
        Response = Response & "SCRIPT_NAME :" & SCRIPT_NAME & "<BR>"
        Response = Response & "SERVER_NAME :" & SERVER_NAME & "<BR>"
        Response = Response & "SERVER_PORT :" & SERVER_PORT & "<BR>"
        Response = Response & "SERVER_PROTOCOL :" & SERVER_PROTOCOL & "<BR>"
        Response = Response & "SERVER_SOFTWARE :" & SERVER_SOFTWARE & "<BR>"
        Response = Response & "AUTH_PASS :" & AUTH_PASS & "<BR>"
        Response = Response & "HTTP_COOKIE :" & HTTP_COOKIE & "<BR>"
        Response = Response & "HTTP_ACCEPT :" & HTTP_ACCEPT & "<BR>"
        Response = Response & "HTTP_USER_AGENT :" & HTTP_USER_AGENT & "<BR>"
        Response = Response & "AUTH_USER :" & AUTH_USER & "<BR>"
        Response = Response & "ALL_HTTP :" & ALL_HTTP & "<BR>"
        CreateResponse = Response & "</H4></body>"
    Else
        CreateResponse = Heder
    End If
End Function
----------------------------------------------------------------------------
Sub Action(request As String, Response As String)
Dim resp As String
    On Error GoTo Erl
    resp = CreateResponse(request)
    Response = StrConv(resp, vbFromUnicode)
    Exit Sub
Erl:
    resp = "0" & ContentTypeMsg & "<H3> Visual Bsaic Error No =" & _ 
           Str$(Err) & "<P>" & Error$ & "</H3>"
    Response = StrConv(resp, vbFromUnicode)
End Sub
----------------------------------------------------------------------------