Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/desaware/apitools/apimod1.bas

BASIC Source File | 1996-02-06 | 25.8 KB | 784 lines

Attribute VB_Name = "APIMOD1"
' Copyright (c) 1996 by Desaware
' Part of the Desaware API Toolkit
' All Rights Reserved

Option Explicit

Global Separators$  ' Separators between tokens
Global Const ReturnType$ = "%&!#@$"
Global ReturnTypeName$(7)   ' Individual names

' State for parsing
' 0 = Normal
' 1 = In quote
Dim ParseState%

' Location of special characters in string
Const idComment% = 4    '  ' character
Const idSpace% = 1      ' Space character
Const IdTab% = 7        ' Tab character
Const idQuote% = 8      '  " character
Const idLineCont% = 5   ' _ - Line continuation char

' State machine information
Dim MajorState%      ' Major state as follows:
                        ' 0 - Clear
                        ' 1 - In Comment
                        ' 2 - In Declare
                        ' 3 - In Type
                        ' 4 - In Global
Dim MinorState%     ' Used by individual state machines as follows

' Current category description (via '')
Global Category$

' Object identification information
Type paramType
    ParamName As String ' Name of parameter
    paramType As String
    IsArray As Integer
    IsByVal As Integer
End Type

Global objType%    ' 0 = Clear
                ' 1 = Sub
                ' 2 = Function
                ' 3 = Type
                ' 4 = Constant

Global objName$     ' Name of the object
Global objLib$      ' Library or value for globals
Global objAlias$    ' Alias
Global objReturn%   ' Return type (VB char) - See ReturnTypes$
                    ' 0 - Variant (default)
                    ' 1 - Integer, 2 - Long, 3 - Single, 4 - Double
                    ' 5 - Currency, 6 - String, 7 - Object

Global pDesc() As paramType   ' Array of parameter names or type field names

'
' Initialize the constants
'
Sub am1Initialize()
    ' Characters that separate the tokens
    Separators$ = " ()'_," & Chr$(9) & Chr$(34) & "%#$!@&="
    ' We append the tab and " character as well

    ReturnTypeName(0) = "Variant"
    ReturnTypeName(1) = "Integer"
    ReturnTypeName(2) = "Long"
    ReturnTypeName(3) = "Single"
    ReturnTypeName(4) = "Double"
    ReturnTypeName(5) = "Currency"
    ReturnTypeName(6) = "String"
    ReturnTypeName(7) = "Object"
End Sub

'
'   This is the main input line for the state machine
'   InputString$ is the string read from the file.
'   Returns 0 on success.
'   Returns 1 On object ready.
'   Returns 2 on syntax error.
'
Function am1ParseLine%(ByVal InputString$)
    Dim s$
    Dim res%    ' Set by state machines to return value (above)
    Dim TokenRes%

    InputString$ = Trim(InputString$)   ' Trim whitespace

    Do  ' We'll loop through every token in the string
        s$ = GetToken1(InputString$, TokenRes%)
    ' Debug.Print s$, MajorState% & "." & MinorState%
        ' How the string is handled depends on the state
        Select Case MajorState%
            Case 0  ' Clear state
                    res% = ProcessClearState(s$, TokenRes%)
            Case 1  ' Processing Comment
                    res% = ProcessCommentState(s$, TokenRes%)
            Case 2  ' Processing Declaration
                    res% = ProcessDeclareState(s$, TokenRes%)
            Case 3  ' Processing User Type
                    res% = ProcessTypeState(s$, TokenRes%)
            Case 4  ' Processing Global
                    res% = ProcessGlobalState(s$, TokenRes%)
        End Select
    Loop While Len(s$) > 0

    am1ParseLine% = res%

End Function

'
' Returns the position of the next separator.
' Valid separator is any separator unless ParseState% is 1, in which
' case only a quote is valid.
' TokenId% is the location of the token in the separator string
'
Function FindSeparator%(InputString$, TokenId%)
    Dim InputLength%
    Dim c%

    If ParseState% = 1 Then ' Find next quote only
        c% = InStr(InputString$, Chr$(34))
        If c% > 0 Then
            TokenId% = InStr(Separators$, Chr$(34))
        End If
        FindSeparator = c%
        Exit Function
    End If

    InputLength% = Len(InputString$)
    For c% = 1 To InputLength%
        TokenId% = InStr(Separators$, Mid$(InputString$, c%, 1))
        Select Case TokenId%
            Case 0  ' Ignore - it's not a separator

            Case idLineCont
                ' A line continuation character is valid only
                ' if it is the first character in the string
                If c% = 1 Then
                    FindSeparator = c%
                    Exit Function
                End If
            Case Else
                ' This character is a separator
                FindSeparator = c%
                Exit Function
        End Select

    Next c%

    FindSeparator = 0
    TokenId% = 0

