All of the program code and information presented in the OpenNTF.org Code Bin are provided "as-is", and should be used at your own risk. OpenNTF.org make no express or implied warranty about anything in the Code Bin, and OpenNTF.org will not be responsible or liable for any damage caused by the use or misuse of anything from this site. OpenNTF.org makes no guarantees about anything. Please thoroughly test all of the knowledge and code you find here before you attempt to use them in your production environment.

%REM
Class name: LSLogger
Description: A utility class for logging information to a text file as simple text or XML.
Author: Dallas Gimpel
Date: 07/15/2004

+++ Properties:
CLASS_NAME - String constant, name of class
EOL_PLATFORM - Byte constant, default "end of line" character(s)
GetFilePath - String, returns file path with which this instance was constructed

+++ Public Methods:
New - class constructor
args: pstrFilePath As String

Delete - class destructor
args: none

ClearLog - clears previous entries in a log file
args: none

LogText - writes the string passed as simple text
args: pblnIsNewLine As Boolean, pstrValue As String

AddXMLTag - writes an open XML tag without a value or closing tag
args: pblnIsNewLine As Boolean, pstrTagName As String

LogXMLTagValue - write an open XML tag and value with or without a closing tag
args: pblnCloseTag As Boolean, pblnIsNewLine As Boolean, pstrTagName As String, pstrTagValue As String

LogXMLAttribute - writes an XML attribute
args: pstrAttName As String, pstrAttValue As String

CloseTag - closes an open XML tag (if it is first determined to be open)
args: pstrTagName As String


+++ Private Methods:
replaceSpaces - replaces the spaces in a string with an underscore ("_") character
args: pstrValu As String

formatEntityRef - replaces reserved characters with their XML entity references
args: pstrValu As String

openTag - writes a new open XML tag
args: pblnIsNewLine As Boolean, pstrTagName As String

getErrorMessage - String, constucts error message in a standard format for internal errors
args: none

getStackTrace - String, a stack trace generated for internal errors
args: none
%END REM

Public Class LSLogger
Private nsess As NotesSession
Private streamOut As NotesStream
Private intOpenTagCount As Integer
Private intOpenTagLst List As Integer
Private strFilePath As String

'+++ CLASS PROPERTIES +++
Public Property Get CLASS_NAME As String
CLASS_NAME = "LSLogger"
End Property

Public Property Get GetFilePath As String
GetFilePath$ = Me.strFilePath$
End Property

Public Property Get EOL_PLATFORM As Byte
EOL_PLATFORM = 3
End Property

'+++ CLASS CONSTRUCTOR +++
Sub New(pstrFilePath As String) '// errors are thrown here
Const CHARACTER_SET = "UTF-8" '// this should match the character set in the XML declaration (see the "openTag" method)
Set Me.nsess = New NotesSession()
Set Me.streamOut = nsess.CreateStream()
Me.intOpenTagCount% = -1
Me.strFilePath$ = pstrFilePath$

If Len(Trim(pstrFilePath$)) = 0 Then
Error 7001, "A valid file path for output must be provided"
End If

If Not(Me.streamOut.Open(pstrFilePath$, CHARACTER_SET)) Then
Error 7002, "Could not open the specified file (" & pstrFilePath$ & ") for output"
End If
End Sub

'+++ CLASS DESTRUCTOR +++
Sub Delete()
On Error Goto errorHandler

Dim i As Integer
Dim intCount As Integer
Dim strTagArray() As String

If Not(Me.streamOut Is Nothing) Then
If Me.intOpenTagCount% > 0 Then '// try to add closing tags as necessary
Redim strTagArray(0 To Me.intOpenTagCount%)
intCount% = -1
Forall tagNum In Me.intOpenTagLst
intCount% = intCount% + 1
strTagArray(intCount%) = Listtag(tagNum)
End Forall

