<%
'******************************************************************************
' ********************** DO NOT DELETE ****************************************
'
' COPYRIGHT NOTICE: Copyright 1999 Jon M. Gohr, NetTech Development Inc.
'
' This code is free for non-commercial use. Any commercial usage or 
' duplication requires a licensing agreement from the author who may be 
' contacted at the following email address: jongohr@yahoo.com
'
' The author assumes no responsibility for any damage caused by the 
' proper or inproper use of this code.
'
' ********************** DO NOT DELETE ****************************************
'******************************************************************************
%>
<%
Class cBuffer
    Private objFSO, objFile, objDict
    Private m_strPathToFile, m_TableBGColor, m_StartTime
    Private m_EndTime, m_LineCount, m_intKeyMin, m_intKeyMax
    Private m_CodeColor, m_CommentColor, m_StringColor, m_TabSpaces
    
    '**************************************************************************
    ' BEGIN EVENT HANDLERS
    '**************************************************************************
    Private Sub Class_Initialize()
        ' Set the intial table background color
        TableBGColor = "white"
        ' Set the intial color for the code keywords
        CodeColor = "Blue"
        ' Set the intial color for comments
        CommentColor = "Green"
        ' Set the intial color for quoted strings
        StringColor = "Gray"
        ' Set the number of spaces we will use to replace tab characters
        TabSpaces = "    "
        ' Set the File Path to an empty string
        PathToFile = ""
        
        ' Zero these out, hopefully their use is obvious?
        m_StartTime = 0
        m_EndTime = 0
        m_LineCount = 0
        
        ' 2 is the size of the smallest known keyword
        KeyMin = 2
        ' 8 is the size of the largest known keyword
        KeyMax = 8
        
        ' Create an instance of the dictionary object
        Set objDict = server.CreateObject("Scripting.Dictionary")
        ' Set the dictionary object compare mode to text
        objDict.CompareMode = 1
        
        CreateKeywords
        
        ' Create an instance of the FileSystemObject
        Set objFSO = server.CreateObject("Scripting.FileSystemObject")
    End Sub

    Private Sub Class_Terminate()
        ' Destroy the objects created in the intialize event
        Set objDict = Nothing
        Set objFSO = Nothing
    End Sub
    
    '**************************************************************************
    ' END EVENT HANDLERS
    '**************************************************************************

    '**************************************************************************
    ' BEGIN PROPERTIES
    '**************************************************************************
    
    ' PROPERTIES WITH SOME PUBLIC EXPOSURE ************************************
    Public Property Let CodeColor(inColor)
        m_CodeColor = "<font color=" & inColor & "><Strong>"
    End Property
    Private Property Get CodeColor()
        CodeColor = m_CodeColor
    End Property

    Public Property Let CommentColor(inColor)
        m_CommentColor = "<font color=" & inColor & ">"
    End Property
    Private Property Get CommentColor()
        CommentColor = m_CommentColor
    End Property

    Public Property Let StringColor(inColor)
        m_StringColor = "<font color=" & inColor & ">"
    End Property
    Private Property Get StringColor()
        StringColor = m_StringColor
    End Property

    Public Property Let TabSpaces(inSpaces)
        m_TabSpaces = inSpaces
    End Property
    Private Property Get TabSpaces()
        TabSpaces = m_TabSpaces
    End Property

    Public Property Let TableBGColor(inColor)
        m_TableBGColor = inColor
    End Property

    Private Property Get TableBGColor()
        TableBGColor = m_TableBGColor
    End Property

    Public Property Get ProcessingTime()
        ProcessingTime = Second(m_EndTime - m_StartTime)
    End Property

    Public Property Get LineCount()
        LineCount = m_LineCount
    End Property

    Public Property Get PathToFile()
        PathToFile = m_strPathToFile
    End Property
    Public Property Let PathToFile(inPath)
        m_strPathToFile = inPath
    End Property

    ' PRIVATE PROPERTIES ******************************************************
    Private Property Let KeyMin(inMin)
        m_intKeyMin = inMin
    End Property
    Private Property Get KeyMin()
        KeyMin = m_intKeyMin
    End Property
    Private Property Let KeyMax(inMax)
        m_intKeyMax = inMax
    End Property
    Private Property Get KeyMax()
        KeyMax = m_intKeyMax
    End Property
    
    '**************************************************************************
    ' END PROPERTIES
    '**************************************************************************
    
    '**************************************************************************
    ' BEGIN METHODS
    '**************************************************************************

    ' subroutine to add all of the known language keywords to the dictionary
    Private Sub CreateKeywords()
        objDict.Add "abs", "Abs"
        objDict.Add "and", "And"
        objDict.Add "array", "Array"
        objDict.Add "call", "Call"
        objDict.Add "cbool", "CBool"
        objDict.Add "cbyte", "CByte"
        objDict.Add "ccur", "CCur"
        objDict.Add "cdate", "CDate"
        objDict.Add "cdbl", "CDbl"
        objDict.Add "cint", "CInt"
        objDict.Add "class", "Class"
        objDict.Add "clng", "CLng"
        objDict.Add "const", "Const"
        objDict.Add "csng", "CSng"
        objDict.Add "cstr", "CStr"
        objDict.Add "date", "Date"
        objDict.Add "dim", "Dim"
        objDict.Add "do", "Do"
        objDict.Add "loop", "Loop"
        objDict.Add "empty", "Empty"
        objDict.Add "eqv", "Eqv"
        objDict.Add "erase", "Erase"
        objDict.Add "exit", "Exit"
        objDict.Add "false", "False"
        objDict.Add "fix", "Fix"
        objDict.Add "for", "For"
        objDict.Add "next", "Next"
        objDict.Add "each", "Each"
        objDict.Add "function", "Function"
        objDict.Add "global", "Global"
        objDict.Add "if", "If"
        objDict.Add "then", "Then"
        objDict.Add "else", "Else"
        objDict.Add "elseif", "ElseIf"
        objDict.Add "imp", "Imp"
        objDict.Add "int", "Int"
        objDict.Add "is", "Is"
        objDict.Add "lbound", "LBound"
        objDict.Add "len", "Len"
        objDict.Add "mod", "Mod"
        objDict.Add "new", "New"
        objDict.Add "not", "Not"
        objDict.Add "nothing", "Nothing"
        objDict.Add "null", "Null"
        objDict.Add "on", "On"
        objDict.Add "error", "Error"
        objDict.Add "resume", "Resume"
        objDict.Add "option", "Option"
        objDict.Add "explicit", "Explicit"
        objDict.Add "or", "Or"
        objDict.Add "private", "Private"
        objDict.Add "property", "Property"
        objDict.Add "get", "Get"
        objDict.Add "let", "Let"
        objDict.Add "set", "Set"
        objDict.Add "public", "Public"
        objDict.Add "redim", "Redim"
        objDict.Add "select", "Select"
        objDict.Add "case", "Case"
        objDict.Add "end", "End"
        objDict.Add "sgn", "Sgn"
        objDict.Add "string", "String"
        objDict.Add "sub", "Sub"
        objDict.Add "true", "True"
        objDict.Add "ubound", "UBound"
        objDict.Add "while", "While"
        objDict.Add "wend", "Wend"
        objDict.Add "with", "With"
        objDict.Add "xor", "Xor"
    End Sub

    ' Simple function to return the smaller of two numbers
    Private Function Min(x, y)
        Dim tempMin
        If x < y Then tempMin = x Else tempMin = y
        Min = tempMin
    End Function
    
    ' simple function to return the larger of two numbers
    Private Function Max(x, y)
        Dim tempMax
        If x > y Then tempMax = x Else tempMax = y
        Max = tempMax
    End Function
    
    ' Public method to add keywords to the dictionary object
    Public Sub AddKeyword(inKeyword, inToken)
        KeyMin = Min(Len(inKeyword), KeyMin)
        KeyMax = Max(Len(inKeyword), KeyMax)
        
        objDict.Add LCase(inKeyword), inToken
    End Sub
    
    ' This is the primary method of the class.
    Public Sub ParseFile(blnOutputHTML)
        Dim m_strReadLine, tempString, blnInScriptBlock, blnGoodExtension, i
        Dim blnEmptyLine
        
        ' zero out the line count
        m_LineCount = 0
        
        ' Check the length of the PathToFile property.
        If Len(PathToFile) = 0 Then
            Err.Raise 5, "cBuffer: PathToFile Length Zero"
            Exit Sub
        End If
        
        ' Check the file extension
        Select Case LCase(Right(PathToFile, 3))
            Case "asp", "inc"
                blnGoodExtension = True
            Case Else
                blnGoodExtension = False
        End Select
        
        If Not blnGoodExtension Then
            Err.Raise 5, "cBuffer: File extension not asp or inc"
            Exit Sub
        End If
        
        ' Open the file
        Set objFile = objFSO.OpenTextFile(server.MapPath(PathToFile))
        
        ' Start the outside table which will contain all the output
        Response.Write "<table nowrap bgcolor=" & TableBGColor & " cellpadding=0 cellspacing=0>"
        Response.Write "<tr><td><PRE>"
        
        ' Grab the time at the start of processing
        m_StartTime = Time()
        
        ' loop and read the file a line at a time
        Do While Not objFile.AtEndOfStream
            m_strReadLine = objFile.ReadLine
            
            ' Because of the line conversion we do below we need to catch
            ' blank lines up here right away.
            blnEmptyLine = False
            If Len(m_strReadLine) = 0 Then
                blnEmptyLine = True
            End If
            
            ' Replace all the tab characters with spaces
            m_strReadLine = Replace(m_strReadLine, vbTab, TabSpaces)
            ' Increment the line count
            m_LineCount = m_LineCount + 1
            ' Trim all the spaces from the left side of the line
            ' so we can start doing evaluation of the content of the line
            tempString = LTrim(m_strReadLine)
            
            ' Check for the top script line that set's the default script language
            ' for the page.
            If left( tempString, 3 ) = Chr(60) & "%@" And right(tempString, 2) = "%" & Chr(62) Then
                Response.Write "<table><tr bgcolor=yellow><td>"
                Response.Write server.HTMLEncode(m_strReadLine)
                Response.Write "</td></tr></table>"
                blnInScriptBlock = False
            ' Check for an opening script tag
            ElseIf Left( tempString, 2) = Chr(60) & "%" Then
                ' Check for a closing script tag on the same line
                If right( RTrim(tempString), 2 ) = "%" & Chr(62) Then
                    Response.Write "<table><tr><td bgcolor=yellow><%</td>"
                    Response.Write "<td>"
                    Response.Write CharacterParse(mid(m_strReadLine, 3, Len(m_strReadLine) - 4))
                    Response.Write "</td>"
                    Response.Write "<td bgcolor=yellow>%></td></tr></table>"
                    blnInScriptBlock = False
                Else
                    Response.Write "<table><tr bgcolor=yellow><td><%</td></tr></table>"
                    ' We've got an opening script tag so set the flag to true so
                    ' that we know to start parsing the lines for keywords/comments
                    blnInScriptBlock = True
                End If
            Else
                If blnInScriptBlock Then
                    If blnEmptyLine Then
                        Response.Write vbCrLf
                    Else
                        If right(tempString, 2) = "%" & Chr(62) Then
                            Response.Write "<table><tr bgcolor=yellow><td>%></td></tr></table>"
                            blnInScriptBlock = False
                        Else
                            Response.Write CharacterParse(m_strReadLine) & vbCrLf
                        End If
                    End If
                Else
                    If blnOutputHTML Then
                        If blnEmptyLine Then
                            Response.Write vbCrLf
                        Else
                            Response.Write server.HTMLEncode(m_strReadLine) & vbCrLf
                        End If
                    End If
                End If
            End If
        Loop
        
        ' Grab the time at the completion of processing
        m_EndTime = Time()
        
        ' Close the outside table
        Response.Write "</PRE></td></tr></table>"
        
        ' Close the file and destroy the file object
        objFile.close
        Set objFile = Nothing
    End Sub
    
    ' This function parses a line character by character
    Private Function CharacterParse(inLine)
        Dim charBuffer, tempChar, i, outputString
        Dim insideString, workString, holdChar
        
        insideString = False
        outputString = ""
        
        For i = 1 to Len(inLine)
            tempChar = mid(inLine, i, 1)
            Select Case tempChar
                Case " "
                    If Not insideString Then
                        charBuffer = charBuffer & " "
                        If charBuffer <>" "  Then
                            If left(charBuffer, 1) = " " Then outputString = outputString & " "
                            
                            ' Check for a 'rem' style comment marker
                            If LCase(Trim(charBuffer)) = "rem" Then
                                outputString = outputString & CommentColor
                                outputString = outputString & "REM"
                                workString = mid( inLine, i, Len(inLine))
                                workString = replace(workString, "<", "<")
                                workString = replace(workString, ">", ">")
                                outputString = outputString & workString & "</font>"
                                charBuffer = ""
                                Exit For
                            End If
                            
                            outputString = outputString & FindReplace(Trim(charBuffer))
                            If right(charBuffer, 1) = " " Then outputString = outputString & " "
                            charBuffer = ""
                        End If
                    Else
                        outputString = outputString & " "
                    End If
                Case "("
                    If left(charBuffer, 1) = " " Then
                        outputString = outputString & " "
                    End If
                    outputString = outputString & FindReplace(Trim(charBuffer)) & "("
                    charBuffer = ""
                Case Chr(60)
                    outputString = outputString & "<"
                Case Chr(62)
                    outputString = outputString & ">"
                Case Chr(34)
                    ' catch quote chars and flip a boolean variable to denote that
                    ' whether or not we're "inside" a quoted string
                    insideString = Not insideString
                    If insideString Then
                        outputString = outputString & StringColor
                        outputString = outputString & """
                    Else
                        outputString = outputString & """
                        outputString = outputString & "</font>"
                    End If
                Case "'"
                    ' Catch comments and output the rest of the line
                    ' as a comment IF we're not inside a string.
                    If Not insideString Then
                        outputString = outputString & CommentColor
                        workString = mid( inLine, i, Len(inLine))
                        workString = replace(workString, "<", "<")
                        workString = replace(workString, ">", ">")
                        outputString = outputString & workString
                        outputString = outputString & "</font>"
                        Exit For
                    Else
                        outputString = outputString & "'"
                    End If
                Case Else
                    ' We've dealt with special case characters so now
                    ' we'll begin adding characters to our outputString
                    ' or charBuffer depending on the state of the insideString
                    ' boolean variable
                    If insideString Then
                        outputString = outputString & tempChar
                    Else
                        charBuffer = charBuffer & tempChar
                    End If
            End Select
        Next
        
        ' Deal with the last part of the string in the character buffer
        If Left(charBuffer, 1) = " " Then
            outputString = outputString & " "
        End If
        ' Check for closing parentheses at the end of a string
        If right(charBuffer, 1) = ")" Then
            charBuffer = Left(charBuffer, Len(charBuffer) - 1)
            CharacterParse = outputString & FindReplace(Trim(charBuffer)) & ")"
            Exit Function
        End If
        
        CharacterParse = outputString & FindReplace(Trim(charBuffer))
    End Function
    
    ' return true or false if a passed in number is between KeyMin and KeyMax
    Private Function InRange(inLen)
        If inLen >= KeyMin And inLen <= KeyMax Then
            InRange = True
            Exit Function
        End If
        InRange = False
    End Function
    
    ' Evaluate the passed in string and see if it's a keyword in the
    ' dictionary. If it is we will add html formatting to the string
    ' and return it to the caller. Otherwise just return the same
    ' string as was passed in.
    Private Function FindReplace(inToken)
        ' Check the length to make sure it's within the range of KeyMin and KeyMax
        If InRange(Len(inToken)) Then
            If objDict.Exists(inToken) Then
                FindReplace = CodeColor & objDict.Item(inToken) & "</Strong></Font>"
                Exit Function
            End If
        End If
        ' Keyword is either too short or too long or doesn't exist in the
        ' dictionary so we'll just return what was passed in to the function 
        FindReplace = inToken
    End Function
    
    '**************************************************************************
    ' END METHODS
    '**************************************************************************
End Class
%>