End Function

'
' Retrieves the left token from the input string, modifies
' the input string to remove the token. Ignores white space
' result% = 0 - on success, 1 - Missing close quote
'
Function GetToken1$(instring$, result%)
    Dim maxlen%
    Dim Separatorloc%, Quote2%
    Dim TokenId%
    Dim Quote2Loc%
    result% = 0
    maxlen% = Len(instring$)
    If maxlen% = 0 Then ' Empty string
        GetToken1$ = instring$
        result% = 0
    End If

    Separatorloc% = FindSeparator(instring$, TokenId%)
    Select Case Separatorloc%
        Case 0  ' Just retrieve through the rest of the line
                GetToken1 = instring$
                instring$ = ""

        Case 1  ' First char is a separator
                ' Special cases are comment and quote
                Select Case TokenId%
                    Case idQuote%   ' Return quoted string as a single token
                        ParseState% = 1
                        Quote2% = FindSeparator(Mid$(instring$, 2), TokenId%) + 1
                        ParseState% = 0
                        If Quote2% <= 1 Then
                            result% = 1
                            Exit Function
                        Else
                            GetToken1$ = Left$(instring$, Quote2%)
                            If maxlen% > Quote2% Then instring$ = Mid$(instring$, Quote2% + 1) Else instring$ = ""
                            Exit Function
                        End If
                    Case idComment% ' Return comment as a single token
                        GetToken1$ = instring$
                        ' If there's a line continuation at the end, parse it separately
                        TrimWhiteSpace instring$, 2 ' Trim trailing spaces
                        If instring$ = "" Then Exit Function
                        If InStr(Separators$, Right$(instring$, 1)) = idLineCont Then
                            ' Check if it's a line continuation
                            maxlen% = Len(instring$)
                            TokenId% = InStr(Separators$, Mid$(instring$, maxlen% - 1, 1))
                            If TokenId% = idSpace Or TokenId% = IdTab Then
                                GetToken1$ = Left(instring$, maxlen% - 1)
                                instring$ = Right$(instring$, 1)
                                Exit Function
                            End If
                        End If
                        instring$ = ""
                    Case idSpace%, IdTab%   ' It's whitespace
                        TrimWhiteSpace instring$, 1
                        If Len(instring$) > 0 Then
                            ' Recursive call on rest of string
                            GetToken1 = GetToken1(instring$, TokenId%)
                        Else
                            GetToken1$ = ""
                            instring$ = ""
                        End If
                    Case Else
                        ' All other separators are tokens
                        GetToken1$ = Left$(instring$, 1)
                        If maxlen% > 1 Then
                            instring$ = Mid$(instring$, 2)
                        Else
                            instring$ = ""
                        End If

                End Select


        Case Else   ' First char is not a separator
                ' Return the string up to the separator
                GetToken1$ = Left$(instring$, Separatorloc% - 1)
                instring$ = Mid$(instring$, Separatorloc%)
    End Select




End Function

'
'   Checks the string against the return type name array
'   to find out which return type it is.
'   Returns -1 on error
'
Function GetTypeValue%(s As String)
    Dim x%
    Dim us$
    us$ = UCase$(s)
    For x = 0 To UBound(ReturnTypeName)
        If us$ = UCase$(ReturnTypeName(x)) Then
            GetTypeValue% = x
            Exit Function
        End If
    Next x


End Function

'
'   MajorState% is zero - processes the clear
'   MinorState% =   0 - Normal entry
'                   1 - Line term pending
Function ProcessClearState%(s As String, TokenRes%)
    Select Case UCase$(s)
        Case "DECLARE"
                MajorState% = 2
                MinorState% = 0
        Case "PUBLIC"
                MajorState% = 4
                MinorState% = 0
        Case "TYPE"
                MajorState% = 3
                MinorState% = 0
        Case "GLOBAL"
                MajorState% = 4
                MinorState% = 0
        Case "_"
                MinorState% = 1
        Case Else
            If s = "REM" Or Left$(s, 1) = "'" Then ' It's a comment
                MajorState% = 1
                MinorState% = 0
                If Len(s) > 1 Then
                    If Mid$(s, 2, 1) = "'" Then
                        ' Double '' sets current category
                        If Len(s) > 2 Then
                            Category$ = Mid$(s, 3)
                            TrimWhiteSpace Category$, 3
                        End If
                    End If
                End If
            Else
                MinorState% = 0
                ' Anything else is simply ignored
            End If
    End Select
    ' Clear state never terminates an object
    ProcessClearState% = 0