For i = intCount% To 1 Step -1 '// stop at 1 (so we don't close XML declaration)
Call Me.CloseTag(strTagArray(i))
Next i
End If
Call Me.streamOut.Close()
End If

Set Me.nsess = Nothing
Set Me.streamOut = Nothing
Me.strFilePath = ""
Erase Me.intOpenTagLst
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

'+++ PUBLIC METHODS +++
Public Sub ClearLog()
Call Me.streamOut.Truncate()
End Sub

Public Sub LogText(pblnIsNewLine As Boolean, pstrValue As String)
On Error Goto errorHandler

If pblnIsNewLine Then
Call streamOut.WriteText(pstrValue$, Me.EOL_PLATFORM)
Else
Call streamOut.WriteText(pstrValue$)
End If
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

Public Sub AddXMLTag(pblnIsNewLine As Boolean, pstrTagName As String)
'// Note that the tag name should be passed without brackets.
Call Me.replaceSpaces(pstrTagName$)
Call Me.openTag(pblnIsNewLine, pstrTagName$)
End Sub

Public Sub LogXMLTagValue(pblnCloseTag As Boolean, pblnIsNewLine As Boolean, pstrTagName As String, pstrTagValue As String)
'// Note that the tag name should be passed without brackets.
On Error Goto errorHandler

Dim strBuff As String

Call Me.formatEntityRef(pstrTagValue$)
Call Me.replaceSpaces(pstrTagName$)
Call Me.openTag(pblnIsNewLine, pstrTagName$)
strBuff$ = String$(Me.intOpenTagCount% + 1, Chr(9))

If pblnIsNewLine Then
Call Me.streamOut.WriteText(strBuff$ & pstrTagValue$, Me.EOL_PLATFORM)
Else
Call Me.streamOut.WriteText(strBuff$ & pstrTagName$)
End If

If pblnCloseTag Then
Call Me.CloseTag(pstrTagName$)
End If
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

Public Sub LogXMLAttribute(pstrAttName As String, pstrAttValue As String)
'// Note that the attribute name should be passed without brackets.
On Error Goto errorHandler

Dim strBuff As String

If Me.intOpenTagCount% < 1 Then
Error 7003, "Invalid attempt to add an attribute - no open tags exist"
End If
strBuff$ = String$(Me.intOpenTagCount% + 1, Chr(9))
Call Me.formatEntityRef(pstrAttValue$)
Call Me.replaceSpaces(pstrAttName$)
Call streamOut.WriteText(strBuff$ & pstrAttName$ & {="} & pstrAttValue$ & {"}, Me.EOL_PLATFORM)
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

Public Sub CloseTag(pstrTagName As String)
'// Note that the tag name should be passed without brackets.
On Error Goto errorHandler

Dim strBuff As String
strBuff$ = String$(Me.intOpenTagCount%, Chr(9))

Call Me.replaceSpaces(pstrTagName$)
If Iselement(Me.intOpenTagLst(pstrTagName$)) Then
Me.intOpenTagCount% = Me.intOpenTagCount% - 1
Erase Me.intOpenTagLst(pstrTagName$)
Call streamOut.WriteText(strBuff$ & "</" & pstrTagName$ & ">", Me.EOL_PLATFORM)
End If
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

'+++ PRIVATE METHODS +++
Private Sub replaceSpaces(pstrValu As String)
pstrValu$ = Fulltrim(pstrValu$)
pstrValu$ = Replace(pstrValu$, " ", "_")
End Sub

Private Sub formatEntityRef(pstrValu As String)
Const XML_AMPERSAND = {&amp;}
Const XML_LT = {&lt;}
Const XML_GT = {&gt;}
Const XML_QUOTES = {&quot;}
Const XML_APOS = {&apos;}