End Function

'
' Comment state
' MinorState% = 0 - In comment, throw out everything
'               1 - Line continuation received, watch for newline
' Exit on receipt of new line.
' If anything else arrives, throw it out
'
Function ProcessCommentState%(s As String, TokenRes%)
    Select Case s
        Case "_"
            MinorState% = 1
        Case ""
            ' If newline arrived, if last item was line continuation
            ' stay in comment state for next line
            ' Otherwise, switch back to clear state
            Select Case MinorState%
                Case 0
                    MajorState% = 0
                Case Else
                    MinorState% = 0
            End Select
        Case Else
            MinorState% = 0
    End Select

    ' Just ignore anything else
    ProcessCommentState = 0
End Function

'
' Declare state
' MinorState% = 0 - Entry point
'               1 - Processing comment
'
' Exit on receipt of new line.
' If anything else arrives, throw it out
'
'   MinorState  0 - Declare received
'               1 - Comment
'               2 - Syntax error found - throw away rest
'               3 - Sub,Function received, waiting on name
'               4 - Name received, waiting on lib
'               5 - Lib received, waiting on lib name
'               6 - Libname recorded, waiting on ( or Alias
'               7 - Alias received waiting on Aliasname
'               8 - Aliasname received, waiting on (
'               9 - Start of parameter
'               10 -    ) received, can get EOL, comment or As
'               11 - Type word received
'               12 - Like 9, except ByVal received
'               13 - Just processed param name
'               14 - Appending array info to var name
'               15 - AS received, waiting for type
'               16 - Full parameter received, look for , or )
'
'
Function ProcessDeclareState%(s As String, TokenRes%)

    Static lineterm%    ' Separate state machine for line timer character
    Static CompletionState% ' Set to 1 on legal statement
    Static CurParamNum%

    If CompletionState% = 0 Then CompletionState% = 2   ' Default to error state

    ' The following conditions apply regardless of minor state
    Select Case s
        Case "_"
            lineterm% = True
            ProcessDeclareState% = 0
            Exit Function
        Case ""
            If Not lineterm% Then
                MajorState% = 0
                MinorState% = 0
                ProcessDeclareState% = CompletionState%
                Exit Function
            End If
            lineterm% = False
        Case Else
            lineterm% = False
            If Left$(s, 1) = "'" Or UCase$(s) = "REM" Then
                ' Enter internal comment state
                ProcessDeclareState% = 0
                MinorState% = 1
                Exit Function
            End If
    End Select


    Select Case MinorState%
        Case 0
                objName$ = ""
                objLib$ = ""
                objAlias$ = ""
                objReturn% = 0
                Select Case UCase$(s)
                    Case "SUB"
                        objType = 1
                        ReDim pDesc(0)
                        MinorState% = 3
                    Case "FUNCTION"
                        objType = 2
                        ReDim pDesc(0)
                        MinorState% = 3
                    Case Else
                        objType = 0
                        MinorState% = 2
                End Select
                CompletionState% = 2    ' Set error status
        Case 1, 2 ' Internal comment mode or syntax error
                ' Just ignore everything - top level will
                ' handle it
        Case 3
                If Len(s) = 1 And InStr(Separators, s) Then
                    ' Not a legal name
                    MinorState% = 2
                Else
                    objName$ = s
                    objReturn% = 0 ' Default variant
                    MinorState% = 4
                End If
        Case 4  ' We might also get type char at this point
                If Len(s) = 1 And objReturn% = 0 And InStr(ReturnType$, s) > 0 Then
                    ' It's a type character
                    objReturn% = InStr(ReturnType$, s)
                    ' Stay in current minor state for lib
                    ' Multiple type chars are not detected as error
                Else
                    If UCase$(s) = "LIB" Then MinorState% = 5 Else MinorState% = 2
                End If
        Case 5
                If Left$(s, 1) <> Chr$(34) Or Len(s) < 3 Or TokenRes% = 1 Then
                    MinorState% = 2
                Else
                    MinorState% = 6
                    objLib$ = Mid$(s, 2, Len(s) - 2)
                End If
        Case 6
                Select Case UCase$(s)
                    Case "("
                        MinorState% = 9
                    Case "ALIAS"
                        MinorState% = 7
                    Case Else
                        MinorState% = 2
                End Select
        Case 7
                If Left$(s, 1) <> Chr$(34) Or Len(s) < 3 Or TokenRes% = 1 Then
                    MinorState% = 2
                Else
                    MinorState% = 8
                    objAlias$ = Mid$(s, 2, Len(s) - 2)
                End If
        Case 8
                If s = "(" Then MinorState% = 9 Else MinorState% = 2
        Case 9, 12 ' ( received (or , on prev param), processing param
            Select Case UCase$(s)
                Case ")"    ' Possible legal state
                    CompletionState = 1
                    MinorState = 10
                Case "BYVAL"
                    If MinorState% = 12 Then
                        MinorState% = 2
                    Else
                        MinorState% = 12
                    End If
                Case Else
                    If Len(s) = 1 And InStr(Separators, s) Then
                        MinorState% = 2
                    Else
                        ' Record the name
                        CurParamNum = UBound(pDesc) + 1
                        ReDim Preserve pDesc(CurParamNum)
                        pDesc(CurParamNum).ParamName = s
                        If MinorState% = 12 Then pDesc(CurParamNum).IsByVal = True
                        MinorState% = 13
                    End If

            End Select
        Case 10 ' Only "AS" acceptable
            If UCase$(s) = "AS" And objReturn% = 0 Then MinorState% = 11 Else MinorState% = 2
            CompletionState% = 2    ' Must finish
        Case 11
            objReturn% = GetTypeValue(s)
            If objReturn% >= 0 Then CompletionState% = 1
        Case 13
            Select Case UCase$(s)
                Case "("
                    MinorState% = 14
                    pDesc(CurParamNum).IsArray = True
                Case "AS"
                    MinorState% = 15
                Case ","
                    MinorState% = 9 ' Get ready for next
                Case Else
                    ' It might be a type character
                    If Len(s) = 1 And InStr(ReturnType$, s) > 0 Then
                        pDesc(CurParamNum).paramType = ReturnTypeName(InStr(ReturnType$, s))
                        ' pDesc(CurParamNum).ParamType = InStr(ReturnType$, s)
                        MinorState% = 16
                    Else
                        MinorState% = 2
                    End If

            End Select
        Case 14
            If s = ")" Then
                MinorState% = 13
            End If
        Case 15
            pDesc(CurParamNum).paramType = s
            MinorState% = 16
            'objReturn% = GetTypeValue(s)
            'If objReturn% >= 0 Then
            '    pDesc(CurParamNum).ParamType = objReturn%
            '    MinorState% = 16
            'Else
            '    MinorState% = 2
            'End If
        Case 16
            Select Case s
                Case ","
                    MinorState% = 9
                Case ")"
                    CompletionState% = 1
                    MinorState% = 10
                Case Else
                    MinorState% = 2
            End Select

    End Select





End Function

'
' Declare state
' MinorState% = 0 - Entry point
'               1 - Processing comment
'
' Exit on receipt of new line.
' If anything else arrives, throw it out
'
'   MinorState  0 - Global or Public received
'               1 - Comment
'               2 - Syntax error found - throw away rest
'               3 - Const received, waiting on name
'               4 - Name received, waiting on =
'               5 - = received, waiting on Value
'
'
Function ProcessGlobalState%(ByVal s$, TokenRes As Integer)

    Static lineterm%    ' Separate state machine for line timer character
    Static CompletionState% ' Set to 1 on legal statement

    If CompletionState% = 0 Then CompletionState% = 2   ' Default to error state

    ' The following conditions apply regardless of minor state
    Select Case s
        Case "_"
            lineterm% = True
            ProcessGlobalState% = 0
            Exit Function
        Case ""
            If Not lineterm% Then
                MajorState% = 0
                MinorState% = 0
                ProcessGlobalState% = CompletionState%
                Exit Function
            End If
            lineterm% = False
        Case Else
            lineterm% = False
            If Left$(s, 1) = "'" Or UCase$(s) = "REM" Then
                ' Enter internal comment state
                ProcessGlobalState% = 0
                MinorState% = 1
                Exit Function
            End If
    End Select


    Select Case MinorState%
        Case 0
                objName$ = ""
                objLib$ = ""
                Select Case UCase$(s)
                    Case "CONST"
                        objType = 4
                        MinorState% = 3
                    Case Else
                        objType = 0
                        MinorState% = 2
                End Select
                CompletionState% = 2    ' Set error status
        Case 1, 2 ' Internal comment mode or syntax error
                ' Just ignore everything - top level will
                ' handle it
        Case 3
                If Len(s) = 1 And InStr(Separators, s) Then
                    ' Not a legal name
                    MinorState% = 2
                Else
                    objName$ = s
                    MinorState% = 4
                End If
        Case 4  ' We might also get type char at this point
                If s = "=" Then
                    MinorState% = 5
                    objLib$ = ""
                    Exit Function
                End If

                If Len(s) = 1 And InStr(ReturnType$, s) > 0 Then
                    ' It's a type character
                        objReturn% = InStr(ReturnType$, s)
                Else
                    MinorState% = 2
                End If
        Case 5
                objLib$ = objLib$ & s   ' Keep adding to value
                CompletionState% = 1
    End Select