If Len(pstrValu$) > 0 Then
pstrValu$ = Replace(pstrValu$, {&}, XML_AMPERSAND)
pstrValu$ = Replace(pstrValu$, {<}, XML_LT)
pstrValu$ = Replace(pstrValu$, {>}, XML_GT)
pstrValu$ = Replace(pstrValu$, {"}, XML_QUOTES)
pstrValu$ = Replace(pstrValu$, {'}, XML_APOS)
End If
End Sub

Private Sub openTag(pblnIsNewLine As Boolean, pstrTagName As String)
On Error Goto errorHandler
Const XML_DECLARATION = {<?xml version="1.0" encoding="utf-8" standalone="yes"?>}
Dim strBuff As String

If Not(Iselement(Me.intOpenTagLst(XML_DECLARATION))) Then
Me.intOpenTagCount% = Me.intOpenTagCount% + 1
Me.intOpenTagLst(XML_DECLARATION) = Me.intOpenTagCount%
Call streamOut.WriteText(XML_DECLARATION, Me.EOL_PLATFORM)
End If

If Not(Iselement(Me.intOpenTagLst(pstrTagName$))) Then
Me.intOpenTagCount% = Me.intOpenTagCount% + 1
Me.intOpenTagLst(pstrTagName$) = Me.intOpenTagCount%

strBuff$ = String$(Me.intOpenTagCount%, Chr(9))
If pblnIsNewLine Then
Call Me.streamOut.WriteText(strBuff$ & "<" & pstrTagName$ & ">", Me.EOL_PLATFORM)
Else
Call Me.streamOut.WriteText(strBuff$ & "<" & pstrTagName$ & ">")
End If
End If
subExit:
Exit Sub

errorHandler:
Msgbox Me.getErrorMessage() & Me.getStackTrace(), , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Resume subExit
End Sub

Private Function getErrorMessage() As String
getErrorMessage$ = "An error was encountered . . ." & Chr(13) _
& "Error number: " & Err & Chr(13) _
& "Error description: " & Error$ & Chr(13) & Chr(13)
End Function

Private Function getStackTrace() As String
Const NL = {
}
Const DELIMITER = ","
Const PROCEDURE_NAME = 2
Const LINE_NUMBER = 3
Dim i As Integer
Dim intLower As Integer
Dim intLine As Integer
Dim strStackTrace As String
Dim strName As String
Dim strTmpVal As String
Dim varStack As Variant

varStack = Lsi_info(14) '// IMPORTANT: To my knowledge, this is undocumented AND unsupported - DGG
varStack = Split(varStack, NL)

intLower% = Lbound(varStack) + 1
For i = intLower% To Ubound(varStack)
strTmpVal$ = varStack(i)
If Len(Trim$(strTmpVal$)) > 0 Then
strName$ = Strtoken(strTmpVal$, DELIMITER, PROCEDURE_NAME, 5)
If i = intLower% Then
intLine% = Erl
Else
intLine% = Strtoken(strTmpVal$, DELIMITER, LINE_NUMBER, 5)
End If

strStackTrace$ = strStackTrace$ & strName$ & " | " & intLine% & Chr(13)
End If
Next i

getStackTrace$ = "Stack trace: " & NL & strStackTrace$
End Function
End Class

This working example utility uses the LSLogger class to debug the state of an in-memory ADO Command object and form it into text or XML.

Sub debugADOParameterObjects(pblnRecordAsXML As Boolean, pvarADOCmd As Variant)
On Error Goto errorHandler

Dim logger As LSLogger
Dim x As Long
Dim y As Long
Dim lngParmCount As Long
Dim lngPropertyCount As Long
Dim strFilePath As String
Dim varParmClxn As Variant
Dim varPropClxn As Variant
Dim varProp As Variant

Set varParmClxn = pvarADOCmd.Parameters
Call varParmClxn.Refresh() '// automatically builds the Parameters collection based on the parameters in the SQL statement
lngParmCount& = varParmClxn.Count '// this is base 1
If pblnRecordAsXML Then
strFilePath$ = Environ$("Temp") & "\ADO_ParameterDetail.xml"
Else
strFilePath$ = Environ$("Temp") & "\ADO_ParameterDetail.txt"
End If

Set logger = New LSLogger(strFilePath$)

'// With the collections, methods, and properties of a Parameter object, you can:
'// - Set or return the name of a parameter with the Name property.
'// - Set or return the value of a parameter with the Value property. Value is the default property of the Parameter object.
'// - Set or return parameter characteristics with the Attributes, Direction, Precision, NumericScale, Size, and Type properties.
'// - Pass long binary or character data to a parameter with the AppendChunk method.
'// - Access provider-specific attributes with the Properties collection.

If pblnRecordAsXML Then '// record results as XML
Call logger.AddXMLTag(True, "ADO Parameter Object Collection")
For x = 0 To (lngParmCount& - 1)
Call logger.AddXMLTag(True, "ADO Parameter Object")
Call logger.LogXMLTagValue(True, True, "Name", varParmClxn(x).Name)
Call logger.LogXMLTagValue(True, True, "Attributes", Trim$(varParmClxn(x).Attributes))
Call logger.LogXMLTagValue(True, True, "Precision", Trim$(varParmClxn(x).Precision))
Call logger.LogXMLTagValue(True, True, "NumericScale", Trim$(varParmClxn(x).NumericScale))
Call logger.LogXMLTagValue(True, True, "Size", Trim$(varParmClxn(x).Size))
Call logger.LogXMLTagValue(True, True, "Type", Trim$(varParmClxn(x).Type))

Set varPropClxn = varParmClxn(x).Properties
lngPropertyCount& = varPropClxn.Count

Call logger.AddXMLTag(True, "Parameter properties")
Call logger.LogXMLTagValue(True, True, "Count", Cstr(lngPropertyCount&))
If lngPropertyCount& > 0 Then
For y = 0 To (lngPropertyCount& - 1) '// record any provider-specific properties
Set varProp = varPropClxn(y)
Call logger.AddXMLTag(True, "Parameter property")
Call logger.LogXMLTagValue(True, True, "Name", varProp.Name)
Call logger.LogXMLTagValue(True, True, "Type", varProp.Type)
Call logger.LogXMLTagValue(True, True, "Value", varProp.Value)
Call logger.LogXMLTagValue(True, True, "Attributes", varProp.Attributes)
Call logger.CloseTag("Parameter property")
Next y
End If
Call logger.CloseTag("Parameter properties")
Call logger.CloseTag("ADO Parameter Object")
Next x
Else '// record results as text
For x = 0 To (lngParmCount& - 1)
Call logger.LogText(True, "Parameter Name: " & varParmClxn(x).Name)
Call logger.LogText(True, "Attributes: " & varParmClxn(x).Attributes)
Call logger.LogText(True, "Direction: " & varParmClxn(x).Direction)
Call logger.LogText(True, "Precision: " & varParmClxn(x).Precision)
Call logger.LogText(True, "NumericScale: " & varParmClxn(x).NumericScale)
Call logger.LogText(True, "Size: " & varParmClxn(x).Size)
Call logger.LogText(True, "Type: " & varParmClxn(x).Type)

Set varPropClxn = varParmClxn(x).Properties
lngPropertyCount& = varPropClxn.Count
Call logger.LogText(True, "Parameter properties: " & lngPropertyCount&)
If lngPropertyCount& > 0 Then
For y = 0 To (lngPropertyCount& - 1) '// record any provider-specific properties
Set varProp = varPropClxn(y)
Call logger.LogText(True, " Property name: " & varProp.Name)
Call logger.LogText(True, " Property type: " & varProp.Type)
Call logger.LogText(True, " Property value: " & varProp.Value)
Call logger.LogText(True, " Property Attributes: " & varProp.Attributes)
Next y
End If
Call logger.LogText(True, "") '// add a new line
Next x
End If

subExit:
Set logger = Nothing
Exit