End Function

'
' Type state
' MinorState% = 0 - Entry point
'               1 - Processing comment
'
' Exit on receipt of new line.
' If anything else arrives, throw it out
'
'   MinorState  0 - Type received waiting on name or comment
'               1 - Comment
'               2 - Syntax error found - throw away rest
'               3 - Ready for first Field name
'               4 - Comment during Field
'               5 - Field name recorded
'               6 - End received, waiting on type
'               7 - Comment after completion
'
'
'
'
Function ProcessTypeState%(ByVal s$, TokenRes%)

    Static CompletionState% ' Set to 1 on legal statement
    Static lineterm%    ' Separate state machine for line timer character
    Static CurrentParamNum%

    If CompletionState% = 0 Then CompletionState% = 2   ' Default to error state

    Select Case s
        Case "_"
            lineterm% = True
            ProcessTypeState% = 0
            Exit Function
        Case ""
            If lineterm% Then
                ' No change to state for Types
                lineterm% = False
                Exit Function
            End If
            lineterm% = False
        Case Else
            lineterm% = False
    End Select


    Select Case MinorState%
        Case 0
                If (Len(s) = 1 And InStr(Separators$, s) > 0) Or s = "" Then
                    MinorState% = 2
                    Exit Function
                End If
                objType = 3
                objName$ = s
                ReDim pDesc(0)  ' Clear array
                MinorState% = 3

        Case 1  ' It's a comment
                ' True EOL means time for next variable
                If s = "" Then MinorState% = 3

        Case 2
                If s = "" Then
                    MajorState = 0
                    ProcessTypeState% = CompletionState%
                End If

        Case 3
                If s = "" Then Exit Function 'Ignore extra lines
                If UCase$(s) = "END" Then
                    MinorState% = 6
                    Exit Function
                End If

                If Left$(s, 1) = "'" Or UCase$(s) = "REM" Then
                    MinorState% = 4
                    Exit Function
                End If
                If (Len(s) = 1 And InStr(Separators$, s) > 0) Then
                    MinorState% = 2
                    Exit Function
                End If
                CurrentParamNum = UBound(pDesc) + 1
                ReDim Preserve pDesc(CurrentParamNum)
                pDesc(CurrentParamNum).ParamName$ = s
                MinorState% = 5

        Case 4
                If s = "" Then MinorState% = 3

        Case 5
                If Left$(s, 1) = "'" Or UCase$(s) = "REM" Then
                    MinorState% = 4
                    Exit Function
                End If
                If s = "" Then  ' Line end
                    MinorState% = 3
                    Exit Function
                End If
                pDesc(CurrentParamNum).ParamName$ = pDesc(CurrentParamNum).ParamName$ & " " & s

        Case 6
                Select Case UCase$(s)
                    Case "TYPE"
                        MinorState% = 7
                        CompletionState% = 1
                    Case Else
                        MinorState% = 2
                End Select

        Case 7
            If s = "" Then
                MajorState% = 0
                MinorState% = 0
                ProcessTypeState% = CompletionState%
            End If

    End Select

End Function

'
' Trims whitespace from string per mode
'   mode 1 = left, 2 = right, 3 = both
'
Sub TrimWhiteSpace(s$, ByVal mode%)
    Dim ch%
    If s$ = "" Then Exit Sub
    If mode% And 1 Then
        Do
            ch% = Asc(s$)
            If ch% = 32 Then s$ = LTrim$(s$)
            If ch% = 9 Then
                If Len(s$) > 1 Then s$ = Mid$(s$, 2) Else s$ = ""
            End If
        Loop While s$ <> "" And (ch% = 32 Or ch% = 9)
    End If
    If mode% And 2 Then
        Do
            ch% = Asc(Right$(s$, 1))
            If ch% = 32 Then s$ = RTrim$(s$)
            If ch% = 9 Then
                If Len(s$) > 1 Then s$ = Mid$(s$, 1, Len(s$) - 1) Else s$ = ""
            End If
        Loop While s$ <> "" And (ch% = 32 Or ch% = 9)
    End If


End Sub