|
xxx
Utility Belt: Library
Source Code To Cut and Paste
by Charles Carroll (with some help by Jeff, Steve and Dave)
Here is the Utility Belt Library Code to cut and paste.
filename=/experiments/utilitybelt/vercurrent/utilitybelt.vb
Option Strict Off
Imports Microsoft.VisualBasic
Imports Microsoft.VisualBasic.Constants
Imports Microsoft.VisualBasic.Information
Imports System.Collections
Imports System.Collections.Specialized
Imports System.Configuration.ConfigurationSettings
Imports System.Data
Imports System.Data.OLEDB
Imports System.Data.SQLClient
Imports System.Drawing
Imports System.IO
Imports System.Net
Imports System.Reflection
Imports System.Runtime.InteropServices
Imports System.Security.Cryptography
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Threading
Imports System
Imports System.Web
Imports System.Web.Mail
Imports System.Web.UI
Imports System.Web.UI.Webcontrols
Imports System.XML
Imports System.xml.XmlNodeType
<Assembly: AssemblyVersion("0.9.8.70")>
<Assembly: AssemblyTitle("FREE Utility Belt by LearnAsp.com")>
<Assembly: AssemblyDescription("Design by Charles Carroll and Team")>
<Assembly: AssemblyCompany("Carroll Software Training (CST)")>
<Assembly: AssemblyProduct("FREE Utility Belt by LearnAsp.com")>
<Assembly: AssemblyCopyright("copyright 2002,2003,2004,2005 by Charles Mark Carroll")>
<Assembly: AssemblyTrademark("")>
<Assembly: CLSCompliant(True)>
Namespace LearnASP
Public Class UtilityBelt
' To Compile into DLL we recommend the following command line
' vbc utilitybelt.vb /r:system.dll,system.web.dll,system.data.dll,system.xml.dll,system.drawing.dll /out:utilitybelt.dll /target:library
'
Private Trace As Web.TraceContext = Web.HttpContext.Current.Trace
Private Server As Web.HttpServerUtility = Web.HttpContext.Current.Server
Private Page As Web.UI.Page = DirectCast(Web.HttpContext.Current.Handler, Web.UI.Page)
Private Cache as System.Web.Caching.Cache =System.Web.HttpContext.Current.Cache
Private Shared _AmazonLastCallTime As DateTime
Private BolAdvice_ As Boolean = False
Private BolHints_ As Boolean = False
Public SCC_Format As String = "default"
Public SCC_LineCounter As Integer = 0
Public SCC_LineNumbers As Boolean = False
Public SCC_SrcSettings As NameValueCollection
Private _strAmazonLocale As String = ""
Private bolCache_ As Boolean
Private bolEmailIsWorking_ as boolean=false
Private bolErrEmail_ As Boolean
Private bolErrFriendly_ As Boolean
Private bolErrHide_ As Boolean
Private bolErrIgnoreNext_ As Boolean
Private bolErrNullNestedIgnore_ As Boolean
Private bolErrRaw_ As Boolean
Private bolErrThrowBack_ As Boolean
Private bolErrorDetails_ As Boolean
Private bolHTMLencode_ As Boolean
Private bolLogCacheHitMiss_ As Boolean
Private bolLogDbg_ As Boolean
Private bolLogSQLShow_ As Boolean
Private bolLogSQLreturn_ As Boolean
Private bolLogSensitive_ As Boolean
Private bolLogUBFlow_ As Boolean
Private bolLogWarning_ As Boolean
Private bolMessages_ = True
Private bolSimpleTrace_ As Boolean
Private bolSuperTraceToTraceStream_ As Boolean
Private bolSuperTrace_ As Boolean
Private bolXrayOn_ As Boolean
Private bolXrayToPage_ As Boolean
Private dsXray As DataSet
Private errorCountGlobal_ As Integer
Private errorCount_ As Integer
Private errorOccuredGlobal_ As Boolean
Private errorOccured_ As Boolean
Private intCacheMinutes_ As Integer
Private intCacheSeconds_ As Integer
Private intHintNumber As Integer
Private intReaderUnClosedCount As Integer
Private objNull_ As String
Private plcException_ As PlaceHolder
Private plcXray_ As PlaceHolder
Private strAmazonDevToken_ As String
Private strAmazonPromoCode_ As String
Private strErrMessage_ As String
Private strLogFileName_ As String
Private strMailErrorSubject_ As String
Private strMailErrorsTo_ As String
Private strMailSmtpServer_ As String
private strSimpleTrace_ as string=""
Private strSuperTraceHide_ As String
Private strSuperTraceShow_ As String
Private strVersion As String
Private intLockedFileSleepDuration As Integer = 20 ' 1/500
Private intLockedFileAttempts As Integer
Private intLockedFileAttemptsMax As Integer = 1
Public Property strAmazonLocale() As String
Get
Return _strAmazonLocale
End Get
Set(ByVal Value As String)
Select Case Value.ToLower
Case "", "uk"
_strAmazonLocale = Value.ToLower
Case Else
LogHint("strAmazonLocale", "Locale can only be empty [""""] or ""uk"" ")
End Select
End Set
End Property
Private _boolAmazon1RequestPerSecond As Boolean = True
Public Property boolAmazon1RequestPerSecond() As Boolean
Get
Return _boolAmazon1RequestPerSecond
End Get
Set(ByVal Value As Boolean)
_boolAmazon1RequestPerSecond = Value
End Set
End Property
Private Property bolCache() As Boolean
Get
bolCache = bolCache_
End Get
Set(ByVal v As Boolean)
bolCache_ = v
End Set
End Property
Public Property intCacheSeconds() As Integer
Get
intCacheSeconds = intCacheSeconds_
End Get
Set(ByVal v As Integer)
intCacheSeconds_ = v
End Set
End Property
Public Property intCacheMinutes() As Integer
Get
intCacheMinutes = intCacheMinutes_
End Get
Set(ByVal v As Integer)
intCacheMinutes_ = v
End Set
End Property
ReadOnly Property errorCount() As Integer
Get
errorCount = errorCount_
End Get
End Property
ReadOnly Property errorCountGlobal() As Integer
Get
errorCountGlobal = errorCountGlobal_
End Get
End Property
ReadOnly Property errorOccured() As Boolean
Get
errorOccured = errorOccured_
End Get
End Property
ReadOnly Property errorOccuredGlobal() As Boolean
Get
errorOccuredGlobal = errorOccuredGlobal_
End Get
End Property
Public Property plcXray() As PlaceHolder
Get
If plcXray_ Is Nothing Then
Dim Page1 As System.Web.UI.Page = System.Web.HttpContext.Current.Handler
Dim plcEndOfPage As New PlaceHolder
Page1.Controls.Add(plcEndOfPage)
plcXray_ = plcEndOfPage
plcXray = plcXray_
Else
plcXray = plcXray_
End If
End Get
Set(ByVal v As PlaceHolder)
plcXray_ = v
bolXrayToPage_ = True
End Set
End Property
Public Property plcException() As PlaceHolder
Get
If plcException Is Nothing Then
' If they did not specify a placeholder then add one to end of page
Dim Page1 As System.Web.UI.Page = System.Web.HttpContext.Current.Handler
Dim plcEndOfPage As New PlaceHolder
Page1.Controls.Add(plcEndOfPage)
plcException_ = plcEndOfPage
plcException = plcException_
Else
plcException = plcException_
End If
End Get
Set(ByVal v As PlaceHolder)
plcException_ = v
End Set
End Property
Private Property strAmazonDevToken() As String
Get
strAmazonDevToken = strAmazonDevToken_
End Get
Set(ByVal v As String)
strAmazonDevToken_ = v
If v = "D1967KF255R5KZ" Then
Dim strSiteHost As String = System.Web.HttpContext.Current.Request.Url.Host.ToLower()
If strSiteHost.IndexOf("learnasp") < 0 Then
LogHint("Not Your Amazon DevKey", "Amazon Devkey you used belongs to learnasp.com! Get your own @ <a href='http://www.amazon.com/gp/browse.html/ref=mm_ws_?node=3435361'>http://www.amazon.com/gp/browse.html/ref=mm_ws_?node=3435361</a>!")
End If
End If
End Set
End Property
Private Property strAmazonPromoCode() As String
Get
strAmazonPromoCode = strAmazonPromoCode_
End Get
Set(ByVal v As String)
strAmazonPromoCode_ = v
End Set
End Property
Private Property strErrMessage() As String
Get
strErrMessage = strErrMessage_
End Get
Set(ByVal v As String)
strErrMessage_ = v
End Set
End Property
Private Property strMailSmtpServer() As String
Get
strMailSmtpServer = strMailSmtpServer_
End Get
Set(ByVal v As String)
strMailSmtpServer_ = v
End Set
End Property
Public Property strSuperTraceHide() As String
Get
strSuperTraceHide = strSuperTraceHide_
End Get
Set(ByVal v As String)
strSuperTraceHide_ = v
End Set
End Property
Public Property strSuperTraceShow() As String
Get
strSuperTraceShow = strSuperTraceShow_
End Get
Set(ByVal v As String)
strSuperTraceShow_ = v
End Set
End Property
Public Property objNull() As Object
Get
objNull = objNull_
End Get
Set(ByVal v As Object)
objNull_ = v
End Set
End Property
Public Sub New()
CheckPage()
dsXray = XrayDataSetCreate()
ConfigDefaults()
ConfigRead()
strVersion = System.Reflection.Assembly.GetExecutingAssembly().GetName().Version.ToString()
Trace.Write("Utility Belt version #", strVersion)
Trace.Write("Utility Belt authors", [Assembly].GetExecutingAssembly.GetCustomAttributes(GetType(AssemblyDescriptionAttribute), False)(0).Description)
End Sub
Private Sub Page_PreRender(ByVal Sender As Object, ByVal E As EventArgs)
dim strTask as string="Page_PreRender"
'Try
DisplayLog()
RemoveHandler Page.PreRender, AddressOf Page_PreRender
' Catch exc1 As Exception
' LogException(strTask,exc1)
'End Try
End Sub
Private Sub CheckPage()
If Page Is Nothing AndAlso Not HttpContext.Current.Handler Is Nothing Then
Page = HttpContext.Current.Handler
AddHandler Page.PreRender, AddressOf Page_PreRender
End If
End Sub
Sub Dispose()
logWarning("Dispose", "Dispose is no longer needed")
End Sub
Private Sub AAATemplate()
' DIM everything that needs to be seen by CATCH or FINALLY block
Dim strTask As String = "SUB AAATemplate"
Try
LogTaskStart(strTask)
' LogTaskEndPremature(strTask,"reason for quitting early")
' LogFlow(strTask,"some branch people want to know about with UBFlowon")
' LogDebugData(strTask,"varname=" & varname)
' LogWarning(strTask,"some high level warning for the developer")
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1) ' Used for most exceptions
Finally
' Release(Conn1)
' Release(Conn1)
' Release(stream1)
' Release(Rdr1)
' Release(Rdr1)
End Try
End Sub
Private Function appkey(ByVal strParm As String) As String
' TODO in case of SQLserver use {Application Name}=HttpContext.Current.Request.FilePath
Dim strTempReturn As String=""
Dim strTask As String = "appkey"
LogTaskParms(strTask,"strParm",strParm)
Try
strTempReturn = AppSettings(strParm)
If strTempReturn = "" Then
LogHint(strTask, "<b>" & strParm & "</b> => No App Key or AppKey Value is blank")
End If
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
Return LogReturn(strTask,strTempReturn)
End Function
Sub Array1dRandomize(ByRef arryP1 As String(), ByVal intP2Shufflecount As Integer)
Dim strTask As String = "SUB Array1dRandomize"
LogTaskStart(strTask)
Dim tempobj As Object
tempobj = arryP1
Array1dRandomize(tempobj, intP2Shufflecount)
LogTaskEnd(strTask)
End Sub
Sub Array1dRandomize(ByRef arryP1 As Object, ByVal intP2Shufflecount As Integer)
' 1st parameter as array C# hated that
' as string() C# hated that
' Re-arrange a 1dArray. The 2nd parameter determines how many passes through the array are done
' can't be shared AND have Error Trapping
' Cannot refer to an instance member of a class from within a shared method or shared member initializer
' without an explicit instance of the class.
Dim strTask As String = "SUB Array1dRandomize"
Try
LogTaskStart(strTask)
If arryP1 Is Nothing Then
LogHint(strTask, "Array is Nothing, Can't be re-arranged")
LogTaskEnd(strTask)
Exit Sub
End If
If arryP1.GetupperBound(0) = 0 Then
LogHint(strTask, "Array has zero elements, Can't be re-arranged")
LogTaskEnd(strTask)
Exit Sub
End If
Dim Random1 As New Random
Dim intRandomNum As Integer
Dim intMaxArraySize As Integer = arryP1.GetupperBound(0)
Dim intMaxShuffleCount As Integer = intMaxArraySize * intP2Shufflecount
Dim strSwap1, strSwap2 As String
Dim intShuffleCounter As Integer
For intShuffleCounter = 0 To intMaxShuffleCount
intRandomNum = Random1.Next(intMaxArraySize)
strSwap1 = arryP1(intRandomNum)
strSwap2 = arryP1(intMaxArraySize - 1)
arryP1(intRandomNum) = strSwap2
arryP1(intMaxArraySize - 1) = strSwap1
Next
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub ArrayFromDatatable(ByRef pArray As Array, ByVal dt1 As DataTable)
Dim strTask As String = "ArrayFromDataTable - datatable + array = parameters"
Try
If TypeName(dt1) = "Nothing" Then
LogHint(strTask, "DataTable is Empty, Can't be made into array")
LogTaskEnd(strTask)
Exit Sub
End If
Dim intArraycounterMax As Integer = dt1.Rows.Count - 1
Dim intFieldcounterMax As Integer = dt1.Columns.Count - 1
Dim intFieldcounter As Integer
Dim thearray(intArraycounterMax, intFieldcounterMax) As String
Dim thearray1d(intArraycounterMax) As String
Dim intarraycounter As Integer = 0
Dim datarow1 As DataRow
If intFieldcounterMax = 0 Then
For Each datarow1 In dt1.Rows
Try
' LogDebugData(strtask,"intArrayCounter=" & intArrayCounter)
thearray1d(intarraycounter) = datarow1(intFieldcounter)
Catch ex1 As InvalidCastException
' Nothing to do Nulls are ok
Catch ex1 As Exception
logWarning(strTask, "nulldata r:" & intarraycounter)
Finally
End Try
intarraycounter += 1
Next
Else
For Each datarow1 In dt1.Rows
For intFieldcounter = 0 To intFieldcounterMax
Try
' LogDebugData(strtask,"intArrayCounter=" & intArrayCounter)
thearray(intarraycounter, intFieldcounter) = datarow1(intFieldcounter)
Catch ex1 As InvalidCastException
' Nothing to do Nulls are ok
Catch ex1 As Exception
logWarning(strTask, "nulldata r:" & intarraycounter & " c:" & intFieldcounter)
Finally
End Try
Next
intarraycounter += 1
Next
End If
If intFieldcounterMax = 0 Then
pArray = thearray1d
Else
pArray = thearray
End If
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub arrayFromDataTable(ByVal strConn As String, _
ByVal strSQL As String, ByRef parray As Object)
Dim strTask As String = "SUB ArrayFromDataTable"
LogTaskStart(strTask)
LogTaskParms(strTask,"strConn", strConn,"strSQL", strSQL,"parray", pArray)
Dim dt1 As New DataTable
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
dt1 = DataTableGetSQLClient(strConn, strSQL)
Case "oledb"
dt1 = DataTableGetOLEDB(strConn, strSQL)
End Select
ArrayFromDatatable(parray, dt1)
End Sub
Private Sub arrayFromDataTable(ByVal strConn As String, ByVal strSQL As String, _
ByRef htParm As Hashtable, ByRef parray As Object)
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "SUB ArrayFromDataTable"
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL, "htParm", htParm,"parray", pArray)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
SPSQLServer_arrayFromDataTable(parray, strConn, htParm, strSQL)
Case Else
LogException(strTask, DBAnalyzeConn(strConn) & " not yet implemented")
End Select
LogTaskEnd(strTask)
End Sub
Private sub ConfigDefaults()
DIM strIndent as string="&npsp; "
Trace.IsEnabled = False
bolCache_ = False
intCacheSeconds_ = 600
intCacheMinutes_ = 10
bolSuperTrace_ = False
bolSuperTraceToTraceStream_ = False
bolErrorDetails_ = False
bolErrIgnoreNext_ = False
bolErrNullNestedIgnore_ = False
bolErrThrowBack_ = False
errorCount_ = 0
bolLogSQLShow_ = False
bolLogSQLreturn_ = False
bolLogUBFlow_ = False
bolLogDbg_ = False
bolLogSensitive_ = False
bolLogCacheHitMiss_ = False
bolXrayOn_ = True
bolXrayToPage_ = False
strSuperTraceHide_ = ""
strSuperTraceShow_ = ""
strMailSmtpServer_ = "localhost"
objNull_ = "-null-"
strMailErrorsTo_ = ""
Dim sbTemp As New StringBuilder
With sbTemp
.Append("<table width='100%' bgcolor='#CCE6FF' gridlines='all' border='2' bordercolor='#FFCCFF' cellpadding='2'><tr><td>")
.Append("<font face='verdana' size='1'><h3><a href='http://www.learnasp.com/ub'>")
.Append("ASP.net Utility Belt FREE Library</a> ")
.Append(strVersion)
.Append("<br>coded by ")
.Append("<a href='http://www.learnasp.com/freebook/learn/utilitybelt_credits.aspx'>")
.Append("Charles Carroll and Team</a> ")
.Append("</h3>")
.Append(strIndent)
.Append("<font size='+1'><font color='red'><b>An error occured and was logged.</b>")
.Append("<br>")
.Append(strIndent)
.Append(strMailErrorsTo_)
.Append(" has been notified by email</font><br><br>")
.Append("<font size='-1'>Note To Programmer:<br>")
.Append(strIndent)
.Append("Custom errors, use <b><StrErrorMessage>Your Message</StrErrorMessage></b> in utilitybelt.config<br>")
.Append(strIndent)
.Append("<a href='http://www.learnasp.com/freebook/learn/utilitybelt_errorhandling.aspx'>")
.Append("Additional Error-Handling Documentation Here</a><br>")
.Append(strIndent)
.Append("use <b>Options(""Debug-on"")</b> to see detailed error messages<br>")
.Append(strIndent)
.Append("<a href='http://groups.yahoo.com/group/AspNetUtilityBelt'>")
.Append("Programmer Technical Support Here</a></font>")
.Append("</font></td></tr></table><br>")
End With
strErrMessage_ = sbTemp.ToString()
end sub
Private Sub ConfigRead()
Dim Xmltr1 As XmlTextReader
Dim strTask As String = "SUB ConfigRead"
Try
LogTaskStart(strTask)
Dim strFileName As String
ErrorReset()
strFileName = FileMapIfNeeded("utilitybelt.config", strTask)
If File.Exists(strFileName) = False Then
ErrorReset()
strFileName = FileMapIfNeeded("\utilitybelt.config", strTask)
Else
LogFlow("Config File Found",strFileName)
End If
If errorCount = 1 Then
LogAdviceUtilityBeltConfigNotFound(strTask, strFileName)
LogTaskEnd(strTask)
Exit Sub
End If
Xmltr1 = New XmlTextReader(strFileName)
objectCreateTrack(strTask,XmlTr1)
Do While Xmltr1.Read()
If Xmltr1.NodeType = Element Then
Dim strElementName As String = Xmltr1.Name
Select Case strElementName
Case "ub"
' nothing to do all is well
Case "amazonpromocode"
Xmltr1.Read()
strAmazonPromoCode_ = Xmltr1.Value
Case "amazondevtoken"
Xmltr1.Read()
strAmazonDevToken_ = Xmltr1.Value
Case "strErrorMessage"
Xmltr1.Read()
strErrMessage_ = Xmltr1.Value
Case "strLogFilename"
Xmltr1.Read()
strLogFileName_ = Xmltr1.Value
Case "strMailErrorsTo"
Xmltr1.Read()
strMailErrorsTo_ = Xmltr1.Value
Case "strMailErrorSubject"
Xmltr1.Read()
strMailErrorSubject_ = Xmltr1.Value
Case "strMailSMTPServer"
Xmltr1.Read()
strMailSmtpServer = Xmltr1.Value
Trace.Write("strMailSMTPServer", strMailSmtpServer)
case "supertrace"
Xmltr1.Read()
dim strGlobalSuperTrace as string=Xmltr1.Value
strGlobalSuperTrace = strGlobalSuperTrace.ToLower
If ConvertStringToBoolean(strGlobalSuperTrace)
bolSuperTrace_=true
End If
Case Else
Xmltr1.Read()
Dim strTemp As String = Xmltr1.Value
LogAdviceConfigUnknownElement(strTask, strElementName, strTemp)
End Select
End If
Loop
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Xmltr1)
End Try
End Sub
Function ConvertStringToBoolean (parmStrToConv as string) as boolean
dim strTemp as string
strTemp=parmStrToConv.ToLower()
If strTemp="on" OR strTemp="y" OR strTemp="yes" THEN
return(true)
Else
return(false)
end if
end function
Private Function ConvertStr2ByteArray(ByVal strInput As String) As Byte()
' Thanks to Steve Walther ASP.net Unleashed book
' http://www.amazon.com/exec/obidos/ISBN=0672320681/learnasp
' Need To Deal with Unicode in Next Version
' dave 123aspx: hmmm... i think there is a small error in the Convert2ByteArray() function
' Chaz - No Myth: go
' dave 123aspx: hang on.. still thinking out loud
' Chaz - No Myth: It came from Steve Walther's book
' dave 123aspx: hmmm... i ran into something likethis before... not all char consist of only 1 byte
' Chaz - No Myth: Unicode chars are 2 bytes for example sometimes more.
' dave 123aspx: and you can loose characters when you try to convert a multibyte char to a single byte
' dave 123aspx: use the Encoding.GetBytes() method
' dave 123aspx: much cleaner
Dim strTask As String = "ConvertStr2ByteArray"
LogTaskParms(strTask,"strInput",strInput)
Try
LogTaskStart(strTask)
Dim intCounter As Integer
Dim arrChar As Char()
'LogDebugData(strTask, "Convert2ByteArray" & strInput)
arrChar = strInput.ToCharArray()
Dim arrByte(arrChar.Length - 1) As Byte
' LogDebugData(strTask,"byte length=" & arrByte.Length)
For intCounter = 0 To arrByte.Length - 1
' LogDebugData(strTask,intCounter & " => " & arrChar(intCounter) )
arrByte(intCounter) = Convert.ToByte(arrChar(intCounter))
Next
Return (LogReturn(strTask,arrByte))
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Function ConvertStr2MD5checksum(ByVal strParm1 As String) As String
' Thanks to Jeff SchoolCraft For This Code
' Description: strings cannot easily be used as names for say caches or other programming elements
' without escaping certain letters and punctuation. For example the string:
' select * from publishers WHERE state='CA'
' PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=D:\domains\stage.learnasp.com\experiments\data\biblio.mdb;
' would not be an acceptable cache name because it has characters that would be illegal in variable names
' and is too long as well. The MD5 Checksum representation would be an acceptable variable name, i.e
' 03-7E-5E-F3-62-25-CF-52-BE-9A-A7-4F-58-7E-07
Dim strTask As String = "ConvertStr2MD5checksum"
LogTaskParms(strTask,"strParm1",strParm1)
Try
LogTaskStart(strTask)
Dim arrHashInput As Byte()
Dim arrHashOutput As Byte()
Dim objMD5 As MD5CryptoServiceProvider
objMD5 = New MD5CryptoServiceProvider
arrHashInput = ConvertStr2ByteArray(strParm1)
arrHashOutput = objMD5.ComputeHash(arrHashInput)
Dim strChecksum As String = BitConverter.ToString(arrHashOutput)
' LogDebugData(strtask,"strParm1=" & strParm1)
' LogDebugData(strtask,"strChecksum=" & strChecksum)
LogTaskEnd(strTask)
Return (LogReturn(strTask,strChecksum))
Catch ex1 As Exception
LogException("ConvertStr2MD5checksum", ex1)
Finally
End Try
End Function
Shared Sub CtrlDropdownSelect(ByRef drpP1 As DropDownList, ByVal strP2 As String)
drpP1.SelectedIndex = drpP1.Items.IndexOf(drpP1.Items.FindByValue(strP2))
End Sub
Shared Sub CtrlListBoxSelect(ByRef lstP1 As ListBox, ByVal strP2 As String)
lstP1.Items.FindByValue(strP2).Selected = True
End Sub
Private Sub CtrlFindAndAdd(ByVal strControlName As String, ByVal objParm As Object)
' Not working, Not Final yet
Dim whatever As Control
'whatever=Page.findcontrol(strControlName)
Dim strTypenameOfFind As String = TypeName(whatever)
If strTypenameOfFind = "Nothing" Then
Trace.Warn("Sub ControlFindAndAdd", "Can't Find Control id=" & strControlName)
Else
whatever.Controls.Add(objParm)
End If
End Sub
Private Function DataTableGet(ByVal strConn As String, ByVal strSQL As String) As DataTable
Dim strTask As String = "DataTableGet"
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
LogTaskEnd(strTask)
Return (DataTableGetSQLClient(strConn, strSQL))
Case "oledb"
LogTaskEnd(strTask)
Return (DataTableGetOLEDB(strConn, strSQL))
End Select
End Function
Private Function DataTableGet(ByVal strConn As String, ByVal strSQL As String, ByRef ht As Hashtable) As DataTable
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "DataTableGet"
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"ht", ht)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
LogTaskEnd(strTask)
Return LogReturn(strTask,SPSQLServer_DataTableGet(strConn, strSQL, ht))
Case Else
Throw New EntryPointNotFoundException(strTask & "::" & DBAnalyzeConn(strConn) & " not implemented")
End Select
End Function
Private Function DataTableGetOLEDB(ByVal strConn As String, ByVal strSQL As String) As DataTable
Dim strTask As String = "DataTableGetOLEDB"
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
If bolCache_ Then
LogTaskEnd(strTask)
Return LogReturn(strTask,DataTableGetOLEDBCached(strConn, strSQL, intCacheMinutes_))
Else
LogTaskEnd(strTask)
Return LogReturn(strTask,DataTableGetOLEDBCachedNot(strConn, strSQL))
End If
End Function
Private Function DataTableGetOLEDBCached(ByVal strConn As String, ByVal strSQL As String, ByVal intMinutes As Integer) As DataTable
Dim strTask As String = "DataTableGetOLEDBCached"
Try
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"intMinutes", intMinutes)
Dim strChksum As String
strChksum = ConvertStr2MD5checksum(strSQL & System.Environment.NewLine & strConn)
Dim dt1 As DataTable
If System.Web.HttpContext.Current.Cache(strChksum) Is Nothing Then
LogCache(strTask, "Adding To Cache")
dt1 = DataTableGetOLEDBCachedNot(strConn, strSQL)
System.Web.HttpContext.Current.Cache.Insert(strChksum, dt1, Nothing, DateTime.Now.AddMinutes(intMinutes), System.Web.HttpContext.Current.Cache.NoSlidingExpiration)
ObjectCreateTrack(strTask,cache(strChkSum))
Else
LogCache(strTask, "Using From Cache")
dt1 = System.Web.HttpContext.Current.Cache(strChksum)
End If
LogTaskEnd(strTask)
Return dt1
Catch ArgumentNullException As Exception
Dim strDiagnosis As String = "Tried to Cache Null Data, Maybe earlier failed database connection!"
LogException(strTask, ArgumentNullException)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Function DataTableGetOLEDBCachedNot(ByVal strConn As String, ByVal strSQL As String) As DataTable
Dim strTask As String = "DataTableGetOLEDBCachedNot"
Try
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim dt1 As New DataTable
Dim conn As New OleDbConnection(strConn)
Dim adapter As New OleDbDataAdapter(strSQL, conn)
adapter.Fill(dt1)
' LogDebugData(strTask,"DataTable Row Count=" & dt1.rows.count)
LogTaskEnd(strTask)
Return (dt1)
Catch OleDbException As Exception
If OleDbException.Message.IndexOf("is not a valid path") > -1 Then
LogException(strTask, OleDbException)
End If
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Function DataTableGetSQLClient(ByVal strConn As String, ByVal strSQL As String) As DataTable
Dim strTask As String = "DataTableGetSQLClient"
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
If bolCache_ Then
LogTaskEnd(strTask)
Return DataTableGetSQLClientCached(strConn, strSQL, intCacheMinutes_)
Else
LogTaskEnd(strTask)
Return DataTableGetSQLClientCachedNot(strConn, strSQL)
End If
End Function
Private Function DataTableGetSQLClientCached(ByVal strConn As String, ByVal strSQL As String, ByVal intMinutes As Integer) As DataTable
Dim strTask As String = "DataTableGetSQLClientCached"
Try
LogTaskStart(strTask)
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim strChksum As String
strChksum = ConvertStr2MD5checksum(strConn & ";" & strSQL)
Dim dt1 As DataTable
' LogDebugData(strTask,"strChksum=" & strChkSum)
If System.Web.HttpContext.Current.Cache(strChksum) Is Nothing Then
LogCache(strTask, "Adding To Cache")
dt1 = DataTableGetSQLClientCachedNot(strConn, strSQL)
System.Web.HttpContext.Current.Cache.Insert(strChksum, dt1, Nothing, DateTime.Now.AddMinutes(intMinutes), System.Web.HttpContext.Current.Cache.NoSlidingExpiration)
ObjectCreateTrack(strTask,cache(strChkSum))
Else
LogCache(strTask, "Using From Cache")
dt1 = System.Web.HttpContext.Current.Cache(strChksum)
End If
LogTaskEnd(strTask)
Return dt1
Catch ex1 As Exception
' ToDo Deal with Cache Exceptions
LogException(strTask, ex1)
Finally
End Try
End Function
Private Function DataTableGetSQLClientCachedNot(ByVal strConn As String, ByVal strSQL As String) As DataTable
Dim strTask As String = "DataTableGetSQLClientCachedNot"
Try
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim dt1 As New DataTable("temp")
Dim conn As New SqlConnection(strConn)
LogTaskSQL(strTask, strSQL)
Dim adapter As New SqlDataAdapter(strSQL, conn)
adapter.Fill(dt1)
LogTaskEnd(strTask)
Return dt1
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO: should I be disposing of resources here?
End Try
End Function
Private Function DBAccess2Oledb(ByVal strAccessFileName As String) As String
Return ("PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & FileMapIfNeeded(strAccessFileName, "DBAccess2Oledb"))
End Function
Private Function DBAnalyzeConn(ByRef strParmConn As String) As String
' altered 16 nov 2003: inclusion of other SQL server connection string format
Dim strTempConn As String
Dim bolSQLserver As Boolean
Dim strTask As String = "DBAnalyzeConn"
LogTaskParms(strTask,"strParmConn",strParmConn)
Try
Dim bolappKeyFound As Boolean = False
strTempConn = strParmConn.ToLower()
If strTempConn.IndexOf("server=") > -1 Then bolSQLserver = True
If strTempConn.IndexOf("initial catalog=") > -1 Then bolSQLserver = True
' check for valid sqlserver
If Not (bolSQLserver) Then
' check for path if not a sqlserver conn string
Dim intProviderFound = strTempConn.IndexOf ("provider=")
Dim intSlashFound = strTempConn.IndexOf("\")
Dim intBackSlashFound = strTempConn.IndexOf("/")
Dim intPeriodFound = strTempConn.IndexOf(".")
Dim intFoundTotal As Integer = intProviderFound + intSlashFound + intBackSlashFound + intPeriodFound
' its an appkey go fetch
If intFoundTotal = -4 Then
logTask(strTask, "detected appkey connect string")
bolappKeyFound = True
strParmConn = appkey(strParmConn)
strTempConn = strParmConn.ToLower()
' check again for SQL server string
If strTempConn.IndexOf("server=") > -1 Then bolSQLserver = True
If strTempConn.IndexOf("initial catalog=") > -1 Then bolSQLserver = True
End If
End If
If bolSQLserver Then
logTask(strTask, "detected SQLserver connect string")
If bolappKeyFound = False Then
LogAdviceHardCodedConnectString(strTask, strParmConn)
End If
LogTaskEnd(strTask)
Return LogReturn(strTask,"sqlserver")
Else
' Is this check needed ??? ( .asp rename trick for .mdb )
If strTempConn.IndexOf(".mdb") <> -1 Then
logTask(strTask, "detected Access connect string")
If bolappKeyFound = False Then
LogAdviceHardCodedConnectString(strTask, strParmConn)
End If
' this seems to be the correct one
If strTempConn.IndexOf ("provider=microsoft.jet.oledb.4.0") = -1 Then
logTask(strTask, "detected Access filename without connect string")
strParmConn = DBAccess2Oledb(strParmConn)
End If
End If
LogTaskEnd(strTask)
Return LogReturn (strTask,"oledb")
End If
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Sub DBExec(ByVal strConn As String, ByVal strSQL As String)
Dim strTask As String = "DBExec"
LogTaskStart(strTask)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
DBExecSQLClient(strConn, strSQL)
Case "oledb"
DBExecOLEDB(strConn, strSQL)
End Select
LogTaskEnd(strTask)
End Sub
Function DBExec(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable) As Integer
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "DBExec hashtable"
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL, "htParms", htParms)
Dim intret As Integer = 0
LogTaskStart(strTask)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
intret = SPSQLServer_DBExec(strConn, strSQL, htParms)
Case Else
Throw New EntryPointNotFoundException(strTask & "::" & DBAnalyzeConn(strConn) & " is not implemented")
End Select
LogTaskEnd(strTask)
Return intret
End Function
Private Sub DBExecOLEDB(ByVal strConn As String, ByVal strSQL As String)
Dim strTask As String = "DBExecOLEDB"
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim Conn1 As OleDbConnection
Dim Cmd1 As OleDbCommand
Dim intReturn As Integer
Try
LogTaskStart(strTask)
LogTaskSQL(strTask, strSQL)
Conn1 = New OleDbConnection(strConn)
Cmd1 = New OleDbCommand(strSQL, Conn1)
Conn1.Open()
intReturn = Cmd1.ExecuteNonQuery()
logSQLReturn(strTask, intReturn, "intReturn")
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Conn1)
End Try
End Sub
Private Sub DBExecSQLClient(ByVal strConn As String, ByVal strSQL As String)
Dim strTask As String = "SUB DBExecSQLClient"
logTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim intReturn As Integer
Try
LogTaskStart(strTask)
logParm(strTask, strConn, "strConn")
logParm(strTask, strSQL, "strSQL")
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Conn1.Open()
intReturn = Cmd1.ExecuteNonQuery()
logSQLReturn(strTask, intReturn, "intReturn")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Conn1)
End Try
End Sub
Sub DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef arrDB As Array)
Dim strTask As String = "SUB DBPopulate / array = 3rd parm"
LogTaskStart(strTask)
LogAdviceAdHocSQL(strTask, strSQL)
ArrayFromDatatable(strConn, strSQL, arrDB)
LogTaskEnd(strTask)
End Sub
Sub DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef string1 As String)
' The problem is that Strings are not byref in DBpopulate anymore
Dim strTask As String = "DBPopulate / string as 3rd parameter"
LogAdviceAdHocSQL(strTask, strSQL)
string1 = DBScalar(strConn, strSQL)
End Sub
Sub DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef int1 As Integer)
' The problem is that Strings are not byref in DBpopulate anymore
Dim strTask As String = "DBPopulate / int as 3rd parameter"
LogAdviceAdHocSQL(strTask, strSQL)
int1 = DBScalar(strConn, strSQL)
End Sub
Sub DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef objParm As Object)
' used to be SUB DBPopulate(strConn as string,strSQL as string,byref objParm as object)
' C# does not like byref on 3rd parameter
' because it can't convert anything to object byref
Dim strTypeName As String = TypeName(objParm).ToLower()
Dim strTask As String = "DBPopulate w/3 Params; (3rd Param obj type=" & strTypeName & ")"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objParm", objparm)
Try
LogAdviceAdHocSQL(strTask, strSQL)
If TypeOf (objParm) Is Control Then
Select Case strTypeName
Case "literal"
Dim litTemp As Literal
litTemp = objParm
litTemp.Text = DBScalar(strConn, strSQL)
Case "textbox"
Dim txtTemp As TextBox
txtTemp = objParm
txtTemp.text = DBScalar(strConn, strSQL)
Case Else
Trace.Warn ("DbPopulate",strTypeName)
DBPopulate_Control(strConn, strSQL, objParm)
End Select
Exit Sub
End If
Select Case strTypeName
Case "datatable"
objParm = DataTableGet(strConn, strSQL)
logWarning(strTask, "datatable rowcount=" & objParm.rows.count)
Case "dataview"
Dim dtTemp As New DataTable
dtTemp = DataTableGet(strConn, strSQL)
Dim dv1 As New System.data.DataView(dtTemp)
objParm = dv1
Case "textbox"
Dim txtTemp As TextBox
txtTemp = objParm
txtTemp.text = DBScalar(strConn, strSQL)
txtTemp = objParm
objParm.text = DBScalar(strConn, strSQL)
Case "string()", "string(,)"
ArrayFromDatatable(strConn, strSQL, objParm)
Case "nothing" '
ArrayFromDatatable(strConn, strSQL, objParm)
Case Else
Trace.Warn ("DbPopulate",strTypeName)
logWarning(strTask, "TypeName=" & strTypeName & " NOT recognized")
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef htParm As Hashtable, ByRef objParm As Object)
Dim strTask As String = "SUB DBPopulate / hash=3rd parm object, object=4th parm"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"htParm",htParm,"objParm", objparm)
Dim strTypeName As String
Try
strTypeName = TypeName(objParm).ToLower
If TypeOf (objParm) Is Control Then
Select Case strTypeName
Case "literal"
Dim litTemp As Literal
litTemp = objParm
litTemp.Text = SP_DBScalar(strConn, strSQL, htParm)
Case "textbox"
Dim txtTemp As TextBox
txtTemp = objParm
txtTemp.Text = SP_DBScalar(strConn, strSQL, htParm)
Case Else
SP_DBPopulate_Control(strConn, strSQL, htParm, objParm)
End Select
Exit Sub
End If
Select Case strTypeName
Case "datatable"
Dim dtTemp As New DataTable
dtTemp = objParm
SP_DBPopulate_DataTable(strConn, strSQL, htParm, dtTemp)
objParm=dtTemp
Case "integer", "string", "datetime"
objParm = DBScalar(strConn, strSQL)
Case "nothing"
' whatever
Case "string()"
SP_DBPopulate_Array1d(strConn, strSQL, htParm, objParm)
Case "string(,)"
SP_DBPopulate_Array2d(strConn, strSQL, htParm, objParm)
Case Else
logWarning(strTask, "TypeName=" & strTypeName & " NOT recognized")
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
private Sub DBPopulate(ByVal objParmDataSource As DataTable, ByVal objParmControl As Object)
DBPopulate_ControlFromDataViewOrDataTable(objParmDataSource,objParmControl)
End Sub
Sub DBPopulate(ByVal objParmDataSource As DataView, ByRef objParmControl As Object)
DBPopulate_ControlFromDataViewOrDataTable(objParmDataSource,objParmControl)
End Sub
Sub DBPopulate_ControlFromDataViewOrDataTable(ByVal objParmDataSource As object, ByRef objParmControl As Object)
DIM strTask as string="SUB DBPopulate_ControlFromDataViewOrDataTable"
LogTaskStart(strTask)
LogTaskParms(strTask, "objParmDataSource",objParmDataSource,"objParmControl", objparmControl)
Try
Dim intHowManyRows as integer
TRY
' works for DataTable
intHowManyRows=objParmDataSource.Rows.count
CATCH
' works for DataView
intHowManyRows=ObjParmDataSource.Count
END TRY
'Trace.Warn("intHowManyRows",intHowManyRows)
If intHowManyRows=0
' nothing to do
else
objParmControl.DataSource = objParmDataSource
objParmControl.DataBind()
end if
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
end sub
Function DBPopulate(ByVal strConn As String, ByVal strSQL As String) As Object
Dim strTask As String = "Function DBPopulate returns object"
Dim strTypeName As String
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Try
LogAdviceAdHocSQL(strTask, strSQL)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
Return (DBPopulateSQLClientDatareader(strConn, strSQL))
Case "oledb"
Return (DBPopulateOleDBDatareader(strConn, strSQL))
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Sub DBPopulate_Control(ByVal strConn As String, ByVal strSQL As String, _
ByVal objParm As Object)
Dim strTask As String = "SUB DBPopulate_Control"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objParm", objparm)
Dim strTypeName As String
Try
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
DBPopulateSQLClient(strConn, strSQL, objParm)
Case "oledb"
DBPopulateOLEDB(strConn, strSQL, objParm)
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
sub spDBPopulate(ByVal ParamArray objParms As Object())
Dim strTask As String = "SUB spDBPopulate"
LogTaskStart(strTask)
dim strConnect as string=objParms(0)
dim strProcName as string=objParms(1)
dim objWhatToFill as object=objParms(2)
dim htParm as NEW HashTable()
Dim parmCount as integer=Ubound(objParms)
dim counter as integer
If (ParmCount) MOD 2 = 0
LogHint(strTask, "spDBPopulate Incorrect Number of Parameters")
Else
' fine odd number of parameters
End If
For counter = 4 to ParmCount step 2
htParm.Add(objParms(counter-1),objParms(counter))
next
DBPopulate(strConnect,strProcName,htParm,objWhatToFill)
end sub
Function DBPopulateSQLClientDatareader(ByVal strConn As String, ByVal strSQL As String) As SqlDataReader
Dim strTask As String = "DBPopulateSQLClient"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim Rdr1 As SqlDataReader
Try
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader(System.Data.CommandBehavior.CloseConnection)
If Rdr1 Is Nothing Then
' nothing to do
logWarning(strTask, "Empty SQLDataReader")
Return (Nothing)
Else
intReaderUnClosedCount += 1
Return (Rdr1)
End If
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Sub DBPopulateOLEDB(ByVal strConn As String, ByVal strSQL As String, ByRef objToFill As Object)
Dim strTask As String = "SUB DBPopulateOLEDB"
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objToFill", objToFill)
Dim Conn1 As OleDbConnection
Dim Cmd1 As OleDbCommand
Dim Rdr1 As OleDbDataReader
Try
If bolCache_ Then
DBPopulateCachedOLEDB(strConn, strSQL, objToFill)
LogTaskEnd(strTask)
Exit Sub
End If
Conn1 = new OleDbConnection(strConn)
ObjectCreateTrack(strTask,Conn1)
LogTaskSQL(strTask, strSQL)
Cmd1 = New OleDbCommand(strSQL, Conn1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader()
If Rdr1 Is Nothing Then
' nothing to do
logWarning(strTask, "Empty DataReader")
Else
objToFill.DataSource = Rdr1
objToFill.DataBind()
End If
LogTaskEnd(strTask)
Catch ex1 As Exception
If TypeName(ex1) = "OleDbException" Then
Dim strMessage As String
strMessage = ex1.Message
'LogException(strTask,ex1)
If strMessage = "No value given for one or more required parameters." Then
LogHint(strTask, "Most likely a mispelled a field name in a SQL statement", strSQL, "strSQL")
ElseIf strMessage.IndexOf("cannot find the input table or query") > -1 Then
LogHint(strTask, "Most likely a mispelled a table or query name in a SQL statement", strSQL, "strSQL")
ElseIf strMessage.IndexOf("Syntax error (missing operator) in query expression") > -1 Then
LogHint(strTask, "Syntax Error in your SQL statement", strSQL, "strSQL")
Else
LogException(strTask, ex1)
End If
Exit Sub
Else
LogException(strTask, ex1)
End If
Finally
Release(Rdr1)
Release(Conn1)
End Try
End Sub
Function DBPopulateOleDBDatareader(ByVal strConn As String, ByVal strSQL As String) As OleDbDataReader
Dim strTask As String = "DBPopulateOleDBDatareader"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Dim Conn1 As OleDbConnection
Dim Cmd1 As OleDbCommand
Dim Rdr1 As OleDbDataReader
Try
Conn1 = New OleDbConnection(strConn)
Cmd1 = New OleDbCommand(strSQL, Conn1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader(System.Data.CommandBehavior.CloseConnection)
If Rdr1 Is Nothing Then
' nothing to do
logWarning(strTask, "Empty OLEDBDataReader")
Return (Nothing)
Else
intReaderUnClosedCount += 1
Return (Rdr1)
End If
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Sub DBPopulateCachedOLEDB(ByVal strConn As String, ByVal strSQL As String, ByRef objToFill As Object)
Dim strTask As String = "sub DBPopulateCachedOLEDB"
Try
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objToFill", objToFill)
Dim dt1 As DataTable
dt1 = DataTableGetOLEDBCached(strConn, strSQL, intCacheMinutes_)
objToFill.DataSource = dt1
objToFill.DataBind()
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub DBPopulateSQLClient(ByVal strConn As String, ByVal strSQL As String, ByRef objToFill As Object)
Dim strTask As String = "sub DBPopulateSQLClient "
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objToFill", objToFill)
If bolLogSensitive_ Then
strTask &= "<br>" & vbCrLf & " object.id=" & objToFill.id
strTask &= "<br>" & vbCrLf & " strSQL=" & strSQL & vbCrLf
End If
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim Rdr1 As SqlDataReader
Try
If bolCache_ Then
DBPopulateCachedSQLClient(strConn, strSQL, objToFill)
LogTaskEnd(strTask)
Exit Sub
End If
Conn1=New SqlConnection(strConn)
ObjectCreateTrack(strTask,Conn1)
Cmd1 = New SqlCommand(strSQL, Conn1)
ObjectCreateTrack(strTask,Cmd1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader()
ObjectCreateTrack(strTask,rdr1)
If Rdr1 Is Nothing Then
logWarning(strTask, "Empty DataReader")
Else
objToFill.DataSource = Rdr1
objToFill.DataBind()
End If
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Rdr1)
Release(Conn1)
LogTaskEnd(strTask)
End Try
End Sub
Private Sub DBPopulateCachedSQLClient(ByVal strConn As String, ByVal strSQL As String, ByRef objToFill As Object)
Dim strTask As String = "sub DBPopulateCachedSQLClient"
Try
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL,"objToFill", objToFill)
Dim dt1 As DataTable
dt1 = DataTableGetSQLClientCached(strConn, strSQL, intCacheMinutes_)
objToFill.DataSource = dt1
objToFill.DataBind()
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Function DBScalar(ByVal strConn As String, ByVal strSQL As String) As Object
Dim strTask As String = "DBScalar"
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
LogTaskEnd(strTask)
Return (DBScalarSqlClient(strConn, strSQL))
Case "oledb"
LogTaskEnd(strTask)
Return (DBScalarOLEDB(strConn, strSQL))
End Select
End Function
Private Function DBScalarOLEDB(ByVal strConn As String, ByVal strSQL As String) As Object
Dim strTask As String = "DBScalarOLEDB"
Dim Conn1 As OleDbConnection
Dim objTempReturn As Object
Try
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Conn1 = New OleDbConnection(strConn)
ObjectCreateTrack(strtask,Conn1)
Dim Cmd1 As New OleDbCommand(strSQL, Conn1)
ObjectCreateTrack(strTask,cmd1)
Conn1.Open()
objTempReturn = Cmd1.ExecuteScalar()
LogTaskEnd(strTask)
logSQLReturn(strTask, objTempReturn, "objTempReturn")
Catch ex1 As InvalidCastException
Return (objNull_)
Catch ex1 As Exception
If TypeName(ex1) = "ArgumentException" Then
Dim strMessage As String
strMessage = ex1.message
If strMessage.IndexOf("An OLE DB Provider was not specified in the ConnectionString") > -1 Then
' ??? End of statement expected
' LogErrorWithSensitiveDetail(strTask,"Bad connection string",strConn,"strConn") exit function
Else
LogException(strTask, ex1)
End If
End If
Finally
Release(Conn1)
End Try
Return (objTempReturn)
End Function
Private Function DBScalarSqlClient(ByVal strConn As String, ByVal strSQL As String) As Object
Dim strTask As String = "DBScalarSQLClient"
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim objTempReturn As Object
Try
LogTaskStart(strTask)
LogTaskParms(strTask, "strConn", strConn,"strSQL", strSQL)
Conn1 = New SqlConnection(strConn)
ObjectCreateTrack(strTask,Conn1)
Cmd1 = New SqlCommand(strSQL, Conn1)
ObjectCreateTrack(strTask,Cmd1)
Conn1.Open()
objTempReturn = Cmd1.ExecuteScalar()
logSQLReturn(strTask, objTempReturn, "objTempReturn")
Return (objTempReturn)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Conn1)
End Try
End Function
Private SUB DisplayLogGrid(strNameOfGrid as string, dtLog as DataTable)
DisplayLogGridFromDataTableOrDataView(strNameOfGrid,dtLog)
END SUB
Private SUB DisplayLogGrid(strNameOfGrid as string, dtLog as DataView)
DisplayLogGridFromDataTableOrDataView(strNameOfGrid,dtLog)
END SUB
private sub DisplayLogGridFromDataTableOrDataView(strNameOfGrid as string, dtLog as object)
dim strTask as string="SUB DisplayLogGridFromDataTable; object=" & strNameOfGrid
LogTaskStart(strTask)
plcException.Controls.Add(New LiteralControl("<hr>"))
plcException.Controls.Add(New LiteralControl("<font color='red'>" & strNameOfGrid & "(option <b>" & strNameOfGrid & "=Off</b> will hide this)</font>"))
Dim dgTemp As New DataGrid
dim htGridOptions as new HashTable
htGridOptions("name") = strNameOfGrid
Gridformat(DgTemp, htGridOptions)
DBPopulate_ControlFromDataViewOrDataTable(dtLog, dgTemp)
plcException.Controls.Add(dgTemp)
LogTaskEnd(strTask)
end sub
Private Sub DisplayLog()
' Before We Analyze Errors and Hints
' We Must Check for Resources Not Disposed Of
Dim strTask as string="SUB DisplayLog"
LogTaskStart(strTask)
If intReaderUnClosedCount > 0 Then
LogHint("Dispose", "unclosedReaders=" & intReaderUnClosedCount)
End If
Dim intCountAllRows As Integer
Dim intTableAdviceRowCount As Integer = dsXray.Tables("Advice").Rows.Count
Dim intTableErrorsRowCount As Integer = dsXray.Tables("Errors").Rows.Count
Dim intTableHintsRowCount As Integer = dsXray.Tables("Hints").Rows.Count
Dim intTableMesagesRowCount As Integer = dsXray.Tables("Messages").Rows.Count
Dim intTableSuperTraceRowCount As Integer = dsXray.Tables("SuperTrace").Rows.Count
Dim intTableSuperTraceSummaryRowCount As Integer = dsXray.Tables("SuperTraceSummary").Rows.Count
intCountAllRows = intTableErrorsRowCount
If intCountAllRows > 0 Then
plcException.Controls.Add(New LiteralControl(strErrMessage_))
End If
If intTableHintsRowCount > 0 And BolHints_ = True Then
DisplayLogGrid("Hints",dsXray.Tables("Hints"))
End If
If intTableErrorsRowCount > 0 And bolErrorDetails_ = True Then
DisplayLogGrid("Errors",dsXray.Tables("Errors"))
End If
If intTableAdviceRowCount > 0 And BolAdvice_ = True Then
DisplayLogGrid("Advice",dsXray.Tables("Advice"))
End If
If intTableMesagesRowCount > 0 And bolMessages_ = True Then
DisplayLogGrid("Messages",dsXray.Tables("Messages"))
End If
If intTableSuperTraceRowCount > 0 And bolSuperTrace_ = True Then
SuperTracePostProcess()
'plcException.Controls.Add(New LiteralControl("<hr>"))
'plcException.Controls.Add(New LiteralControl("MinutesTotal=" & MinutesTotal & "<br>"))
Dim dv1 As New DataView(dsXray.Tables("SuperTrace"))
If strSuperTraceHide_ = "" And strSuperTraceShow_ <> "" Then
dv1.RowFilter = "EventCategory='" & strSuperTraceShow_ & "'"
Trace.Warn("DV1.rowfilter", dv1.RowFilter)
End If
If strSuperTraceHide_ <> "" And strSuperTraceShow_ = "" Then
dv1.RowFilter = "EventCategory<>'" & strSuperTraceShow_ & "'"
Trace.Warn("DV1.rowfilter", dv1.RowFilter)
End If
' what if they are both non-blank?
If dsXray.Tables("SuperTrace").Rows.Count > 0 Then
plcException.Controls.Add(New LiteralControl("<font color='blue'>SuperTrace</font>"))
Dim dgSuperTrace As New DataGrid
dim bc1 as new boundcolumn
dim bc2 as new boundcolumn
dim bc3 as new boundcolumn
dim bc4 as new boundcolumn
dim bc5 as new boundcolumn
with dgSuperTrace
.autogeneratecolumns=false
with bc4
.HeaderText="EventTickCount"
.DataField="EventTickcount"
.DataFormatString="<small>{0:N8}</small>"
end with
.columns.Add(bc4)
with bc5
.HeaderText="Elapsed"
.DataField="Elapsed"
'.DataFormatString="{0:N0}"
.DataFormatString="<small>{0:N8}</small>"
end with
bc5.ItemStyle.HorizontalAlign=HorizontalAlign.Right
.columns.Add(bc5)
with bc1
.HeaderText="Caller"
.DataField="Caller"
.DataFormatString="<small>{0}</small>"
end with
.columns.Add(bc1)
with bc3
.HeaderText="EventDescription"
.DataField="EventDescription"
.DataFormatString="{0}"
end with
.columns.Add(bc3)
with bc2
.HeaderText="LogType"
.DataField="LogType"
.DataFormatString="{0}"
end with
.columns.Add(bc2)
end with
DisplayLogGrid("SuperTrace",dsXray.Tables("SuperTrace"))
End If
If intTableSuperTraceSummaryRowCount > 0 And bolMessages_ = True Then
DBPopulate(dv1, dsXray.Tables("SuperTraceSummary"))
'dv1.Sort = "ItemType"
DisplayLogGrid("SuperTraceSummary",dsXray.Tables("SuperTraceSummary"))
End If
End If
LogTaskEnd(strTask)
End Sub
Sub EdgeCase(ByVal strEdgeCaseName As String)
strEdgeCaseName = strEdgeCaseName.ToLower()
End Sub
Sub EdgeCase(ByVal htParams As Hashtable)
Dim strTask As String = "EdgeCase hashtable"
Try
Dim strEdgeCaseName As String
Dim d As DictionaryEntry
Dim strKey As String
Dim objvalue As Object
For Each d In htParams
strKey = d.Key
objvalue = d.Value
strEdgeCaseName = strKey.ToLower()
Select Case strEdgeCaseName
Case "strmailerrorsto"
strMailErrorsTo_ = objvalue
Case "strerrmessage"
strErrMessage_ = objvalue
Case "stramazonpromocode"
strAmazonPromoCode_ = objvalue
Case "stramazondevtoken"
strAmazonDevToken_ = objvalue
Case Else
logWarning("EdgeCase", "EdgeCase unknown=> key=" & strKey & " value=" & objvalue.ToString())
End Select
Next d
Catch exc1 As Exception
LogException(strTask, exc1)
End Try
End Sub
Sub ErrorReset()
errorCount_ = 0
intHintNumber = 0
errorOccured_ = False
End Sub
Sub FileAppend(ByVal strParmFileName As String, ByVal strParm As String)
Dim strTask As String = "sub FileAppend string overload"
Dim fs As FileStream
Dim tw As StreamWriter
Try
LogTaskStart(strTask)
If File.Exists(strParmFileName) Then
fs = StreamFileAppend(strParmFileName, strTask)
Else
fs = StreamFileCreate(strParmFileName, strTask)
End If
ObjectCreateTrack(strTask,fs)
tw = New StreamWriter(fs)
ObjectCreateTrack(strTask,tw)
tw.Write(strParm)
tw.Flush()
LogTaskEnd(strTask)
Catch exc1 As Exception
LogException(strTask, exc1)
Finally
Release(tw)
Release(fs)
End Try
End Sub
Sub FileAppend(ByVal strParmFileName As String, ByVal arrayParm As String())
Dim strTask As String = "sub FileAppend array overload"
Dim fs As FileStream
Dim tw As StreamWriter
Dim intarraycounter As Integer
Try
LogTaskStart(strTask)
If File.Exists(strParmFileName) Then
fs = StreamFileAppend(strParmFileName, strTask)
Else
fs = StreamFileCreate(strParmFileName, strTask)
End If
ObjectCreateTrack(strTask,fs)
tw = New StreamWriter(fs)
ObjectCreateTrack(strTask,tw)
For intarraycounter = 0 To arrayParm.GetUpperBound(0)
tw.WriteLine(arrayParm(intarraycounter))
Next
tw.Flush()
LogTaskEnd(strTask)
Catch exc1 As Exception
LogException(strTask, exc1)
Finally
Release(tw)
Release(fs)
End Try
End Sub
Function FileMapIfNeeded(ByVal strParmFN As String, ByVal strCallerName As String) As String
Dim strTask As String = "FileMapIfNeeded"
LogTaskParms(strTask,"strParmFn",strParmFn,"strCallerName",strCallerName)
Dim strNewFileName As String
Dim bolHardCoded As Boolean = False
strNewFileName = strParmFN
If strParmFN.StartsWith("\") Or strParmFN.StartsWith("/") Then
bolHardCoded = False
logFlow(strTask, "starts with / or \ attempt to mappath")
Try
strNewFileName = Server.MapPath(strParmFN)
Catch
End Try
Else
End If
If File.Exists(strNewFileName) Then
logFlow(strTask, "file exists fine. returning")
If bolHardCoded Then
LogAdviceHardCodedFileName(strTask, strParmFN)
End If
LogTaskEnd(strTask)
Return (strNewFileName)
End If
' If it don't exist so far we can try to map it
' The FW is buggy
' If you give it a file that does not exist it will mappath it anyway
Try
strNewFileName = Server.MapPath(strParmFN)
logFlow(strTask, "Mapped Path Ok!")
Catch
logFlow(strTask, "Error when mapping path")
LogError()
LogTaskEnd(strTask)
Return (strParmFN)
End Try
' If it got this far it mapped the path fine
If File.Exists(strNewFileName) Then
Return (strNewFileName)
LogTaskEnd(strTask)
Else
LogError()
LogHint(strCallerName, "File Does Not Exist: " & strParmFN)
LogTaskEnd(strTask)
Return (strParmFN)
End If
End Function
Sub FileRead(ByVal strParmFileName As String, ByRef strParm As String)
Dim strTask As String = "sub FileRead"
Dim sr1 As StreamReader
Try
LogTaskStart(strTask)
sr1 = StreamOpen(strParmFileName, strTask)
strParm = sr1.ReadToEnd()
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Release(sr1)
Finally
Release(sr1)
End Try
End Sub
Function FileRead(ByVal strParmFileName As String) As String
Dim strTemp As String
FileRead(strParmFileName, strTemp)
Return strTemp
End Function
Sub FileRead(ByVal strParmFileName As String, ByRef arryLines As Object)
Dim strTask As String = "sub FileToArray"
Dim sr1 As StreamReader
Dim strLineCurrent As String
Dim intCounter As Integer
Dim theArray(1000) As String
Try
LogTaskStart(strTask)
sr1 = StreamOpen(strParmFileName, strTask)
strLineCurrent = sr1.ReadLine()
Do Until strLineCurrent Is Nothing
intCounter += 1
' LogDebugData(strTask,"strLineCurrent=" & strLineCurrent)
Try
theArray(intCounter - 1) = strLineCurrent
strLineCurrent = sr1.ReadLine()
Catch ex1 As Exception
Dim intMaxArrayHeight As Integer = theArray.GetUpperBound(0)
ReDim Preserve theArray(intMaxArrayHeight + 1000)
End Try
Loop
' LogDebugData(strTask,"intCounter=" & intCounter)
ReDim Preserve theArray(intCounter)
arryLines = theArray
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Release(sr1)
Finally
End Try
End Sub
Sub FileWrite(ByVal strParmFileName As String, ByVal strParm As String)
Dim strTask As String = "sub FileWrite"
Dim fs As FileStream
Dim tw As StreamWriter
Try
LogTaskStart(strTask)
fs = StreamFileCreate(strParmFileName, strTask)
ObjectCreateTrack(strTask,fs)
tw = New StreamWriter(fs)
ObjectCreateTrack(strTask,tw)
tw.Write(strParm)
tw.Flush()
LogTaskEnd(strTask)
Catch exc1 As Exception
LogException(strTask, exc1)
Finally
Release(tw)
Release(fs)
End Try
End Sub
Sub FileWrite(ByVal strParmFileName As String, ByVal arrayParm As String())
Dim strTask As String = "sub FileWrite"
Dim fs As FileStream
Dim tw As StreamWriter
Dim intarraycounter As Integer
Try
LogTaskStart(strTask)
fs = StreamFileCreate(strParmFileName, strTask)
ObjectCreateTrack(strTask,fs)
tw = New StreamWriter(fs)
ObjectCreateTrack(strTask,tw)
For intarraycounter = 0 To arrayParm.GetUpperBound(0)
tw.WriteLine(arrayParm(intarraycounter))
Next
tw.Flush()
LogTaskEnd(strTask)
Catch exc1 As Exception
LogException(strTask, exc1)
Finally
Release(tw)
Release(fs)
End Try
End Sub
Protected Sub Gridformat(ByVal objGrid As Object, ByVal htGridOptions As Hashtable)
Dim strTask As String = "SUB GridFormat"
LogTaskStart(strTask)
Dim strTypeName As String = TypeName(objGrid).ToLower()
Select Case strTypeName
Case "datagrid","table"
Dim datagrid1 As New DataGrid
ObjectCreateTrack(strTask,datagrid1)
Dim table1 As New Table
ObjectCreateTrack(strTask,table1)
With datagrid1
.HeaderStyle.BackColor = ColorTranslator.FromHtml("#aaaadd")
.BorderWidth = Unit.Pixel(1)
.GridLines = System.Web.UI.WebControls.GridLines.Both
.BorderStyle = System.Web.UI.WebControls.BorderStyle.Solid
.Width = Unit.Percentage(100)
If htGridOptions("name") = "Errors" Then
.Font.Size = System.Web.UI.WebControls.FontUnit.XXSmall
End If
End With
With table1
.BorderWidth = Unit.Pixel(1)
.GridLines = System.Web.UI.WebControls.GridLines.Both
.BorderStyle = System.Web.UI.WebControls.BorderStyle.Solid
.Width = Unit.Percentage(100)
End With
If strTypeName = "datagrid" Then
objGrid = datagrid1
Else
objGrid = table1
End If
Case Else
LogAdvice(strTask, "GridFormat Unknown object=" & strTypeName)
End Select
LogTaskEnd(strTask)
End Sub
Function HTTPGrab(ByVal strURL As String)
Dim strTask As String = "HTTPGrab"
LogTaskStart(strTask)
If bolCache_ Then
LogTaskEnd(strTask)
Return (HTTPGrabCached(strURL))
Else
LogTaskEnd(strTask)
Return (HTTPGrabCachedNot(strURL))
End If
End Function
Private Function HTTPGrabCached(ByVal strURL As String)
Dim strTask As String = "HTTPGrabCached"
Try
LogTaskStart(strTask)
Dim strResult As String
Dim strChksum As String
strChksum = ConvertStr2MD5checksum("httpgrab:" & strURL)
If System.Web.HttpContext.Current.Cache(strChksum) Is Nothing Then
LogCache(strTask, "Cache Miss. Adding To HTTP Cache.")
strResult = HTTPGrabCachedNot(strURL)
System.Web.HttpContext.Current.Cache.Insert(strChksum, strResult, Nothing, DateTime.Now.AddMinutes(intCacheMinutes_), System.Web.HttpContext.Current.Cache.NoSlidingExpiration)
ObjectCreateTrack(strTask,Cache(strChksum))
Else
LogCache(strTask, "Cache Hit. Using from HTTP Cache.")
strResult = System.Web.HttpContext.Current.Cache(strChksum)
End If
LogTaskEnd(strTask)
Return strResult
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Private Function HTTPGrabCachedNot(ByVal strURL As String)
Dim strTask As String = "HTTPGrabCachedNot"
Dim webResponse1 As WebResponse
Dim webRequest1 As WebRequest
Dim sr1 As StreamReader
Dim strResult As String
Try
LogTaskStart(strTask)
webRequest1 = webRequest1.Create(strURL)
ObjectCreateTrack(strTask,webrequest1)
webResponse1 = webRequest1.GetResponse()
ObjectCreateTrack(strTask,webResponse1)
sr1 = New StreamReader(webResponse1.GetResponseStream())
ObjectCreateTrack(strTask,sr1)
strResult = sr1.ReadToEnd()
LogTaskEnd(strTask)
Return strResult
Catch ex1 As Exception
LogException(strTask & "=> " & strURL, ex1)
Finally
Release(sr1)
End Try
End Function
Function HttpPost(ByVal strURL As String, ByVal hashUrlParms As Hashtable) As String
'-- Added by Gary Pupurs, 23Mar03
Dim strTask As String = "HttpPost"
Dim webResponse1 As WebResponse
Dim webRequest1 As WebRequest
Dim sr1 As StreamReader
Dim strResult As String
Dim streamRequest As Stream
Dim bytesPayload As Byte()
Dim strUrlEncodedPayload As String
Try
LogTaskStart(strTask)
Dim d As DictionaryEntry
Dim sb1 As New StringBuilder
For Each d In hashUrlParms
sb1.Append(d.Key)
sb1.Append("=")
sb1.Append(Server.UrlEncode(d.Value))
sb1.Append("&")
Next d
strUrlEncodedPayload = sb1.ToString()
webRequest1 = webRequest1.Create(strURL)
ObjectCreateTrack(strTask,webRequest1)
webRequest1.Method = "POST"
webRequest1.ContentType = "application/x-www-form-urlencoded"
bytesPayload = System.Text.Encoding.ASCII.GetBytes(strUrlEncodedPayload)
webRequest1.ContentLength = bytesPayload.Length
streamRequest = webRequest1.GetRequestStream()
ObjectCreateTrack(strTask,streamRequest)
streamRequest.Write(bytesPayload, 0, bytesPayload.Length)
streamRequest.Close() ' Use UB.ReleaseStream() when created
webResponse1 = webRequest1.GetResponse()
ObjectCreateTrack(strTask,WebResponse1)
sr1 = New StreamReader(webResponse1.GetResponseStream())
ObjectCreateTrack(strTask,sr1)
strResult = sr1.ReadToEnd()
LogTaskEnd(strTask)
Return strResult
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(sr1)
End Try
End Function
Private Function IsCached(ByVal key As String) As Boolean
Dim strTask As String = "iscached"
LogTaskStart(strTask)
Dim strChksum As String = ConvertStr2MD5checksum(key)
If System.Web.HttpContext.Current.Cache(strChksum) Is Nothing Then
LogTaskEnd(strTask)
Return False
Else
LogTaskEnd(strTask)
Return True
End If
End Function
Private Sub logActivity(ByVal strLogType As String, ByVal strParmCaller As String, _
ByVal objValue As Object, ByVal strObjName As String)
' Xray(objvalue,strObjName)
Dim strTypeName As String = TypeName(objValue).ToLower()
Dim sbVar As New StringBuilder
If strTypeName = "string" Then
With sbVar
.Append(strObjName)
.Append("=")
.Append(objValue)
End With
Else
With sbVar
.Append("name=")
.Append(strObjName)
.Append("<br>")
.Append(System.Environment.NewLine)
.Append("typename=")
.Append(TypeName(objValue))
Select Case strTypeName
Case "nothing"
' nothing to do
Case "datatable"
Dim dtTemp As DataTable
dtTemp = objValue
.Append("<br>Row Count=")
.Append(dtTemp.Rows.Count)
Case "string()"
.Append("<br>ubound=")
.Append(objValue.GetupperBound(0))
Case "string(,)"
.Append("<br>ubound(0)=")
.Append(objValue.GetupperBound(0))
.Append("<br>ubound(1)=")
.Append(objValue.GetupperBound(1))
Case Else
.Append("<br>value=")
.Append(objValue.ToString())
End Select
If TypeOf (objValue) Is Control Then
.Append("<br>id=")
.Append(objValue.id)
End If
End With
End If
logActivity(strLogType, strParmCaller, sbVar.ToString())
End Sub
Sub log(ByVal strParmCaller As String, ByVal strDesc As String)
logActivity(strParmCaller, "application", strDesc)
End Sub
Private Sub logActivity(ByVal strLogType As String, ByVal strParmCaller As String, _
ByVal strParmDetails As String)
Dim strTask as string="logActivity"
' todo - This function is taking parameters in wrong order
' This function allows us to control what gets inserted into Trace stream
' it has the parameter LogType to subdivide the nature of trace entries
' Clean Up SUB and FUNCTION text that comes in
strParmCaller = strParmCaller.Replace("function", "")
strParmCaller = strParmCaller.Replace("sub ", "")
strParmCaller = strParmCaller.Replace("SUB ", "")
' todo Now If option is set insert in normal trace stream
Dim strDetails As String = strParmDetails
Try
Dim strPrefix, strSuffix As String
Select Case strLogType.ToLower()
Case "ubflow:start"
strPrefix = "<Font size='+1' color='green'><b>"
strSuffix = "<b></font>"
Case "ubflow:end"
strPrefix = "<Font size='+1' color='blue'><b>"
strSuffix = "<b></font>"
Case "xray"
' strDetails="name=" & strLogType & "<br>" & strDetails
' strParmCaller=""
Case Else
' Nothing To Do
End Select
Select Case strParmCaller.ToLower()
Case "xray" ' These will go away when Log routines are cleaned up
strParmCaller = ""
strDetails = "name=" & strLogType & "<br>" & strDetails
strLogType = "xray"
Case Else
' Nothing To Do
End Select
If bolSuperTraceToTraceStream_ Then
Trace.Write(strParmCaller, strDetails)
End If
strLogType = strPrefix & strLogType & strSuffix
strParmCaller = strPrefix & strParmCaller & strSuffix
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("SuperTrace").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strParmCaller ' EventCaller
dtblrowTemp(2) = strLogType ' EventCategory
dtblrowTemp(3) = strDetails ' EventDescription
dtblrowTemp(4) = QueryPerformanceCounter()/QueryPerformanceFrequency() ' DateTime.Now.Ticks 'System.Environment.TickCount ' EventTickcount
dsXray.Tables(0).Rows.Add(dtblrowTemp)
Catch exc1 As Exception
LogException(strTask, exc1)
End Try
End Sub
Private Sub LogAdvice(ByVal strParmCaller As String, ByVal strAdvice As String)
Dim strTask As String = "SUB logAdvice"
Try
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("Advice").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strParmCaller
dtblrowTemp(2) = strAdvice
LogActivity(strParmCaller,"strAdvice",strAdvice)
dsXray.Tables("Advice").Rows.Add(dtblrowTemp)
Catch exc1 As Exception
LogException(strTask, exc1)
End Try
End Sub
Private Sub LogAdviceAdHocSQL(ByVal strParmCaller As String, ByVal strSQL As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("Ad-Hoc SQL was used. We recommend using Stored Procs instead*")
.Append("<br><font color='blue'>SQL=" & strSQL & "</font>")
.Append("<br>* the equivalent in Oracle is a Package.")
.Append("<br> the equivalent in Access is a parameterized query.")
End With
LogAdvice(strParmCaller, sbAdvice.ToString())
End Sub
private Sub LogAdviceConfigUnknownElement(ByVal strParmCaller As String, _
ByVal strElementName As String, ByVal strElementValue As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("A Unknown Element encountered in UtilityBelt.config")
.Append("<br><font color='blue'><")
.Append(strElementName)
.Append(">")
.Append(strElementValue)
.Append("</")
.Append(strElementName)
.Append(">")
.Append("</font>")
End With
LogAdvice(strParmCaller, sbAdvice.ToString())
End Sub
private Sub LogAdviceHardCodedConnectString(ByVal strParmCaller As String, ByVal strConn As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("A Hard-Coded Connection string was used")
.Append("<br><font color='blue'>strConn=" & strConn & "</font>")
.Append("<br>A key in web.config should be used instead!")
End With
LogAdvice(strParmCaller, sbAdvice.ToString())
End Sub
private Sub LogAdviceHardCodedFileName(ByVal strParmCaller As String, ByVal strParmFN As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("<b>Hardcoded Filename => " & strParmFN & "</b>")
.Append("<br>We recommend using virtual paths in case you move site to different Webserver.")
End With
LogAdvice(strParmCaller, sbAdvice.ToString())
End Sub
private Sub LogHintSprocMissingParameter(ByVal strParmCaller As String, ByVal strParameterName As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("Stored Procedure Parameter Not Supplied =><br><b>" & strParameterName & "</b>")
'.Append("<br>add the following to your code ...")
End With
LogHint(strParmCaller, sbAdvice.ToString())
End Sub
private sub LogHintSprocWrongParameterName(ByVal strParmCaller As String, ByVal strParameterName As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("<b>Stored Procedure Incorrect Parameter Name => " & strParameterName & "</b>")
End With
LogHint(strParmCaller, sbAdvice.ToString())
end sub
private Sub LogAdviceUtilityBeltConfigNotFound(ByVal strCaller As String, ByVal strFileName As String)
Dim sbAdvice As New StringBuilder
With sbAdvice
.Append("utilitybelt.config File not found<br><b>" & strFileName & "</b>")
.Append("<br>The designers highly recommend a config file to specify setup of email<br>and/or setup log of all runtime errors")
.Append("<br>READ MORE: <a href='http://www.learnasp.com/freebook/learn/utilitybelt_config.aspx'>http://www.learnasp.com/freebook/learn/utilitybelt_config.aspx</a>")
End With
LogAdvice(strCaller, sbAdvice.ToString())
End Sub
Private Sub LogCache(ByVal strParmTaskName As String, ByVal strDesc As String)
logActivity("cache", strParmTaskName, strDesc)
End Sub
Private Sub LogDebugData(ByVal strParmTaskName As String, ByVal strDebugData As String)
logActivity("dbg", strParmTaskName, strDebugData)
End Sub
Private Sub LogError()
Dim strTask As String = "SUB LogError()"
LogTaskStart(strTask)
errorCount_ += 1
' Xray(errorcount_,"ErrorCount_")
errorOccured_ = True
errorCountGlobal_ += 1
errorOccuredGlobal_ = True
LogTaskEnd(strTask)
End Sub
Sub LogException(ByVal srv1 As System.Web.HttpServerUtility)
' Designed to be called from Page_Error
LogException("Exception that was not caught", srv1.GetLastError())
With System.Web.HttpContext.Current.Response
'.write(typename(srv1))
.Write(strErrMessage_)
'.write(srv1.GetLastError().ToString())
.Write(XrayDataSetForDisplay())
End With
srv1.ClearError()
End Sub
Sub LogException(ByVal strCallerNameParm As String, ByVal excParm2 As Object)
Dim strTask As String = "SUB LogException"
' RESEARCH 'Throw' operand must derive from 'System.Exception'
' IF bolErrThrowBack_
' Throw
' END IF
static intExceptionsInnerCount as integer
static strExceptionInnerName as string
'Trace.Warn(strCallerNameParm,"LogException",excParm2)
Try
LogTaskStart(strTask)
Dim strExc As String = excParm2.ToString()
Dim strExceptionType = TypeName(excParm2)
Dim strExcMessage As String = excParm2.Message()
If excParm2.InnerException IS nothing
Else
intExceptionsInnerCount+=1
If intExceptionsInnerCount=1
strExceptionInnerName=strCallerNameParm
END IF
LogException(strExceptionInnerName & "InnerException #" & intExceptionsInnerCount ,excParm2.InnerException)
End If
' Opening Streams the File can be locked by another process
If strExceptionType = "IOException" Then
Trace.Warn("strExcMessage.IndexOf()", strExcMessage.IndexOf("The process cannot access the file"))
If strExcMessage.IndexOf("The process cannot access the file") > -1 Then
logWarning(strCallerNameParm, "File Locked!")
End If
End If
' Actual NULL error can be TargetInvocationException in nested controls
If strExc.IndexOf("Cast from type 'DBNull' to type 'String' is not valid") > -1 Then
If bolErrNullNestedIgnore_ = True Then
logWarning(strCallerNameParm, "WARNING: Null encountered in nested filled object, but DBOption NullBindIgnoreOn allows it")
'trace.warn(p1, "WARNING: Null encountered in nested filled object, but DBOption NullBindIgnoreOn allows it",excParm1)
Else
LogHint(strCallerNameParm, "Null encountered in nested filled object. Getting rid of null results in database query or Option <b><font color='red'>nullbind-ignore-on</font></b> will eliminate this error")
End If
' Exit Sub
End If
LogError()
If bolErrIgnoreNext_ Then
Trace.Warn("bolErrIgnoreNext_=true", "", excParm2)
Options("Error-IgnoreNext-Off")
LogTaskEnd(strTask)
Exit Sub
End If
' Now Email Error and Add to tblErrors
IF bolEmailIsWorking_
MailError(strCallerNameParm, excParm2, "obsolete")
END IF
Dim tbl1 As New Table
Dim cl1 As TableCell
Dim rw1 As TableRow
Try
Dim dtblrowTemp As DataRow
'trace.warn("dsXray.Tables(0)",typename(dsXray.Tables(0)))
dtblrowTemp = dsXray.Tables("Errors").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strCallerNameParm
dtblrowTemp(2) = TypeName(excParm2)
dtblrowTemp(3) = excParm2.Helplink()
dtblrowTemp(4) = excParm2.Message()
dtblrowTemp(5) = excParm2.StackTrace()
dtblrowTemp(6) = excParm2.TargetSite()
dsXray.Tables("Errors").Rows.Add(dtblrowTemp)
Catch exc1 As Exception
logException(strTask, exc1)
End Try
LogTaskEnd(strTask)
Catch exc1 As Exception
logException(strTask, exc1)
End Try
End Sub
Private Sub LogHint(ByVal strParmTaskName As String, ByVal strErrorDesc As String, _
ByVal objParmValue As Object, ByVal strParmObjName As String)
LogHint(strParmTaskName, strErrorDesc)
End Sub
Private Sub LogHint(ByVal strParmCaller As String, ByVal strErrorDesc As String)
Dim strTask As String = "sub LogHint"
Try
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("Hints").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strParmCaller
dtblrowTemp(2) = strErrorDesc
dsXray.Tables("Hints").Rows.Add(dtblrowTemp)
Catch exc1 As Exception
logException(strTask, exc1)
End Try
End Sub
Private Sub logFlow(ByVal strParmTaskName As String, ByVal strDesc As String)
logActivity("ubflow", UBIndent(1) & strParmTaskName, strDesc)
End Sub
Private Sub LogMessages(ByVal strParmCaller As String, ByVal strType As String, ByVal strMessage As String)
Dim strTask As String = "SUB logMessages"
Try
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("Messages").NewRow() ' used to be TblMessages
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strParmCaller
dtblrowTemp(2) = strType
dtblrowTemp(3) = strMessage
dsXray.Tables("Messages").Rows.Add(dtblrowTemp)
Catch exc1 As Exception
logException(strTask, exc1)
End Try
End Sub
Private Sub logParm(ByVal strParmTaskName As String, ByVal objParmValue As Object, ByVal strParmName As String)
logActivity("parm", UBIndent(1) & strParmTaskName, objParmValue, strParmName)
End Sub
Private Sub logSQLReturn(ByVal strParmTaskName As String, ByVal objParmValue As Object, ByVal strParmName As String)
logActivity("SQLReturn", strParmTaskName, objParmValue, strParmName)
End Sub
private sub LogSuperTraceSummary(byVal paramHashTable as hashtable)
' dtSuperTraceSummary fields
' Item,ItemCount,ItemType,ItemDescription,ItemElapsedPretty,
' ItemElapsed,ItemCheckSum
Dim strTask As String = "sub LogSuperTraceSummary"
Try
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("SuperTraceSummary").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = LogHashTableKey2DbNull(paramHashTable,"Item")
dtblrowTemp(2) = LogHashTableKey2DbNull(paramHashTable,"ItemCount")
dtblrowTemp(3) = LogHashTableKey2DbNull(paramHashTable,"ItemType")
dtblrowTemp(4) = LogHashTableKey2DbNull(paramHashTable,"Caller")
dtblrowTemp(5) = LogHashTableKey2DbNull(paramHashTable,"ItemDescription")
dtblrowTemp(6) = LogHashTableKey2DbNull(paramHashTable,"ItemElapsedPretty")
dtblrowTemp(7) = LogHashTableKey2DbNull(paramHashTable,"ItemElapsed")
dtblrowTemp(8) = LogHashTableKey2DbNull(paramHashTable,"ItemCheckSum")
dsXray.Tables("SuperTraceSummary").Rows.Add(dtblrowTemp)
Catch exc1 As Exception
LogException(strTask, exc1)
End Try
end sub
function LogHashTableKey2DbNull(htParam as hashtable, objParamKey as object) as object
If htParam.Contains(objParamKey)
return(htParam(objParamKey))
Else
return(DbNull.Value)
' todo needs to be system.dbnull but that returns
' dbnull' is a type in 'System' and cannot be used as an expression.
end if
end function
Private Sub logTask(ByVal strParmTaskName As String, ByVal strDesc As String)
logActivity("info", UBIndent(1) & strParmTaskName, strDesc)
End Sub
Private Sub LogTaskStart(ByVal strParmTaskName As String)
'Because the Context.Handler is only assigned on the
'PreRequestHandlerExecute and this class can created sooner
'We the to check the page until it is assigned
CheckPage()
'If strSimpleTrace_.IndexOf(strParmTaskName)=-1
strSimpleTrace_ &= strParmTaskName & system.environment.newline()
'end if
dim htSuperTrace as new HashTable()
with htSuperTrace
.add("Item",strParmTaskName)
.add("ItemType","start")
.add("ItemCount",1)
end with
Call LogSuperTraceSummary(htSuperTrace)
logActivity("ubflow:start", strParmTaskName, "")
End Sub
Private Sub LogTaskEnd(ByVal strParmTaskName As String)
logActivity("ubflow:end", strParmTaskName, "")
End Sub
Private Sub LogTaskEndFinally(ByVal strParmTaskName As String)
logFlow(strParmTaskName, "end finally")
End Sub
Private sub LogTaskEndPremature(ByVal strParmTaskName As String, ByVal strExplanation As String)
logFlow(strParmTaskName, strExplanation)
End sub
Private Sub LogTaskParms(ByVal ParamArray objParms As Object())
Dim parmCount as integer=Ubound(objParms)
dim counter as integer
Dim strTask as string=objParms(0)
If (ParmCount) MOD 2 = 0
' all is well
Else
LogHint(strTask, "Incorrect Number of Parameters to LogTaskParms")
End If
For counter = 1 to ParmCount step 2
' LogParm(strTask,objParms(counter+1),objParms(counter))
XrayObject(strTask,"ubflow:LogTaskParms",objParms(counter),objParms(counter+1))
'Xray(objParms(counter+1),objParms(counter))
next
end Sub
Private function LogReturn(ByVal strParmTaskName As String,objParm as object) as object
XrayObject(strParmTaskName,"ubflow:LogReturn","objParm",objParm)
Return(objParm)
End function
Private Sub LogTaskSQL(ByVal strParmTaskName As String, ByVal strParmSQL As String)
logActivity("sql", strParmTaskName, strParmSQL)
End Sub
Private Sub logWarning(ByVal strParmTaskName As String, ByVal strWarning As String)
Dim strtask As String = "LogWarning"
LogTaskStart(strTask)
Try
intHintNumber = 1 ' unknown error
If strWarning.IndexOf("File Locked") > -1 Then
intHintNumber = 2
End If
Dim dtblrowTemp As DataRow
dtblrowTemp = dsXray.Tables("Hints").NewRow()
' dont worry about col(0) - auto-incremented
dtblrowTemp(1) = strParmTaskName
dtblrowTemp(2) = intHintNumber
dtblrowTemp(3) = strWarning
dsXray.Tables("Hints").Rows.Add(dtblrowTemp)
LogTaskEnd(strTask)
Catch exc1 As Exception
Logexception(strTask, exc1)
End Try
End Sub
Private Function LogXray(ByVal objparm As Object, ByVal strParmName As String) As String
If bolLogSensitive_ = False Then
Return ("-sensitive debug data not supplied for security reasons-")
End If
Dim strTempReturn As String
Dim strDebugTypeName As String
strDebugTypeName = TypeName(objparm)
Return ("varname=" & strParmName & "; typename=" & strDebugTypeName & ";value=" & objparm.ToString())
End Function
Sub MailError(ByVal p1 As String, ByVal excParm2 As Object, ByVal strParm3 As String)
Dim strTask As String = "SUB MailError"
Try
LogTaskStart(strTask)
logParm(strTask, p1, "p1")
logParm(strTask, excParm2, "excParm2")
logParm(strTask, strParm3, "strParm3")
If TypeName(strMailErrorsTo_) = "Nothing" Then
LogTaskEnd(strTask)
Exit Sub
End If
If strMailErrorsTo_.Length() = 0 Then
LogTaskEnd(strTask)
Exit Sub
End If
Dim strScriptName As String
strScriptName = System.Web.HttpContext.Current.Request.RawUrl()
Dim ht1 As New Hashtable
ht1.Add("from", strScriptName)
ht1.Add("to", strMailErrorsTo_)
ht1.Add("subject", "UBError! " & strScriptName)
Dim sb1 As New StringBuilder
With sb1
.Append(p1)
.Append(vbCrLf)
.Append("TypeName=")
.Append(TypeName(excParm2))
.Append(vbCrLf)
If strParm3 <> "" Then
.Append("Additional Details=")
.Append(strParm3)
.Append(vbCrLf)
End If
If TypeName(excParm2) <> "Nothing" Then
.Append("Help Link=")
.Append(excParm2.Helplink())
.Append(vbCrLf)
.Append("Message=")
.Append(excParm2.Message())
.Append(vbCrLf)
.Append("StackTrace=")
.Append(excParm2.StackTrace())
.Append(vbCrLf)
.Append("TargetSite=")
.Append(excParm2.TargetSite.ToString())
.Append(vbCrLf)
.Append("ToString=")
.Append(excParm2.ToString())
.Append(vbCrLf)
End If
End With
ht1.Add("body", sb1.ToString())
logTask("body", sb1.ToString())
MailMsg(ht1)
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub MailMsg(ByRef hashParm1 As Hashtable)
Dim strTask As String = "SUB MailMsg"
Dim objMessage As MailMessage
Try
LogTaskStart(strTask)
hashParm1("errorsending") = False
Dim strParms As String = ";bcc;body;bodyencoding;bodyformat;cc;from;priority;subject;to;urlcontentbase;urlcontentlocation;supressharderror;errorsending;"
Dim d As DictionaryEntry
For Each d In hashParm1
If strParms.IndexOf(";" & d.Key & ";") = -1 Then
LogHint(strTask, "Bad Parameter=" & d.Key)
End If
Next d
' TODO - need to validate the additional parameters for quality of input!
' Valid emails, priority, et al.
objMessage = New MailMessage
With objMessage
'.attachments = hashParm1("attachments")
.Bcc = hashParm1("bcc")
.Body = hashParm1("body")
.BodyEncoding = hashParm1("bodyencoding")
.BodyFormat = hashParm1("bodyformat")
.Cc = hashParm1("cc")
.From = hashParm1("from")
'.headers = hashParm1("headers")
.Priority = hashParm1("priority")
.Subject = hashParm1("subject")
.To = hashParm1("to")
.UrlContentBase = hashParm1("urlcontentbase")
.UrlContentLocation = hashParm1("urlcontentlocation")
End With
SmtpMail.SmtpServer = strMailSmtpServer
SmtpMail.Send(objMessage)
LogTaskEnd(strTask)
Catch ex1 As Exception
If hashParm1("supressharderror") = True Then
hashParm1("errorsending") = True
LogHint(strTask, "Mail Could not be sent.<br>Maybe bad SmtpServer (setting=" & SmtpMail.SmtpServer & ")<br>Error => " & ex1.Message)
Else
LogException(strTask, ex1)
End If
Finally
End Try
End Sub
Function MailMsgTest(ByVal strFrom As String, ByVal strTo As String) As Boolean
Dim strTask As String = "SUB MailMsgTest"
Try
LogTaskStart(strTask)
Dim hashParm1 As New Hashtable
hashParm1("to") = strTo
hashParm1("from") = strTo
hashParm1("subject") = "Test Mail - Utility Belt"
hashParm1("supressharderror") = True
MailMsgTest(hashParm1)
LogTaskEnd(strTask)
bolEmailIsWorking_= Not hashParm1("errorsending")
Return (Not hashParm1("errorsending"))
Catch ex1 As Exception
LogHint(strTask, "Test Mail Could not be sent Error => " & ex1.Message)
Finally
End Try
End Function
Function MailMsgTest(ByVal hashParm1 As Hashtable) As Boolean
Dim strTask As String = "SUB MailMsgTest"
Dim bolMailSent As Boolean = False
Try
hashParm1("supressharderror") = True
MailMsg(hashParm1)
bolMailSent = Not hashParm1("errorsending")
Catch ex1 As Exception
' todo this used to be LogError
LogHint(strTask,"Test Mail Could not be sent Error => " & ex1.message)
Finally
End Try
Return (bolMailSent)
End Function
Function NullTest(ByVal objParm1 As Object) As Boolean
If objParm1 = objNull_ Then
Return (True)
End If
Return (False)
End Function
sub ObjectCreateTrack(strTaskName as string,parmObj as object)
dim htSuperTrace as new HashTable()
with htSuperTrace
.add("Item",parmObj.GetType.ToString())
.add("ItemType","create")
.add("ItemCount",1)
.add("Caller",strTaskName)
end with
Call LogSuperTraceSummary(htSuperTrace)
end sub
Sub Options(ByVal strOptions As String)
Dim strTask As String = "SUB Options"
Try
LogTaskStart(strTask)
strOptions = strOptions.ToLower()
' Ditch spaces, allow =on and =off as synonyms for -on and -off
strOptions = strOptions.Replace(" ", "")
strOptions = strOptions.Replace("=on", "-on")
strOptions = strOptions.Replace("=off", "-off")
strOptions = strOptions.Replace("debug-on", "errors-on,hints-on,messages-on")
Dim arryOptions As String()
arryOptions = strOptions.Split(",")
Dim intOptionsMaxCount As Integer = arryOptions.GetUpperBound(0)
Dim strOptionCurrent As String
Dim strOptionCurrentOriginal As String
Dim intOptionCurrent As Integer
For intOptionCurrent = 0 To intOptionsMaxCount
strOptionCurrentOriginal = arryOptions(intOptionCurrent)
strOptionCurrent = strOptionCurrentOriginal.ToLower()
Dim bolLegitOption as boolean=true
Select Case strOptionCurrent
Case "advice-on"
BolAdvice_ = True
Case "advice-off"
BolAdvice_ = False
Case "cache-on"
bolCache_ = True
Case "cache-off"
bolCache_ = False
Case "db-force-sqlserver"
Trace.Warn("option " & strOptionCurrent, "Not Implemented Yet")
Case "db-force-oledb"
Trace.Warn("option " & strOptionCurrent, "Not Implemented Yet")
Case "errors-on"
bolErrorDetails_ = True
Case "errors-off"
bolErrorDetails_ = False
Case "error-ignorenext-on"
bolErrIgnoreNext_ = True
Case "error-ignorenext-off"
bolErrIgnoreNext_ = False
Case "error-throwback-on"
bolErrThrowBack_ = True
Case "error-throwback-off"
bolErrThrowBack_ = False
Case "hints-on"
BolHints_ = True
Case "hints-off"
BolHints_ = False
Case "htmlencode-on"
bolHTMLencode_ = True
Case "htmlencode-off"
bolHTMLencode_ = False
Case "messages-on"
bolMessages_ = True
Case "messages-off"
bolMessages_ = False
Case "nullbind-ignore-on"
bolErrNullNestedIgnore_ = True
Case "nullbind-ignore-off"
bolErrNullNestedIgnore_ = False
Case "simpletrace-on"
bolSimpleTrace_ = True
Case "simpletrace-off"
bolSimpleTrace_ = False
Case "supertrace-on"
bolSuperTrace_ = True
Case "supertrace-off"
bolSuperTrace_ = False
Case "supertrace-to-trace-on"
bolSuperTraceToTraceStream_ = True
Case "supertrace-to-trace-off"
bolSuperTraceToTraceStream_ = False
Case "trace-on"
Trace.IsEnabled = True
Trace.TraceMode = Trace.TraceMode.SortByTime
Case "trace-off"
Trace.IsEnabled = False
Case "xray-on"
bolXrayOn_ = True
Case "xray-off"
bolXrayOn_ = False
Case "xray-to-page-on"
bolXrayToPage_ = True
Case "xray-to-page-off"
bolXrayToPage_ = False
Case Else
bolLegitOption=false
LogAdvice(strTask, "Option Unknown =>" & strOptionCurrentOriginal)
LogFlow(strTask, "Option Unknown =>" & strOptionCurrentOriginal)
End Select
IF bolLegitOption
logFlow(strTask, "Applied OPTION =>" & strOptionCurrent)
END IF
Next
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Function PayPalLink(ByRef hashParm1 As Hashtable) As String
Dim strTask As String = "SUB PayPalLink"
Dim strPaypalLink As String
Try
LogTaskStart(strTask)
Dim strParms As String = ";account;itemdesc;itemnumber;itemamount;"
Dim d As DictionaryEntry
For Each d In hashParm1
If strParms.IndexOf(";" & d.Key & ";") = -1 Then
LogHint(strTask, "Bad Parameter=" & d.Key)
End If
Next d
strPaypalLink &= "<form action='https://www.paypal.com/cgi-bin/webscr' method='post'>"
strPaypalLink &= "<input type='hidden' name='cmd' value='_xclick'>"
strPaypalLink &= "<input type='hidden' name='business' value='" & hashParm1("account") & "'>"
strPaypalLink &= "<input type='hidden' name='item_name' value='" & hashParm1("itemdesc") & "'>"
strPaypalLink &= "<input type='hidden' name='item_number' value=" & hashParm1("itemnumber") & "'>"
strPaypalLink &= "<input type='hidden' name='amount' value='" & hashParm1("itemamount") & "'>"
strPaypalLink &= "<input type='hidden' name='no_note' value='1'>"
strPaypalLink &= "<input type='hidden' name='currency_code' value='USD'>"
strPaypalLink &= hashParm1("itemdesc") & " (#" & hashParm1("itemnumber") & ") price=$" & hashParm1("itemamount") & "<br>"
strPaypalLink &= "<input type='image' src='https://www.paypal.com/images/x-click-but23.gif' border='0' name='submit' alt='Make payments with PayPal - it's fast, free and secure!'>"
strPaypalLink &= "</form>"
Return (strPaypalLink)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
<System.Runtime.InteropServices.DllImport("Kernel32.dll")> _
Public Shared Function QueryPerformanceCounter(ByRef perfcount As Int64) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("Kernel32.dll")> _
Public Shared Function QueryPerformanceFrequency(ByRef freq As Int64) As Boolean
End Function
Public Shared Function QueryPerformanceCounter() As Int64
Dim perfcount As Int64
QueryPerformanceCounter(perfcount)
Return perfcount
End Function
Public Shared Function QueryPerformanceFrequency() As Int64
Dim freq As Int64
QueryPerformanceFrequency(freq)
Return freq
End Function
Function RegExPatternGrab(ByVal strNickName As String) As String
Select Case strNickName.ToLower()
Case "email"
Return ("^\w+@[a-zA-Z_]+?\.[a-zA-Z]{2,3}$")
Case Else
Return (strNickName)
End Select
End Function
Function RegExMatch(ByVal strCheckThis As String, ByVal strRegExp As String) As Boolean
Dim strExp As String
strExp = RegExPatternGrab(strRegExp)
If Regex.IsMatch(strCheckThis, strExp) Then
Return True
Else
Return False
End If
End Function
Sub Release(ByVal Parm1 As Object)
Dim strtask As String = "Release"
Dim strTypeName As String = TypeName(Parm1).ToLower()
LogTaskStart(strTask & ":" & strTypeName)
logTaskParms(strtask,"Parm1", Parm1)
TRY
'Dim strTypeName As String = Parm1.ToString().ToLower()
'logWarning(strtask, "object typename =><b>" & strTypeName & "</b>")
If strTypeName="nothing"
exit sub
END IF
Select Case strTypeName
Case "filestream", "streamwriter", "streamreader", _
"system.io.streamreader", "system.xml.xmlreader"
Parm1.Close()
'Parm1.Dispose()
Case "system.xml.xmltextreader","xmltextreader","xmltextwriter"
IF strTypeName="xmltextwriter"
Parm1.flush()
END IF
Parm1.Close()
Case "system.data.sqlcommand"
' Paul Brophy wrote this
Parm1.Dispose()
If Not (Parm1.Connection Is Nothing) Then
If Parm1.Connection.State = System.Data.ConnectionState.Open Then
Parm1.Connection.Close()
End If
Parm1.Connection.Dispose()
Parm1.Dispose()
End If
Case "system.data.sqlclient.sqlconnection", "sqlconnection", "system.data.oledb.oledbconnection", "oledbconnection"
If Parm1.State = System.Data.ConnectionState.Open Then
Parm1.Close()
End If
Case "system.data.sqlclient.sqldatareader","sqldatareader","system.data.oledb.oledbdatareader","oledbdatareader"
intReaderUnClosedCount -= 1
If Parm1.IsClosed = False Then Parm1.Close()
Case "nothing"
' hmmmm......
Case Else
logWarning(strtask, "Release encountered unrecognized object =><b>" & strTypeName & "</b>")
End Select
LogTaskEnd(strtask)
Catch exc1 as exception
LogException(strTask,exc1)
End Try
End Sub
Function ScriptColorCode(ByVal strFileName As String) as string
dim ht1 as new hashtable
return(ScriptColorCode(strFileName,ht1))
end function
Function ScriptColorCode(ByVal strFileName As String, ByVal htParms As Hashtable) As String
Dim strTaskName As String = "ScriptcolorCode"
' Properties
Dim SCC_Format As String = "default"
Dim _Path As String
Dim _TestScript As Boolean = True
Dim _QueryString As String
'REM -- see if we want to hide 'show this code' link
' huh huh ShowTestThisScript.Visible = _TestScript
' cmc
'If request("printstatus")="y" THEN
' SCC_LineNumbers=true
'END IF
REM -- check to see if the file exists
If Not (strFileName Is Nothing) Then
'REM -- initialize the SrcSettings
SCCInitSettings()
strFileName = strFileName.Replace("\\", "\")
Dim FileName As String = System.Web.HttpContext.Current.Server.MapPath(strFileName)
Dim nl As String = System.Environment.NewLine
If (File.Exists(FileName)) Then
Dim fs As New FileStream(FileName, FileMode.Open, FileAccess.Read)
Dim sr As New StreamReader(fs)
Dim textBuffer As New StringWriter
Dim sourceLine As String
If CType(SCC_SrcSettings("DefaultFontSize"), Int32) > 5 Then
textBuffer.Write("<font size=" & SCC_SrcSettings("DefaultFontSize") & "><b>" & nl)
Else
textBuffer.Write("<font size=""" & SCC_SrcSettings("DefaultFontSize") & """>" & nl)
End If
If (FileName.ToLower().EndsWith(".cs")) Then
textBuffer.Write("<pre>" & nl)
sourceLine = sr.ReadLine()
Do While Not (sourceLine Is Nothing)
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixCSLine(sourceLine)) 'REM -- Now the content
textBuffer.Write(nl)
sourceLine = sr.ReadLine()
Loop
textBuffer.Write("</pre>")
ElseIf (FileName.ToLower().EndsWith(".js")) Then
'REM -- we have a JS file
ElseIf (FileName.ToLower().EndsWith(".vb")) Then
'REM -- we have a VB file
textBuffer.Write("<pre>" & nl)
sourceLine = sr.ReadLine()
Do While Not (sourceLine Is Nothing)
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixVBLine(sourceLine)) 'REM -- Now the Content
textBuffer.Write(nl)
sourceLine = sr.ReadLine()
Loop
textBuffer.Write("</pre>")
Else 'REM -- we probably have a .aspx or .ascx, or some other type of ASP.NET webpage
Dim lang As String = "VB"
Dim isInScriptBlock As Boolean = False
Dim isInMultiline As Boolean = False
textBuffer.WriteLine("<PRE>" + nl)
sourceLine = sr.ReadLine()
Do While Not (sourceLine Is Nothing)
lang = SCCGetLangFromLine(sourceLine, lang)
If (SCCIsScriptBlockTagStart(sourceLine)) Then 'REM -- see if we are in a '<script....' tag
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixAspxLine(sourceLine)) 'REM -- now the content
isInScriptBlock = True
ElseIf (SCCIsScriptBlockTagEnd(sourceLine)) Then 'REM -- see if we are in a '</script....' tag
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixAspxLine(sourceLine)) 'REM -- Now the content
isInScriptBlock = False
ElseIf (SCCIsMultiLineTagStart(sourceLine) And Not isInMultiline) Then
isInMultiline = True
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write("<font color=blue><b>" + System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine))
ElseIf (SCCIsMultiLineTagEnd(sourceLine) And isInMultiline) Then
isInMultiline = False
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine) + "</b></font>")
ElseIf (isInMultiline) Then
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine))
Else
If (isInScriptBlock) Then
If (lang.ToLower() = "c#") Then
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixCSLine(sourceLine))
ElseIf (lang.ToLower() = "vb") Then
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixVBLine(sourceLine))
ElseIf (lang.ToLower() = "jscript" Or lang.ToLower() = "javascript") Then
'textBuffer.Write(FixJSLine(sourceLine))
End If
Else
textBuffer.Write(SCCWriteLineNumber()) 'REM -- Line Number
textBuffer.Write(SCCFixAspxLine(sourceLine))
End If
End If
'REM
textBuffer.Write(nl)
sourceLine = sr.ReadLine()
Loop
textBuffer.Write("</pre>")
End If
'write out the code...
ScriptColorCode = textBuffer.ToString()
fs.Close()
Else
'BECAUSE we can't find the file, don't show the link...
' ShowTestThisScript.Visible = False
ScriptColorCode = "<br><font color=red>Utility Belt ScriptColorCode cannot find the file:<br>" & _Path & FileName & "</font>"
End If 'the file exists
End If
End Function
Private Function SCCWriteLineNumber() As String
Dim retVal As String = String.Empty
If SCC_LineNumbers Then
SCC_LineCounter = SCC_LineCounter + 1
retVal = "<font color=""" & SCC_SrcSettings("ColorLineNumber") & """>" & SCC_LineCounter.ToString & ":</font>"
End If
Return retVal
End Function
Private Function SCCFixCSLine(ByVal sourceLine As String) As String
If (sourceLine Is Nothing) Then
Return Nothing
End If
sourceLine = Regex.Replace(sourceLine, "(?i)(" & vbTab & ")", SCC_SrcSettings("TabWhiteSpace"))
sourceLine = System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine)
Dim keywords() As String = {"private", "protected", "public", "namespace", "class", "break", "for", "if", "else", "while", "switch", "case", "using", "return", "null", "void", "int", "bool", "string", "float", "this", "new", "true", "false", "const", "static", "base", "foreach", "in", "try", "catch", "finally", "get", "set", "char", "default"}
Dim CombinedKeywords As String = "(?<keyword>" + String.Join("|", keywords) + ")"
sourceLine = Regex.Replace(sourceLine, "(?i)\b" + CombinedKeywords + "\b(?<!'.*)", "<font color=""" & SCC_SrcSettings("ColorCSKeyword") & """>" & "${keyword}" & "</font>")
sourceLine = Regex.Replace(sourceLine, "(?<comment>'(?![^']*").*$)", "<font color=""" & SCC_SrcSettings("ColorCSComment") & """>" & "${comment}" & "</font>")
Return sourceLine
End Function
Private Function SCCFixVBLine(ByVal sourceLine As String) As String
If (sourceLine Is Nothing) Then
Return Nothing
End If
sourceLine = Regex.Replace(sourceLine, "(?i)(" & vbTab & ")", SCC_SrcSettings("TabWhiteSpace"))
sourceLine = System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine)
Dim keywords() As String = {"Private", "Protected", "Public", "End Namespace", "Namespace", "End Class", "Exit", "Class", "Goto", "Try", "Catch", "End Try", "For", "End If", "If", "Else", "ElseIf", "Next", "While", "And", "Do", "Loop", "Dim", "As", "End Select", "Select", "Case", "Or", "Imports", "Then", "Integer", "Long", "String", "Overloads", "True", "Overrides", "End Property", "End Sub", "End Function", "Sub", "Me", "Function", "End Get", "End Set", "Get", "Friend", "Inherits", "Implements", "Return", "Not", "New", "Shared", "Nothing", "Finally", "False", "Me", "My", "MyBase"}
Dim CombinedKeywords As String = "(?<keyword>" + String.Join("|", keywords) + ")"
sourceLine = Regex.Replace(sourceLine, "(?i)\b" + CombinedKeywords + "\b(?<!'.*)", "<font color=""" & SCC_SrcSettings("ColorVBKeyWord") & """>" & "${keyword}" & "</font>")
sourceLine = Regex.Replace(sourceLine, "(?<comment>'(?![^']*").*$)", "<font color=""" & SCC_SrcSettings("ColorVBComment") & """>" & "${comment}" & "</font>")
Return sourceLine
End Function
Private Function SCCIsMultiLineTagStart(ByVal source As String) As Boolean
Dim searchExpr As String = "(?i)(?!.*>)(?<a></?)(?<b>(asp:|template|property|IBuySpy:).*)"
source = System.Web.HttpContext.Current.Server.HtmlEncode(source)
If (Regex.IsMatch(source, searchExpr)) Then
Return True
Else
Return False
End If
End Function
Private Function SCCIsMultiLineTagEnd(ByVal source As String) As Boolean
Dim searchExpr As String = "(?i)>"
source = System.Web.HttpContext.Current.Server.HtmlEncode(source)
If (Regex.IsMatch(source, searchExpr)) Then
Return True
Else
Return False
End If
End Function
Private Function SCCIsScriptBlockTagEnd(ByVal source As String) As Boolean
If (Regex.IsMatch(source, "</script.*>")) Then
Return True
Else
Return False
End If
End Function
Private Function SCCIsScriptBlockTagStart(ByVal source As String) As Boolean
Dim retVal As Boolean = False
If (Regex.IsMatch(source, "<script.*runat=""?server""?.*>")) Then
retVal = True
End If
If (Regex.IsMatch(source, "(?i)<%@\s*WebService")) Then
retVal = True
End If
Return retVal
End Function
Private Function SCCFixAspxLine(ByVal sourceLine As String) As String
Dim searchExpr As String '// search string
Dim replaceExpr As String '// replace string
If ((sourceLine = Nothing) Or (sourceLine.Length = 0)) Then
Return sourceLine
End If
'// Search for \t and replace it with 4 spaces.
sourceLine = Regex.Replace(sourceLine, "(?i)(" & vbTab & ")", SCC_SrcSettings("TabWhiteSpace"))
sourceLine = System.Web.HttpContext.Current.Server.HtmlEncode(sourceLine)
'// Single line comment or #include references.
searchExpr = "(?i)(?<a>(^.*))(?<b>(<!--))(?<c>(.*))(?<d>(-->))(?<e>(.*))"
replaceExpr = "${a}" & "<font aaaa color=""" & SCC_SrcSettings("ColorComment") & """>" & "${b}${c}${d}" & "</font>" & "${e}"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
Return Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
' // Colorize <%@ <type>
searchExpr = "(?i)" & "(?<a>(<%@))" & "(?<b>(.*))" & "(?<c>(%>))"
replaceExpr = "<font bbb color=""" & SCC_SrcSettings("ColorServerSideTag") & """><b>${a}${b}${c}</b>" & "</font>"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
'// Colorize <%# <type>
searchExpr = "(?i)" & "(?<a>(<%#))" & "(?<b>(.*))" & "(?<c>(%>))"
replaceExpr = "${a}" & "<font cccc color=""" & SCC_SrcSettings("ColorDataBinding") & """><b>" & "${b}" & "</b></font>" & "${c}"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
'// Colorize tag <type>
searchExpr = "(?i)" & "(?<a>(<)(?!%)(?!/?asp:)(?!/?template)(?!/?property)(?!/?ibuyspy:)(/|!)?)" & "(?<b>[^;\s&]+)" & "(?<c>(\s|>|\Z))"
replaceExpr = "${a}" & "<font yyy color=""" & SCC_SrcSettings("ColorControlTag") & """>" & "${b}" & "</font>" & "${c}"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
'// Colorize asp:|template for runat=server tags <type>
searchExpr = "(?i)(?<a></?)(?<b>(asp:|template|property|IBuySpy:).*)(?<c>>)?"
replaceExpr = "${a}<font dddd color=""" & SCC_SrcSettings("ColorAspTemplateTag") & """><b>${b}</b></font>${c}"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
'//colorize begin of tag char(s) "<","</","<%"
searchExpr = "(?i)(?<a>(<)(/|!|%)?)"
replaceExpr = "<font zzzzz color=""" & SCC_SrcSettings("ColorStartHtmlTag") & """>" & "${a}" & "</font>"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
'// Colorize end of tag char(s) ">","/>"
searchExpr = "(?i)(?<a>(/|%)?(>))"
replaceExpr = "<font xxxx color=""" & SCC_SrcSettings("ColorEndHtmlTag") & """>" & "${a}" & "</font>"
If (Regex.IsMatch(sourceLine, searchExpr)) Then
sourceLine = Regex.Replace(sourceLine, searchExpr, replaceExpr)
End If
Return sourceLine
End Function
Private Function SCCGetLangFromLine(ByVal sourceLine As String, ByVal defLang As String) As String
If (sourceLine Is Nothing) Then
Return defLang
End If
Dim langMatch As Match = Regex.Match(sourceLine, "(?i)<%@\s*Page\s*.*Language\s*=\s*""(?<lang>[^""]+)")
If (langMatch.Success) Then
Return langMatch.Groups("lang").ToString()
End If
langMatch = Regex.Match(sourceLine, "(?i)(?=.*runat\s*=\s*""?server""?)<script.*language\s*=\s*""(?<lang>[^""]+)"".*>")
If (langMatch.Success) Then
Return langMatch.Groups("lang").ToString()
End If
langMatch = Regex.Match(sourceLine, "(?i)<%@\s*WebService\s*.*Language\s*=\s*""?(?<lang>[^""]+)""?")
If (langMatch.Success) Then
Return langMatch.Groups("lang").ToString()
End If
Return defLang
End Function
Private Sub SCCInitSettings()
If (SCC_SrcSettings Is Nothing) Then
Dim nv As New NameValueCollection
Dim ConfigPath As String = System.Web.HttpContext.Current.Server.MapPath(System.Web.HttpContext.Current.Request.ApplicationPath() & "\" & "showcode.config")
Dim reader As New XmlTextReader(ConfigPath)
Dim ntFormat As Object = reader.NameTable.Add("format")
Dim ntAdd As Object = reader.NameTable.Add("add")
Dim inFormat As Boolean = False
Do While (reader.Read())
If reader.NodeType = XmlNodeType.Element Then
If reader.Name.Equals(ntFormat) Then 'REM -- we are in format mode
If (reader.GetAttribute("name").ToLower = SCC_Format.ToLower()) Then 'REM -- we found the correct format
inFormat = True
End If
End If
End If
If (inFormat And reader.Name.Equals(ntAdd)) Then 'REM -- grab the format value
nv.Add(reader.GetAttribute("key"), reader.GetAttribute("value"))
End If
'REM -- now see if we find the end of the format tag
If (reader.NodeType = XmlNodeType.EndElement) Then 'REM -- are are the end of a tag
If (inFormat And reader.Name.Equals(ntFormat)) Then
reader.Close()
Exit Do
End If
End If
Loop
reader.Close()
SCC_SrcSettings = nv
End If
End Sub
Sub SP_DBPopulate_Array1d(ByVal strConn As String, ByVal strSQL As String, ByRef htParm As Hashtable, ByRef arrayParm As String())
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "SUB SP_DBPopulate Array1d"
Try
LogTaskStart(strTask)
Dim objtemp As Object
ArrayFromDatatable(strConn, strSQL, htParm, objtemp)
Try
arrayParm = objtemp
Catch InvalidCastException As Exception
logWarning(strTask, "BAD CAST")
End Try
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub SP_DBPopulate_Array2d(ByVal strConn As String, ByVal strSQL As String, ByRef htParm As Hashtable, ByRef arrayParm As String(,))
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "SUB SP_DBPopulate_Array2d"
Try
LogTaskStart(strTask)
Dim objtemp As Object
ArrayFromDatatable(strConn, strSQL, htParm, objtemp)
Try
arrayParm = objtemp
Catch InvalidCastException As Exception
logWarning(strTask, "BAD CAST")
End Try
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub SP_DBPopulate_Control(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable, ByRef objToFill As Object)
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SUB SP_DBPopulate_Control w/HashTable"
Dim strTypeName As String
Try
LogTaskStart(strTask)
logParm(strTask, strConn, "strConn")
logParm(strTask, strSQL, "strSQL")
logParm(strTask, htParms, "htParms")
logParm(strTask, objToFill, "objToFill")
strTypeName = TypeName(objToFill)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
SPSQLServer_DBPopulate(strConn, strSQL, htParms, objToFill)
Case Else
Throw New EntryPointNotFoundException(strTask & "::" & DBAnalyzeConn(strConn) & " is not implemented")
' CASE "oledb"
' DBPopulateOLEDB(strConn,strSQL,objToFill)
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub SP_DBPopulate_DataTable(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable, ByRef dtParm As DataTable)
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SUB SP_DBPopulate_DataTable"
Try
LogTaskStart(strTask)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
dtParm = SPSQLServer_DataTableGet(strConn, strSQL, htParms)
Case Else
Throw New EntryPointNotFoundException(strTask & "::" & DBAnalyzeConn(strConn) & " is not implemented")
End Select
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Function SP_DBScalar(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable) As Object
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "SP_DBScalar"
LogTaskStart(strTask)
Select Case DBAnalyzeConn(strConn)
Case "sqlserver"
LogTaskEnd(strTask)
Return LogReturn(strTask,SPSQLServer_DBScalar(strConn, strSQL, htParms))
Case Else
Throw New EntryPointNotFoundException(strTask & "::" & DBAnalyzeConn(strConn) & " is not implemented")
End Select
End Function
Private Sub SPSQLServer_arrayFromDataTable(ByRef parray As Object, ByVal pconn As String, ByRef htParm As Hashtable, ByVal strSQL As String)
'-- Added by Paul Brophy 31Mar03
Dim strTask As String = "SUB SPSQLServer_arrayFromDataTable"
LogTaskStart(strTask)
LogTaskSQL(strTask, strSQL)
Dim dt1 As New DataTable
dt1 = SPSQLServer_DataTableGet(pconn, strSQL, htParm)
ArrayFromDatatable(parray, dt1)
LogTaskEnd(strTask)
End Sub
Private Sub SPSQLServer_DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable)
'-- Added by Paul Brophy 31Mar03
' data columns for ONE ROW are returned in the hashtable containing the parameters
Dim strTask As String = "SUB SPSQLServer_DBPopulate 3 parms htParms as hashtable last parm"
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim Rdr1 As SqlDataReader
Dim Prm1(htParms.Count) As SqlParameter ' an array of SQLParameters
Dim strParam As String
Dim HasOutput As Boolean
Try
LogTaskStart(strTask)
logParm(strTask, strConn, "strConn")
logParm(strTask, strSQL, "strSQL")
logParm(strTask, htParms, "htParms")
' IF bolcache_
' Call DBPopulateCachedSQLClient(strConn,strSQL,objToFill)
' Call LogActivity("ubflow","sub DBPopulateSqlClient","end code")
' Exit sub
' END IF
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Cmd1.CommandType = CommandType.StoredProcedure
HasOutput = SPSQLServer_UnHashParms(Cmd1, htParms, Prm1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader()
If Not (Rdr1 Is Nothing) Then
If (Rdr1.Read()) Then
Dim count As Integer = Rdr1.FieldCount
Dim cols(count) As Object
Dim i As Integer
Rdr1.GetValues(cols)
For i = 0 To count - 1
htParms.Add(Rdr1.GetName(i), cols(i))
Next
End If
If HasOutput Then
SPSQLServer_ReHashParms(htParms, Prm1)
End If
End If
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Rdr1)
Release(Cmd1)
Release(Conn1)
LogTaskEnd(strTask)
End Try
End Sub
Private Function SPSQLServer_DataTableGet(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable) As DataTable
'-- Added by Paul Brophy, 31Mar03
'in May 2005 Charles fixed, old version never really returned datatable
Dim strTask As String = "SPSQLServer_DataTableGet"
logTaskParms(strTask, "strconn",strConn, "strSQL", strSQL,"htParms",htParms)
Dim Prm1(htParms.Count) As SqlParameter ' an array of SQLParameters
Dim HasOutput As Boolean
Dim cmd1 as sqlcommand
Try
LogTaskStart(strTask)
Dim dt1 As New DataTable
Dim conn As New SqlConnection(strConn)
cmd1=new SQLCommand(strSQL,conn)
cmd1.CommandType = CommandType.StoredProcedure
Dim adapter As New SqlDataAdapter(cmd1)
HasOutput = SPSQLServer_UnHashParms(adapter.SelectCommand, htParms, Prm1)
Conn.Open
adapter.Fill(dt1)
If HasOutput Then
SPSQLServer_ReHashParms(htParms, Prm1)
End If
LogTaskEnd(strTask)
Return LogReturn(strTask,dt1)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO: should I be disposing of resources here?
End Try
End Function
Private Function SPSQLServer_DBExec(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable)
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SPSQLServer_DBExec"
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim intReturn As Integer
Dim Prm1(htParms.Count) As SqlParameter ' an array of SQLParameters
Dim HasOutput As Boolean
Try
LogTaskStart(strTask)
LogTaskSQL(strTask, strSQL)
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Cmd1.CommandType = CommandType.StoredProcedure
HasOutput = SPSQLServer_UnHashParms(Cmd1, htParms, Prm1)
Conn1.Open()
intReturn = Cmd1.ExecuteNonQuery()
If HasOutput Then
SPSQLServer_ReHashParms(htParms, Prm1)
End If
logSQLReturn(strTask, intReturn, "intReturn")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Cmd1)
Release(Conn1)
End Try
Return intReturn
End Function
Private Sub SPSQLServer_DBPopulate(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable, ByRef objToFill As Object)
'-- Added by Paul Brophy, 31Mar03
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim Rdr1 As SqlDataReader
Dim Prm1(htParms.Count) As SqlParameter ' an array of SQLParameters
Dim strParam As String
Dim strTask As String = "SUB SPSQLServer_DBPopulate w/HashTable Parameter"
Dim HasOutput As Boolean
Dim bolCaughtError as boolean=false
Dim strMsg as string
Dim strParameterName as string
LogTaskParms(strTask,"strConn", strConn,"strSQL", strSQL,"htParms",htParms,"objToFill",objToFill)
Try
LogTaskStart(strTask)
'IF bolcache_
' Call SPSQLServer_DBPopulate_Cache(strConn,strSQL,objToFill)
' Call LogActivity("ubflow","sub DBPopulateSqlClient","end code")
' Exit sub
'END IF
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Cmd1.CommandType = CommandType.StoredProcedure
HasOutput = SPSQLServer_UnHashParms(Cmd1, htParms, Prm1)
Conn1.Open()
Rdr1 = Cmd1.ExecuteReader()
If HasOutput Then
SPSQLServer_ReHashParms(htParms, Prm1)
End If
If Rdr1 Is Nothing Then
' nothing to do
Else
objToFill.DataSource = Rdr1
objToFill.DataBind()
End If
Catch ex2 as SqlException
'LogException(strTask,ex2)
strMsg=ex2.Message
LogActivity(strTask,"strMsg",strMsg)
DIM intSingleQuotePos,intSingleQuote2Pos,intDiff as integer
If strMsg.IndexOf("is not a parameter")>-1 THEN
dim intPosis as integer
intPosis=strMsg.IndexOf("is")
LogActivity(strTask,"intPosis",intPosis)
strParameterName=strMsg.Substring(0,intPosis)
LogActivity(strTask,"strParameterName",strParameterName)
LogHintSprocWrongParameterName(strTask,strParameterName)
END IF
If strMsg.IndexOf("expects parameter")>-1 THEN
intSingleQuotePos=strMsg.IndexOf("'@")
LogActivity(strTask,"intSingleQuotePos",intSingleQuotePos)
intSingleQuote2Pos=strMsg.IndexOf("'",intSingleQuotePos+1)
LogActivity(strTask,"intSingleQuote2Pos",intSingleQuote2Pos)
intDiff=intSingleQuote2Pos-intSingleQuotePos-1
LogActivity(strTask,"intDiff",intDiff)
strParameterName=strMsg.Substring(intSingleQuotePos+1,intDiff)
LogActivity(strTask,"strParameterName",strParameterName)
LogHintSprocMissingParameter(strTask,strParameterName)
END IF
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Rdr1)
Release(Conn1)
LogTaskEnd(strTask)
End Try
End Sub
Private Function SPSQLServer_DBScalar(ByVal strConn As String, ByVal strSQL As String, ByRef htParms As Hashtable) As Object
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SPSQLServer_DBScalar"
Dim Prm1(htParms.Count) As SqlParameter ' an array of SQLParameters
Dim Conn1 As SqlConnection
Dim Cmd1 As SqlCommand
Dim objTempReturn As Object
Dim HasOutput As Boolean
Try
LogTaskStart(strTask)
LogTaskSQL(strTask, strSQL)
Conn1 = New SqlConnection(strConn)
Cmd1 = New SqlCommand(strSQL, Conn1)
Cmd1.CommandType = CommandType.StoredProcedure
HasOutput = SPSQLServer_UnHashParms(Cmd1, htParms, Prm1)
Conn1.Open()
objTempReturn = Cmd1.ExecuteScalar()
If HasOutput Then
SPSQLServer_ReHashParms(htParms, Prm1)
End If
logSQLReturn(strTask, objTempReturn, "objtempReturn")
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(Conn1)
End Try
Return (objTempReturn)
End Function
Private Function SPSQLServer_GetParmDirection(ByRef strParam As String) As ParameterDirection
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SPSQLServer_GetParmDirection"
Dim strTypeName As String
Dim pd As ParameterDirection = ParameterDirection.Input
Try
LogTaskStart(strTask)
If (strParam.StartsWith(">")) Then
strParam = strParam.Remove(0, 1)
pd = ParameterDirection.Output
End If
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
LogTaskEnd(strTask)
End Try
Return pd
End Function
Private Function SPSQLServer_GetParmType(ByRef objItem As Object) As SqlDbType
'-- Added by Paul Brophy, 31Mar03
Dim dbtype As SqlDbType = SqlDbType.VarChar ' takes the place of case else
' let the sp fail with a bad param
Dim strTask As String = "SPSQLServer_GetParmType"
LogTaskStart(strTask)
Select Case TypeName(objItem.value).ToLower()
Case "integer"
dbtype = SqlDbType.Int
Case "long"
dbtype = SqlDbType.BigInt
Case "short"
dbtype = SqlDbType.SmallInt
Case "byte"
dbtype = SqlDbType.TinyInt
Case "string"
dbtype = SqlDbType.VarChar
Case "datetime"
dbtype = SqlDbType.DateTime
Case "date"
dbtype = SqlDbType.DateTime
End Select
LogTaskEnd(strTask)
Return dbtype
End Function
Private Sub SPSQLServer_ReHashParms(ByRef htParms As Hashtable, ByRef SQLPrm() As SqlParameter)
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SUB SPSQLServer_ReHashParms"
logTaskParms(strTask,"htParms",htParms,"SQLprm",sqlPrm)
Dim i As Integer = 0
Dim strParam As String
Try
LogTaskStart(strTask)
For i = 0 To htParms.Count() - 1
If SQLPrm(i).Direction = ParameterDirection.Output Then
strParam = ">" & SQLPrm(i).ParameterName
htParms.Item(strParam) = SQLPrm(i).Value
End If
Next
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
LogTaskEnd(strTask)
End Try
End Sub
Private Function SPSQLServer_UnHashParms(ByRef Cmd1 As SqlCommand, ByRef htParms As Hashtable, ByRef SQLPrm() As SqlParameter) As Boolean
'-- Added by Paul Brophy, 31Mar03
Dim strTask As String = "SPSQLServer_UnHashParms"
logTaskParms(strTask,"cmd1",cmd1,"htParms",htParms,"SQLprm",sqlPrm)
Dim objItem As DictionaryEntry
Dim i As Integer = 0
Dim HasOutput As Boolean = False
Dim pdir As ParameterDirection
Dim strParam As String
LogTaskStart(strTask)
For Each objItem In htParms
strParam = objItem.Key
pdir = SPSQLServer_GetParmDirection(strParam)
SQLPrm(i) = Cmd1.Parameters.Add(strParam, SPSQLServer_GetParmType(objItem))
SQLPrm(i).Value = objItem.Value
SQLPrm(i).Direction = pdir
i = i + 1
If pdir = ParameterDirection.Output Then
HasOutput = True
End If
Next
LogTaskEnd(strTask)
Return HasOutput
End Function
Function SQLDelimiter(ByVal strParmConn As String, ByVal objParm As Object) As String
Dim strTypeName As String
strTypeName = TypeName(objParm)
Select Case strTypeName
Case "Boolean"
Return ("")
Case "Date"
Select Case DBAnalyzeConn(strParmConn)
Case "sqlserver"
Return ("'")
Case "oledb"
Return ("#")
End Select
Case "Integer"
Return ("")
Case "String"
Return ("'")
Case Else
logActivity("warning", objParm, "SQLDelimiter => Type " & strTypeName & " NOT recognized")
End Select
End Function
Function SQLgenerateInsert(ByVal strParmConn As String, ByVal htParm As Hashtable) As String
' updated 17 nov 2003
Dim strTask As String = "SQLgenerateInsert"
Dim d As DictionaryEntry
Dim strHashKey As String
Dim objHashVal As Object
Dim first_value As Boolean = True
Dim sb1 As New StringBuilder
Dim sbFieldList As New StringBuilder
Dim sbValueList As New StringBuilder
Dim strDelimiterCurrent As String
' get the database type
Dim DBType As String = DBAnalyzeConn(strParmConn)
Try
sb1.Append("INSERT INTO [")
sb1.Append(htParm("table_name"))
sb1.Append("] ")
For Each d In htParm
strHashKey = d.Key
objHashVal = d.Value
If strHashKey.ToLower() = "table_name" Then
' do nothing :)
Else
If Not (first_value) Then
sbFieldList.Append(", ")
End If
sbFieldList.Append("[")
sbFieldList.Append(strHashKey)
sbFieldList.Append("]")
strDelimiterCurrent = SQLDelimiter(DBType, objHashVal)
If Not (first_value) Then
sbValueList.Append(", ")
Else
first_value = False
End If
sbValueList.Append(strDelimiterCurrent)
If strDelimiterCurrent = "'" Then
sbValueList.Append(SQLTextClean(objHashVal.ToString()))
Else
sbValueList.Append(objHashVal)
End If
sbValueList.Append(strDelimiterCurrent)
End If
Next d
sb1.Append(System.Environment.NewLine)
sb1.Append(" (")
sb1.Append(sbFieldList)
sb1.Append(") ")
sb1.Append(System.Environment.NewLine)
sb1.Append(" VALUES (")
sb1.Append(sbValueList)
sb1.Append(")")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
Return (sb1.ToString())
End Function
Function SQLgenerateUpdate(ByVal strParmConn As String, ByVal htParm As Hashtable) As String
Dim strTask As String = "SQLgenerateUpdate"
Dim d As DictionaryEntry
Dim strHashKey As String
Dim objHashVal As Object
Dim inthashCount As Integer
Dim intHashItemNumber As Integer
Dim sb1 As New StringBuilder
Dim bolSkipHashEntry As Boolean = False
Dim strDelimiterCurrent As String
Try
sb1.Append("UPDATE [")
sb1.Append(htParm("table_name"))
sb1.Append("] SET ")
inthashCount = htParm.Count()
For Each d In htParm
intHashItemNumber += 1
bolSkipHashEntry = False
strHashKey = d.Key
objHashVal = d.Value
Select Case strHashKey.ToLower()
Case "table_name", "table_primarykey", "table_primarykey_value"
bolSkipHashEntry = True
Case Else
End Select
If bolSkipHashEntry = False Then
sb1.Append("[")
sb1.Append(strHashKey)
sb1.Append("]=")
strDelimiterCurrent = SQLDelimiter(strParmConn, objHashVal)
sb1.Append(strDelimiterCurrent)
If strDelimiterCurrent = "'" Then
Dim strTemp As String
strTemp = objHashVal.ToString()
strTemp = strTemp.Replace("'", "''")
sb1.Append(strTemp)
Else
sb1.Append(objHashVal)
End If
sb1.Append(strDelimiterCurrent)
If intHashItemNumber < inthashCount Then
sb1.Append(", ")
End If
End If
Next d
sb1.Append(System.Environment.NewLine)
sb1.Append("WHERE [")
sb1.Append(htParm("table_primarykey"))
sb1.Append("]=")
sb1.Append(SQLDelimiter(strParmConn, objHashVal))
sb1.Append(htParm("table_primarykey_value"))
sb1.Append(SQLDelimiter(strParmConn, objHashVal))
sb1.Replace(", " & System.Environment.NewLine & "WHERE", System.Environment.NewLine & "WHERE")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
Return (sb1.ToString())
End Function
Function SQLgenerateUpdateMany(ByVal strParmConn As String, ByVal htParm As Hashtable) As String
' updated 17 nov 2003
Dim strTask As String = "SQLgenerateUpdateMany"
Dim d As DictionaryEntry
Dim strHashKey, tempHashKey As String
Dim objHashVal As Object
Dim sb1 As New StringBuilder
Dim sb_where As New StringBuilder
Dim first_where As Boolean = True
Dim first_value As Boolean = True
Dim bolSkipHashEntry As Boolean = False
Dim strDelimiterCurrent As String
Try
' get the database type
Dim DBType As String = DBAnalyzeConn(strParmConn)
sb1.Append("UPDATE [")
sb1.Append(htParm("table_name"))
sb1.Append("] SET ")
For Each d In htParm
bolSkipHashEntry = False
strHashKey = d.Key.ToString
objHashVal = d.Value
tempHashKey = strHashKey.ToLower()
If tempHashKey = "table_name" Then
bolSkipHashEntry = True
ElseIf tempHashKey.IndexOf("where_") > -1 Then
bolSkipHashEntry = True
If first_where Then
first_where = False
sb_where.Append(" WHERE [")
Else
sb_where.Append(" AND [")
End If
' determine delimiter
strDelimiterCurrent = SQLDelimiter(DBType, objHashVal)
' zet het gedeelte na de "where_" als variabele in de where sb
sb_where.Append(Mid(strHashKey, 7))
sb_where.Append("] =")
sb_where.Append(strDelimiterCurrent)
If strDelimiterCurrent = "'" Then
sb_where.Append(SQLTextClean(objHashVal.ToString()))
Else
sb_where.Append(objHashVal)
End If
sb_where.Append(strDelimiterCurrent)
Else ' is ordinary value
' add a comma if it isn't the first entry
If first_value Then
first_value = False
Else
sb1.Append(", ")
End If
sb1.Append("[")
sb1.Append(strHashKey)
sb1.Append("]=")
strDelimiterCurrent = SQLDelimiter(DBType, objHashVal)
sb1.Append(strDelimiterCurrent)
If strDelimiterCurrent = "'" Then
Dim strTemp As String
strTemp = objHashVal.ToString()
strTemp = strTemp.Replace("'", "''")
sb1.Append(strTemp)
Else
sb1.Append(objHashVal)
End If
sb1.Append(strDelimiterCurrent)
End If
Next d
sb1.Append(System.Environment.NewLine)
sb1.Append(sb_where)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
Return (sb1.ToString)
End Function
Function SQLTextClean(ByVal strParm As String) As String
If strParm = String.Empty Or strParm = "" Then
Return (strParm)
End If
Return (strParm.Replace("'", "''"))
End Function
Function StreamOpen(ByVal strParmFileName As String, ByVal strParmCaller As String) As StreamReader
Dim strTask As String = "function StreamOpen"
Dim srTemp As StreamReader
Try
srTemp = File.OpenText(FileMapIfNeeded(strParmFileName, strParmCaller))
Catch ex1 As Exception
LogException(StreamLogInfo(strParmCaller, strTask, strParmFileName), ex1)
Release(srTemp)
End Try
Return (srTemp)
End Function
Function StreamFileAppend(ByVal strParmFileName As String, ByVal strParmCaller As String) As FileStream
Dim strTask As String = "function StreamFileCreate"
Dim fsTemp As FileStream
Try
fsTemp = New FileStream(strParmFileName, FileMode.Append)
Catch ex1 As Exception
LogException(StreamLogInfo(strParmCaller, strTask, strParmFileName), ex1)
Release(fsTemp)
End Try
Return (fsTemp)
End Function
Function StreamFileCreate(ByVal strParmFileName As String, ByVal strParmCaller As String) As FileStream
Dim strTask As String = "function StreamFileCreate"
Dim fsTemp As FileStream
Try
fsTemp = New FileStream(strParmFileName, FileMode.Create)
Catch ioexc1 As IOException
Dim bolDone As Boolean = False
intLockedFileAttempts = 0
Dim strsuffix As String = " Attempted every " & intLockedFileSleepDuration & " milliseconds."
Do While bolDone = False
Try
fsTemp = New FileStream(strParmFileName, FileMode.Create)
bolDone = True
logWarning(strTask, strParmFileName & " sucessfully opened after " & intLockedFileAttempts & " attempts! " & strsuffix)
Catch
Thread.Sleep(intLockedFileSleepDuration)
End Try
intLockedFileAttempts += 1
If intLockedFileAttempts = intLockedFileAttemptsMax Then
bolDone = True
logWarning(strTask, strParmFileName & " failed to open after " & intLockedFileAttempts & " attempts! " & strsuffix)
End If
Loop
Catch ex1 As Exception
LogException(StreamLogInfo(strParmCaller, strTask, strParmFileName), ex1)
Release(fsTemp)
End Try
Return (fsTemp)
End Function
Function StreamLogInfo(ByVal strCaller As String, ByVal strTask As String, ByVal strParmFileName As String) As String
Return ("Attempt #" & intLockedFileAttempts & " of " & intLockedFileAttemptsMax & " attempt every " & intLockedFileSleepDuration & " milliseconds<br>" & strCaller & "<br>" & strTask & "<br><b>" & strParmFileName & "</b>")
End Function
Private Function strToScreen(ByVal p1 As String)
If bolHTMLencode_ Then
p1 = System.Web.HttpContext.Current.Server.HtmlEncode(p1)
End If
Return (p1)
End Function
sub SuperTracePostProcess()
' Lets FigureOut The Timing Stuff
Dim datarow1 As DataRow
dim TicksThisRow, TicksLastRow as decimal
dim TicksElapsed,TicksTotal as decimal
dim introwcount as integer=0
FOR EACH datarow1 IN dsXray.Tables("SuperTrace").Rows
ticksLastRow=ticksThisRow
ticksThisRow=datarow1("EventTickCount")
'TicksElapsed=(TicksThisRow/QueryPerformanceFrequency())-(ticksLastRow/QueryPerformanceFrequency())
'TicksElapsed=(TicksThisRow-ticksLastRow)/QueryPerformanceFrequency()
TicksElapsed=TicksThisRow-ticksLastRow
datarow1("Elapsed")=TicksElapsed
If introwcount>0
ticksTotal+=TicksElapsed
else
datarow1("Elapsed")=0
end If
introwcount+=1
Next
dim MinutesTotal as decimal=TicksTotal '/QueryPerformanceFrequency()
END SUB
Sub TableRowBuild(ByVal intNumCells As Integer, ByVal strPrefixID As String)
'Dim intCounter as integer
'For intCounter=1 To intNumCells
' c = new HtmlTableCell()
' c.Controls.Add(new LiteralControl("cell" & counter))
' r.Cells.Add(c)
'next
'Table1.Rows.Add(r)
End Sub
Sub TableRowsAdd(ByRef tblParm As Table, ByVal strCell1 As String, ByVal strCell2 As String)
Dim strTask As String = "SUB TableRowsAdd"
Try
' Too noisy adds no value to debugging
' LogTaskStart(strTask)
Static intCellCounter As Integer
Dim cl1 As TableCell
Dim rw1 As TableRow
cl1 = New TableCell
cl1.Width = Unit.Percentage(25)
cl1.BorderWidth = Unit.Pixel(0)
cl1.VerticalAlign = System.Web.UI.WebControls.VerticalAlign.Top
cl1.Controls.Add(New LiteralControl(strCell1))
rw1 = New TableRow
rw1.Cells.Add(cl1)
cl1 = New TableCell
cl1.Width = Unit.Percentage(75)
cl1.BorderWidth = Unit.Pixel(0)
cl1.Controls.Add(New LiteralControl(strCell2))
rw1.Cells.Add(cl1)
intCellCounter += 1
'trace.warn("SUB TableRowsAdd", "tblParm.Rows=" & tblParm.Rows.count)
If tblParm.Rows.Count = 0 Then
intCellCounter = 1
'rw1.BackColor=Color.FromName("Yellow")
With tblParm
.BorderWidth = Unit.Pixel(1)
.GridLines = System.Web.UI.WebControls.GridLines.Both
.BorderStyle = System.Web.UI.WebControls.BorderStyle.Solid
.Width = Unit.Percentage(100)
End With
End If
'IF intCellCounter MOD 2 = 0
' rw1.BackColor=Color.FromName("Silver")
'END IF
tblParm.Rows.Add(rw1)
' Too noisy adds no value to debugging
' LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Function Toc(ByVal strParmFilename As String, ByVal htXMLMap As Hashtable) As String
Dim strTask As String = "SUB TOC"
Dim Xmltr1 As XmlTextReader
Try
LogTaskStart(strTask)
Dim strParms As String = ";weblocation;webname;group;groupmatch;groupimage;"
Dim d As DictionaryEntry
Dim intParmCount As Integer
For Each d In htXMLMap
If strParms.IndexOf(";" & d.Key & ";") = -1 Then
logActivity("error", "SUB TOC", "Bad Parameter=" & d.Key)
End If
intParmCount += 1
Next d
If System.Web.HttpContext.Current.Request("caller") = "utilitybelt" Then
'LogDebugData
logFlow(strTask, "caller=utilitybelt, displaying subsection")
htXMLMap("groupmatch") = System.Web.HttpContext.Current.Request("section")
End If
' This is all groupmatch stuff
Dim strSectionMatch As String = ""
Dim strSectionCurrent As String = ""
Dim strSectionPrev As String = ""
Dim bolSectionShow As Boolean = True
Dim strSectionURL As String
Dim bolSectionMode As Boolean = False
Dim intSectionCount As Integer
If htXMLMap.Contains("groupmatch") Then
logFlow(strTask, "contains groupmatch")
strSectionMatch = htXMLMap("groupmatch")
bolSectionShow = False
bolSectionMode = True
If htXMLMap.Contains("groupmatchsectionurl") Then
strSectionURL = htXMLMap("groupmatchsectionurl")
Else
strSectionURL = ""
End If
End If
Dim strPadLeft = " "
Dim strURLthispage As String = System.Web.HttpContext.Current.Request.RawUrl.ToLower()
strParmFilename = FileMapIfNeeded(strParmFilename, "Toc")
Xmltr1 = New XmlTextReader(strParmFilename)
Dim strURL As String
Dim strDes As String
Dim strURLPrev As String
Dim strDesPrev As String
Dim strURLNext As String
Dim strDesNext As String
Dim strSection As String
Dim intTOCcounter As Integer
Dim intTOCcurrent As Integer
Dim sb1 As New StringBuilder
Dim node11 As System.xml.XmlNodeType
Dim strNodeName As String
Dim bolInTable = False
Dim strSectionEnd As String = ""
Dim strSectionStart As String = ""
Do While Xmltr1.Read()
' LogDebugData("nodetype=",XmlTr1.nodeType)
' LogDebugData("nodename=",XMLtr1.Name)
If Xmltr1.NodeType = Element And Xmltr1.Name = htXMLMap("weblocation") Then
strURLPrev = strURL
strDesPrev = strDes
Xmltr1.Read()
strURL = Xmltr1.Value
intTOCcounter += 1
intTOCcurrent += 1
strURLPrev = strURL
strDesPrev = strDes
End If
If Xmltr1.NodeType = Element And Xmltr1.Name = htXMLMap("group") Then
If bolInTable Then
sb1.Append("</table>")
strSectionEnd = "</td></tr></table>" & vbCrLf
bolInTable = False
End If
If Xmltr1.HasAttributes And False = True Then
Dim intAttributeCount As Integer
Dim strAttName As String
Dim strAttValue As String
intAttributeCount = Xmltr1.AttributeCount()
Do While Xmltr1.MoveToNextAttribute()
strAttValue = Xmltr1.Value()
strAttName = Xmltr1.Name
Trace.Write("strAttName=", strAttValue)
Trace.Write("strAttValue=", strAttValue)
Loop
End If
Xmltr1.MoveToNextAttribute()
strSection = Xmltr1.Value
intSectionCount += 1
strSectionPrev = strSectionCurrent
strSectionCurrent = strSection
' This is all groupmatch stuff
If strSection = strSectionMatch Then
bolSectionShow = True
Else
If strSectionMatch <> "" Then
bolSectionShow = False
End If
End If
Dim strImg As String
Try
Xmltr1.MoveToNextAttribute()
strImg = Xmltr1.Value
If strImg = strSection Then
strImg = ""
Else
bolInTable = True
End If
Catch
strImg = ""
End Try
If bolSectionShow = False Then
' nothing to do
Else
With sb1
If strImg = "" Then
Else
.Append(vbCrLf)
.Append("<table width='100%'><tr><td width='1%'>")
.Append("<img src='")
.Append(strImg)
.Append("'")
.Append(" height='200' width='200'>")
.Append("</td>")
.Append(vbCrLf)
.Append("<td width='99%'>")
strImg = ""
End If
If strSectionPrev <> strSectionCurrent And bolInTable Then
.Append(vbCrLf)
.Append(vbCrLf)
strSectionEnd = ""
End If
.Append("<a href='")
.Append(strSectionURL)
.Append("?caller=utilitybelt§ion=")
.Append(Server.UrlEncode(strSection))
.Append("'><font size='+2'>")
.Append(strSection)
.Append("</font></a><br>")
.Append(vbCrLf)
End With
End If
End If
If Xmltr1.NodeType = Element And Xmltr1.Name = htXMLMap("webname") Then
Xmltr1.Read()
strDes = Xmltr1.Value
' LogDebugData(strTask,"URL=" & strURL)
' LogDebugData(strTask, "Desc=" & strDes)
' LogDebugData(strTask,"strURLPrev=" & strURLPrev)
' LogDebugData(strTask,"strDesPrev=" & strDesPrev)
If strURLthispage <> strURL Then
If bolSectionShow = False Then
' nothing to do
Else
With sb1
.Append(strPadLeft)
.Append("<a href='")
.Append(strURL)
.Append("'>")
.Append(strDes)
.Append("</a><br>")
.Append(vbCrLf)
End With
End If
End If
End If
Loop
Dim strPrefix As String = ""
If bolSectionMode And intSectionCount > 1 Then
strPrefix = "<a href='"
strPrefix &= System.Web.HttpContext.Current.Request.FilePath.ToLower()
strPrefix &= "'><font size='+2'>Full Table Of Contents</font></a><br><br>"
End If
LogTaskEnd(strTask)
Return (strPrefix & sb1.ToString() & "</td></tr></table>")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO - anyway to see if stream is not open
Xmltr1.Close()
End Try
End Function
Function TocBar(ByVal strParmFilename As String, ByVal htXMLMap As Hashtable) As String
Dim strTask As String = "SUB TOCBar"
Dim Xmltr1 As XmlTextReader
Try
LogTaskStart(strTask)
Dim strParms As String = ";weblocation;webname;toc;"
Dim d As DictionaryEntry
Dim intParmCount As Integer
For Each d In htXMLMap
If strParms.IndexOf(";" & d.Key & ";") = -1 Then
logActivity("error", "SUB TOCBar", "Bad Parameter=" & d.Key)
End If
intParmCount += 1
Next d
If intParmCount <> 3 Then
logActivity("error", "TOCBar", "Too Few Parameters=" & intParmCount)
End If
Dim strTOC As String = ""
If htXMLMap.Contains("toc") Then
strTOC = "[<A href='" & htXMLMap("toc") & "'>"
strTOC &= "Table of Contents</a>]<br>"
strTOC &= "Alpha Index Coming Soon"
End If
strParmFilename = FileMapIfNeeded(strParmFilename, "TOCBar")
Xmltr1 = New XmlTextReader(strParmFilename)
Dim strURL As String = ""
Dim strDes As String = ""
Dim strURLprev As String = ""
Dim strDesprev As String = ""
Dim strURLprev2 As String = ""
Dim strDesprev2 As String = ""
Dim strURLnext As String = ""
Dim strDesnext As String = ""
Dim bolGotBoth As Boolean
Dim bolGotNextAndPrev As Boolean
Dim intTOCcounter As Integer = 0
Dim strURLthispage As String = System.Web.HttpContext.Current.Request.RawUrl.ToLower()
' LogDebugData(strTask,"strURLThisPage=" & strURLthispage)
Dim sb1 As New StringBuilder
Do While Xmltr1.Read()
If Xmltr1.NodeType = Element And Xmltr1.Name = htXMLMap("weblocation") Then
logFlow(strTask, "Found weblocation element")
strURLprev2 = strURLprev
strURLprev = strURL
Trace.Write("strURLprev2=", strURLprev2)
Trace.Write("strURLprev=", strURLprev)
Xmltr1.Read()
strURL = Xmltr1.Value
Trace.Write("strURL=", strURL)
bolGotBoth = False
End If
If Xmltr1.NodeType = Element And Xmltr1.Name = htXMLMap("webname") Then
strDesprev2 = strDesprev
strDesprev = strDes
Xmltr1.Read()
strDes = Xmltr1.Value
Trace.Write("strDes=", strDes)
bolGotBoth = True
intTOCcounter += 1
Trace.Write("strDesprev=", strDesprev)
Trace.Write("strDesprev2=", strDesprev2)
End If
If bolGotBoth And strURLthispage = strURLprev.ToLower() And strURLprev2 <> "" Then
strURLnext = strURL
strDesnext = strDes
strURL = strURLprev
strDes = strDesprev
strURLprev = strURLprev2
strDesprev = strDesprev2
Trace.Write("strURLNext=", strURLnext)
Trace.Write("strDesNext=", strDesnext)
Trace.Write("strURL=", strURL)
Trace.Write("strDes=", strDes)
Trace.Write("strURLPrev=", strURLprev)
Trace.Write("strDesPrev=", strDesprev)
With sb1
.Append("<table width='100%'>")
.Append("<tr bgcolor='#FFCCFF'><td align='center' width='50%'>")
.Append("Current Lesson:<br><A href='")
.Append(strURL)
.Append("'><b>")
.Append(strDes)
.Append("</b></a></td><td width='50%'>")
.Append(strTOC)
.Append("</td></tr><tr bgcolor='#CCE6FF'><td width='50%'>")
.Append("<A href='")
.Append(strURLprev)
.Append("'>")
.Append("[prev. Lesson] ")
.Append(strDesprev)
.Append("</a></td><td width='50%'>")
.Append("<A href='")
.Append(strURLnext)
.Append("'>[next Lesson] ")
.Append(strDesnext)
.Append("</a>")
.Append("</td></tr></table>")
End With
Exit Do
End If
Loop
LogTaskEnd(strTask)
Return sb1.ToString()
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO - check if stream is open?
Xmltr1.Close()
End Try
End Function
private function UBIndent(parmInt as integer)
return(" ")
end function
Sub Undocumented(ByVal strUndocumented As String)
Dim strTask As String = "Undocumented"
Dim strUndocmentedMoniker As String = strUndocumented.ToLower()
Select Case strUndocmentedMoniker
Case ("xray_cache")
Xray_cache()
Case ("xray_ub")
XRay_UB()
Case ("xray_request")
Xray_request()
Case Else
logWarning("Undocumented", "Undocumented moniker unknown=>" & strUndocumented)
End Select
End Sub
Sub Undocumented(ByVal strUndocumented As String, ByVal htParms As Hashtable)
Dim strTask As String = "Undocumented / parm2 as hashtable"
Dim strUndocmentedMoniker As String = strUndocumented.ToLower()
Select Case strUndocmentedMoniker
Case ("xmlnodestoarray")
XMLNodesToArray(htParms)
Case Else
logWarning("Undocumented", "Undocumented moniker unknown=>" & strUndocumented)
End Select
End Sub
Private Function ValidateParams(ByVal validParams As String(), ByVal htParams As Hashtable) As Integer
Dim strTask As String = "CountValidParams"
Dim numberOfValidParams As Integer
Dim d As DictionaryEntry
For Each d In htParams
If Array.IndexOf(validParams, d.Key) = -1 Then
LogHint(strTask, "Bad Parameter=" & d.Key.ToString())
Else
If wsAmazonIsParamValueValid(d.Key.ToString(), d.Value.ToString()) Then
numberOfValidParams += 1
End If
End If
Next d
Return numberOfValidParams
End Function
Function WebConfigGrab(ByVal strkey As String) As String
Return (appkey(strkey))
End Function
Function wsAmazonASINSearch(ByVal htParm As Hashtable) As String
Dim strTask As String = "wsAmazonASINSearch"
LogTaskParms(strTask,"htParm",htParm)
LogTaskStart(strTask)
Return LogReturn(strTask,wsAmazonSearch(strTask, htParm, New String() {"AsinSearch", "asin", "type"}))
End Function
Function wsAmazonASINSearchOLD(ByVal htParm As Hashtable) As String
Dim strTask As String = "wsAmazonASINSearch"
LogTaskParms(strTask,"htParm",htParm)
Dim strAmazonURL As String
Try
LogTaskStart(strTask)
Dim strParms As String = ";asin;type;"
Dim d As DictionaryEntry
Dim intParmCount As Integer
For Each d In htParm
If strParms.IndexOf(";" & d.Key & ";") = -1 Then
LogHint(strTask, "Bad Parameter=" & d.Key)
End If
intParmCount += 1
Next d
If intParmCount < 2 Then
LogHint(strTask, "Too Few Parameters=" & intParmCount)
End If
Select Case htParm("type")
Case "lite", "heavy"
' nothing to do
Case Else
LogHint(strTask, "HashTable Parameter type must be lite or heavy")
Exit Function
End Select
strAmazonURL &= "http://xml.amazon.com/onca/xml2?"
strAmazonURL &= "t=" & strAmazonPromoCode_
strAmazonURL &= "&dev-t=" & strAmazonDevToken_
strAmazonURL &= "&type=" & htParm("type")
strAmazonURL &= "&AsinSearch=" & htParm("asin")
strAmazonURL &= "&f=xml"
Dim strAmazonResult As String = HTTPGrab(strAmazonURL)
If strAmazonResult.IndexOf("<ErrorMsg>") > 0 Then
LogHint(strTask, "Amazon Call Returned Error<br>" & strAmazonURL)
End If
LogTaskEnd(strTask)
Return LogReturn(strTask,strAmazonResult)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Function
Function wsAmazonActorSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonActorSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"ActorSearch", "mode", "type"})
End Function
Function wsAmazonAuthorSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonAuthorSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"AuthorSearch", "mode", "type"})
End Function
Function wsAmazonArtistSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonArtistSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"ArtistSearch", "mode", "type"})
End Function
Function wsAmazonBlendedSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonBlendedSearch"
LogTaskStart(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"BlendedSearch", "type"})
LogTaskEnd(strTask)
End Function
Function wsAmazonBrowseNodeSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonBrowseNodeSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"BrowseNodeSearch", "mode", "type"})
End Function
Private Function wsAmazonBuildUrl(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonBuildURL"
LogTaskStart(strTask)
LogTaskParms(strTask,"htParams",htParams)
Dim url As New StringBuilder
url.Append("http://xml.amazon.com/onca/xml2?")
url.Append("t=" & strAmazonPromoCode)
url.Append("&dev-t=" & strAmazonDevToken)
Dim param As DictionaryEntry
For Each param In htParams
url.AppendFormat("&{0}={1}", param.Key, System.Web.HttpUtility.HtmlEncode(param.Value.ToString()))
Next
url.Append("&f=xml")
Dim locale As String = strAmazonLocale
If locale.Length > 0 Then
url.Append("&locale=" & locale)
End If
LogTaskEnd(strTask)
Return LogReturn(strTask,url.ToString())
End Function
Function wsAmazonDirectorSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonDirectorSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"DirectorSearch", "mode", "type"})
End Function
Private Sub wsAmazonEnforceGuidelines(ByVal url As String)
Dim strTask As String = "AmazonEnforceGuidelines"
LogTaskStart(strTask)
If Not (bolCache = True AndAlso IsCached("httpgrab:" & url)) Then
Dim timeDiference As TimeSpan = DateTime.Now.Subtract(_AmazonLastCallTime)
If timeDiference.TotalMilliseconds < 1000 Then
System.Threading.Thread.Sleep(timeDiference)
End If
End If
LogTaskEnd(strTask)
_AmazonLastCallTime = DateTime.Now
End Sub
Function wsAmazonExchangeSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonExchangeSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"ExchangeSearch", "type"})
End Function
Private Function wsAmazonIsParamValueValid(ByVal param As String, ByVal value As String) As Boolean
Dim strTask As String = "wsAmazonIsParamValueValid"
LogTaskParms(strTask,"param",param,"value",value)
Dim returnVal As Boolean = True
Select Case param.ToLower
Case "type"
returnVal = wsAmazonIsParamValueValid(param, value, "lite", "heavy")
Case "browsenodesearch"
If IsNumeric(value) Then
returnVal = True
Else
LogHint("wsAmazonIsParamValueValid", String.Format("Parameter [{0}] must be numeric", param))
returnVal = False
End If
Case "offerstatus"
returnVal = wsAmazonIsParamValueValid(param, value, "open", "closed")
Case "offer"
wsAmazonIsParamValueValid(param, value, "ThirdPartyNew", "Used", "Collectible", "Refurbished")
Case Else
returnVal = True
End Select
Return LogReturn(strTask,returnVal)
End Function
Private Function wsAmazonIsParamValueValid(ByVal param As String, ByVal value As String, ByVal ParamArray validValues As String()) As Boolean
Dim strTask As String = "wsAmazonIsParamValuevalid"
LogTaskParms(strTask,"param",param,"value",value,"validValues",validValues)
If Array.IndexOf(validValues, value) > -1 Then
Return LogReturn(strTask,True)
Else
LogHint(strTask, String.Format("Parameter [{0}] must be {1} not {2}", param, String.Join(", ", validValues), value))
Return LogReturn(strTask,False)
End If
End Function
Function wsAmazonKeywordSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonKeywordSearch"
LogTaskParms(strTask,"htParams",htParams)
LogTaskStart(strTask)
Return LogReturn(strTask,wsAmazonSearch(strTask, htParams, New String() {"KeywordSearch", "mode", "type"}))
End Function
Function wsAmazonListManiaSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonListManiaSearch"
LogTaskStart(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"ListManiaSearch", "type"})
LogTaskEnd(strTask)
End Function
Function wsAmazonManufacturerSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonManufacturerSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"ManufacturerSearch", "mode", "type"})
End Function
Function wsAmazonMarketplaceSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonMarketplaceSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"AsinSearch", "type", "offer"})
End Function
Function wsAmazonPowerSearch(ByVal htParams As Hashtable) As String
' TODO Power seach should be more in depth, ie, allow the users to pass the properties
' See 8.14 Power Searches via XML
Dim strTask As String = "wsAmazonPowerSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"PowerSearch", "mode", "type"})
End Function
Function wsAmazonSimilaritySearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonSimilaritySearch"
LogTaskStart(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"SimilaritySearch", "type"})
LogTaskEnd(strTask)
End Function
Function wsAmazonSellerProfileSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonSellerProfileSearch"
LogTaskStart(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"SellerProfile", "type"})
LogTaskEnd(strTask)
End Function
Private Function wsAmazonSearch(ByVal callingFunction As String, ByVal htParams As Hashtable, ByVal requiredParams As String()) As String
Dim strTask As String = "wsAmazonSearch"
LogTaskParms(strTask,"htParams",htParams,"requiredParams()",requiredParams)
Dim retVal As String = ""
Try
If strAmazonDevToken_ is nothing
dim strMsg as string="DevToken must be placed in "
StrMsg &= "<a href='http://www.learnasp.com/freebook/learn/utilitybelt_config.aspx'>utilitybelt.config</a>"
LogHint(callingFunction,strMsg)
return("")
End If
If htParams Is Nothing Then
LogHint(callingFunction, "You can't send a Nothing / Null htParams")
Else
Dim numberOfValidParams As Integer = ValidateParams(requiredParams, htParams)
If numberOfValidParams < requiredParams.Length Then
LogHint(callingFunction, String.Format("Too Few Parameters={0}. Required {1} parameters, that are: {2}", numberOfValidParams, requiredParams.Length, String.Join(", ", requiredParams)))
Else
Try
Dim strURL As String = wsAmazonBuildUrl(htParams)
'LogError(strTask, strURL)
wsAmazonEnforceGuidelines(strURL)
retVal = LogReturn(strTask,HTTPGrab(strURL).ToString())
Catch ex1 As Exception
LogException(strTask, ex1)
End Try
End If
End If
Catch ex As Exception
LogException(strTask, ex)
End Try
LogTaskEnd(strTask)
Return retVal
End Function
Function wsAmazonThirdPartySellerSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonThirdPartySellerSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"SellerSearch", "offerstatus", "type"})
End Function
Function wsAmazonUpcSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonUpcSearch"
LogTaskStart(strTask)
LogTaskEnd(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"UpcSearch", "mode", "type"})
End Function
Function wsAmazonWishlistSearch(ByVal htParams As Hashtable) As String
Dim strTask As String = "wsAmazonWishlistSearch"
LogTaskStart(strTask)
Return wsAmazonSearch(strTask, htParams, New String() {"WishlistSearch", "type"})
LogTaskEnd(strTask)
End Function
Private Sub XMLNodesToArray(ByVal htParams As Hashtable)
End Sub
Function XMLToDataSet(ByVal strFilename As String) As DataSet
Dim strTask As String = "XMLToDataSet"
Dim ds As New DataSet
Dim FS As FileStream
Dim strFileToRead As String
Try
LogTaskStart(strTask)
strFileToRead = FileMapIfNeeded(strFilename, "DataSetGetXML")
FS = New FileStream(strFileToRead, FileMode.Open)
ds.ReadXml(FS)
LogTaskEnd(strTask)
Catch UnauthorizedAccessException As Exception
LogHint(strTask, "permissions problem with file!", strFileToRead, "strFileToRead")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
Release(FS)
End Try
Return (ds)
End Function
Function XMLToDataTable(ByVal strFilename As String) As DataTable
Dim strTask As String = "XMLToDataTable"
Dim Xmltr1 As XmlTextReader
Dim dt1 As DataTable
Try
LogTaskStart(strTask)
Xmltr1 = New XmlTextReader(FileMapIfNeeded(strFilename, "XMLToDataTable"))
Dim bolTrackThis As Boolean = False
Dim intXMLkey As Integer
Dim strElementCurrent As String
Dim intAttributeCount As Integer = 0
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("Key", GetType(String)))
dt1.Columns.Add(New DataColumn("Element", GetType(String)))
dt1.Columns.Add(New DataColumn("NodeType", GetType(String)))
dt1.Columns.Add(New DataColumn("Value", GetType(String)))
dt1.Columns.Add(New DataColumn("Name", GetType(String)))
dt1.Columns.Add(New DataColumn("LocalName", GetType(String)))
dt1.Columns.Add(New DataColumn("NameSpaceURI", GetType(String)))
Xmltr1.WhitespaceHandling = WhitespaceHandling.None
Xmltr1.Read()
Do
bolTrackThis = True
If Xmltr1.NodeType = Element Then
bolTrackThis = False
'Xmltr1.Read()
strElementCurrent = Xmltr1.Name()
End If
If Xmltr1.NodeType = EndElement Then
bolTrackThis = False
strElementCurrent = ""
End If
If bolTrackThis Then
intXMLkey += 1
End If
intAttributeCount = 0
If bolTrackThis = True Then
Dim dtblRowTemp As DataRow
dtblrowTemp = dt1.NewRow()
dtblrowTemp(0) = intXMLkey
dtblrowTemp(1) = strElementCurrent
dtblrowTemp(2) = Xmltr1.NodeType.ToString()
dtblrowTemp(3) = Server.HtmlEncode(Xmltr1.Value())
dtblrowTemp(4) = Xmltr1.Name
dtblrowTemp(5) = Xmltr1.LocalName()
dtblrowTemp(6) = Xmltr1.NamespaceURI()
dt1.Rows.Add(dtblrowTemp)
End If
If Xmltr1.HasAttributes Then
intAttributeCount = Xmltr1.AttributeCount()
Do While Xmltr1.MoveToNextAttribute()
intXMLkey += 1
Dim dtblRowTemp As DataRow
dtblrowTemp = dt1.NewRow()
dtblrowTemp(0) = intXMLkey
dtblrowTemp(1) = strElementCurrent
dtblrowTemp(2) = Xmltr1.NodeType.ToString()
dtblrowTemp(3) = Server.HtmlEncode(Xmltr1.Value())
dtblrowTemp(4) = Xmltr1.Name
dtblrowTemp(5) = Xmltr1.LocalName()
dtblrowTemp(6) = Xmltr1.NamespaceURI()
dt1.Rows.Add(dtblrowTemp)
Loop
End If
Loop While Xmltr1.Read()
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO - stream?
Xmltr1.Close()
End Try
Return (dt1)
End Function
Function XMLGrabberElements(ByVal strParmFileName As String, ByVal htXMLToFetch As Hashtable) As DataTable
Dim strTask As String = "XMLGrabberElements"
Dim Xmltr1 As XmlTextReader
Dim strMapFile As String
Dim dt1 As DataTable
Try
LogTaskStart(strTask)
strMapFile = FileMapIfNeeded(strParmFileName, "XMLtoDataTable")
' Now setup Datatable
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("XMLValue", GetType(String)))
dt1.Columns.Add(New DataColumn("XMLNodeType", GetType(String)))
dt1.Columns.Add(New DataColumn("XMLType", GetType(String)))
' now Walk XML File
Xmltr1 = New XmlTextReader(strMapFile)
Dim strItemName As String
Dim strItemValue As String
Dim strItemType As String
Dim strDebugAll As String
Do While Xmltr1.Read()
strItemType = ""
strItemName = ""
strItemValue = ""
If Xmltr1.NodeType = Element Then
strItemType = "element"
strItemName = Xmltr1.Name
Xmltr1.Read()
strItemValue = Xmltr1.Value
End If
strDebugAll = "strItemType=" & strItemType & ";strItemName=" & strItemName & "; strItemValue=" & strItemValue
' LogDebugData(strTask,strDebugAll)
If strItemType = "" Then
' Nothing found worthwile
Else
If htXMLToFetch.Contains(strItemName) Then
logFlow(strTask, "htXMLToFetch.contains TRUE")
logFlow(strTask, "strItemType Match")
Dim dtblRowTemp As DataRow
dtblRowTemp = dt1.NewRow()
dtblRowTemp(0) = strItemValue
dtblRowTemp(1) = strItemName
dtblRowTemp(2) = strItemType
dt1.Rows.Add(dtblRowTemp)
End If
End If
Loop
LogTaskEnd(strTask)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
' TODO - stream ?
Xmltr1.Close()
End Try
Return (dt1)
End Function
sub Xray(strParmTaskName as string,strParmTaskCategory as string,StrParmName as string,ObjParm as object)
Xray(ObjParm,strParmName)
end sub
public Sub Xray(ByVal p1 As Object, ByVal p2 As String)
' UNDOCUMENTED new command
' utlty1.Xray(Request(),"Request Object")
Dim strTask As String = "SUB XRay"
If bolXrayOn_ = False Then
Exit Sub
End If
Dim strTypeName As String
strTypeName = TypeName(p1)
Select Case strTypeName
Case "ArrayList"
XRay_ArrayList(p1, p2)
Case "Boolean"
If bolXrayToPage_ Then
plcXray.Controls.Add(New LiteralControl(XrayHeading(p2,"boolean") & p1))
Else
logActivity("xray", p2, p1)
End If
Case "DataTable"
XRay_Datatable(p1, p2)
'CASE "HttpFileCollection"
' Trace_HTTPFileCollection(p1,p2)
Case "Integer"
If bolXrayToPage_ Then
plcXray.Controls.Add(New LiteralControl(XrayHeading(p2,"integer") & p1))
Else
logActivity("xray", p2, p1)
End If
Case "Nothing"
If bolXrayToPage_ Then
plcXray.Controls.Add(New LiteralControl(XrayHeading(p2,"Nothing")))
Else
logActivity("xray", p2, "Nothing")
End If
Case "Queue"
XRay_Q(p1, p2)
Case "Stack"
XRay_Stack(p1, p2)
Case "SortedList"
XRay_SortedList(p1, p2)
Case "String"
Xray_String(p1, p2)
Case "String()"
XRay_Array1d(p1, p2)
Case "String(,)"
XRay_Array2d(p1, p2)
Case "DataSet"
XRay_DataSet(p1, p2)
Case "Hashtable"
XRay_HashTable(p1, p2)
Case "HttpRequest"
Xray_Request()
Case Else
logWarning("Xray", p2 & " typename=" & strTypeName & " NOT RECOGNIZED")
Exit Sub
If bolXrayToPage_ Then
plcXray.Controls.Add(New LiteralControl("<hr>" & p2 & " is type=" & strTypeName & "<hr>"))
Else
logActivity("xray", p2, strTypeName)
End If
End Select
End Sub
Private Sub XRay_1Control(ByVal p1Ctrl As Control, ByVal p2CtrlName As String)
Dim strTask As String = "Xray_1Control"
Try
logActivity("xray", "SUB XRay_1Control", "start")
logActivity("xray", p2CtrlName, p2CtrlName & ".ClientID=" & p1Ctrl.ClientID)
logActivity("xray", p2CtrlName, p2CtrlName & ".Type=" & p1Ctrl.GetType.ToString())
logActivity("xray", p2CtrlName, p2CtrlName & ".ID=" & p1Ctrl.ID)
logActivity("xray", p2CtrlName, p2CtrlName & ".NamingContainer.ToString()=" & p1Ctrl.NamingContainer.ToString())
logActivity("xray", p2CtrlName, p2CtrlName & ".Page.ToString()=" & p1Ctrl.Page.ToString())
logActivity("xray", p2CtrlName, p2CtrlName & ".Parent.ToString()=" & p1Ctrl.Parent.ToString())
logActivity("xray", p2CtrlName, p2CtrlName & ".UniqeID=" & p1Ctrl.UniqueID)
logActivity("xray", "SUB XRay_1Control", "end")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Array1d(ByVal myArray As Array, ByVal strArrayName As String)
Dim strTask As String = "Xray_Array1d"
If bolXrayToPage_ Then
XRay_Array1d_ToPage(myArray, strArrayName)
Exit Sub
End If
Try
logActivity("xray", "Xray", strArrayName & "- 1d array - start")
Dim intarraycounter As Integer = 0
Dim objCell As Object
For intarraycounter = 0 To myArray.GetUpperBound(0)
objCell = myArray(intarraycounter)
logActivity("xray", "r:" & intarraycounter & " t:" & TypeName(objCell), objCell)
Next
logActivity("xray", "Xray", strArrayName & " - 1d array - end")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Array1d_ToPage(ByVal myarray As Array, ByVal strArrayName As String)
Dim strTask As String = "sub XRay_Array1d_ToPage"
Dim tblArray As New Table
Dim dt1 As DataTable
Dim intArrayHeight As Integer
Try
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("Index", GetType(String)))
dt1.Columns.Add(New DataColumn("Value", GetType(String)))
Dim intarraycounter As Integer = 0
intArrayHeight = myarray.GetUpperBound(0)
For intarraycounter = 0 To intArrayHeight
Dim dtblrowtemp As DataRow
dtblrowtemp = dt1.NewRow
dtblrowtemp(0) = intarraycounter
dtblrowtemp(1) = strToScreen(myarray(intarraycounter))
dt1.Rows.Add(dtblrowtemp)
Next
plcXray.Controls.Add(New LiteralControl(""))
XRay_Datatable_ToPage(dt1,XrayHeading(strArrayName,"string()"))
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Array2d(ByVal myarray As Array, ByVal strArrayName As String)
Dim strTask As String = "Xray_Array2d"
If bolXrayToPage_ Then
XRay_Array2d_ToPage(myarray, strArrayName)
Exit Sub
End If
Try
Dim intarraycounter As Integer = 0
Dim intarray2counter As Integer
Dim objCell As Object
logActivity("xray", "Xray", strArrayName & "2d array start")
For intarraycounter = 0 To myarray.GetUpperBound(0)
For intarray2counter = 0 To myarray.GetUpperBound(1)
objCell = myarray(intarraycounter, intarray2counter)
logActivity("xray", "r:" & intarraycounter & " c:" & intarray2counter & " t:" & TypeName(objCell), _
objCell)
Next
Next
logActivity("xray", "Xray", strArrayName & "2d array end")
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Array2d_ToPage(ByVal myarray As Array, ByVal strArrayName As String)
Dim tblArray As New Table
Dim dt1 As DataTable
Try
tblArray.BorderWidth = Unit.Pixel(2)
Dim intarraycounter As Integer = 0
Dim intarray2counter As Integer
Dim strCell As String
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("Row", GetType(String)))
For intarraycounter = 0 To myarray.GetUpperBound(1)
dt1.Columns.Add(New DataColumn("col" & intarraycounter, GetType(String)))
Next
For intarraycounter = 0 To myarray.GetUpperBound(0)
Dim dtblrowtemp As DataRow
dtblrowtemp = dt1.NewRow
dtblrowtemp(0) = intarraycounter
'trace.warn("intarraycounter",intarraycounter)
For intarray2counter = 0 To myarray.GetUpperBound(1)
'trace.warn("intarraycounter2",intarraycounter2)
strCell = myarray(intarraycounter, intarray2counter)
dtblrowtemp(intarray2counter + 1) = strToScreen(strCell)
Next
dt1.Rows.Add(dtblrowtemp)
Next
XRay_Datatable_ToPage(dt1, strArrayName)
Catch ex1 As Exception
LogException("Sub XRay_Array2d_ToPage", ex1)
Finally
End Try
End Sub
Private Sub XRay_ArrayList(ByVal p1 As ArrayList, ByVal p2ArrayListName As String)
' TODO: tracetopage
If bolXrayToPage_ Then
XRay_ArrayList_ToPage(p1, p2ArrayListName)
Exit Sub
End If
Dim strTask As String = "SUB Xray_ArrayList"
logActivity("xray", strTask, p2ArrayListName & " count=" & p1.Count() & " capacity=" & p1.Capacity)
Dim objArrayItem As Object
For Each objArrayItem In p1
logActivity("xray", strTask, p2ArrayListName & "=" & objArrayItem.ToString())
Next
End Sub
Private Sub XRay_ArrayList_ToPage(ByVal arrylstParm As ArrayList, ByVal strName As String)
Dim strTask As String = "sub XRay_ArrayList_ToPage"
Try
plcXray.Controls.Add(New LiteralControl(""))
XRay_Datatable_ToPage(arrylstParm, "ArrayList named " & strName)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Sub Xray_cache()
Xray_cache(False, False)
End Sub
Sub XRay_Cache(ByVal bolShowSystem As Boolean, ByVal bolShowAspNetWorkerProcess As Boolean)
' Adapted from http://www.aspalliance.com/aldotnet/examples/cacheviewer.aspx
Dim strTask As String = "SUB Xray_Cache"
Dim objItem As Object
Dim strName As String
Dim strFirst7 As String
Dim intCacheCount As Integer
Dim intCacheSystemCount As Integer
Dim intCacheISAPICount As Integer
For Each objItem In System.Web.HttpContext.Current.Cache
strName = objItem.Key
strFirst7 = strName.Substring(0, 7)
Select Case strFirst7
Case "System."
If bolShowSystem = True Then
LogMessages(strTask, "cache-system", "type=" & System.Web.HttpContext.Current.Cache(strName).GetType().ToString() & ";name=" & strName)
End If
intCacheSystemCount += 1
Case "ISAPIWo"
If bolShowAspNetWorkerProcess = True Then
LogMessages(strTask, "cache-aspnetworker", "type=" & System.Web.HttpContext.Current.Cache(strName).GetType().ToString() & ";name=" & strName)
End If
intCacheISAPICount += 1
Case Else
'trace.write("SUB XRay_Cache","strFirst7=" & strFirst7)
LogMessages(strTask, "cache", "type=" & System.Web.HttpContext.Current.Cache(strName).GetType().ToString() & ";name=" & strName)
intCacheCount += 1
End Select
Next
logActivity("xray", strTask, "cached items count=" & intCacheCount & "; ISAPI Cache Count=" & intCacheISAPICount & "; System Cache Count=" & intCacheSystemCount)
End Sub
Private Sub XRay_Controls(ByVal p1Ctrl As Object)
Dim strTask As String = "SUB Xray_Controls"
Try
Dim ctrl1 As Control
For Each ctrl1 In p1Ctrl.Controls
XRay_1Control(ctrl1, ctrl1.ID)
XRay_Controls(ctrl1)
Next
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_DataSet(ByVal dsparm1 As DataSet, ByVal strDsName As String)
Dim strTask As String = "Xray_DataSet"
If bolXrayToPage_ Then
XRay_DataSet_ToPage(dsparm1, strDsName)
Exit Sub
End If
Try
Dim dt1 As Object ' datatable
Dim intTableCount As Integer
Dim intTableCurrent As Integer
Dim intCounter As Integer
intTableCount = dsparm1.Tables.Count()
logActivity("xray", strDsName, intTableCount & " DataTables are in this DataSet")
For intCounter = 0 To intTableCount - 1
dt1 = dsparm1.Tables(intCounter)
'plcXray.controls.add(new literalcontrol("dt1 TypeName=" & typename(dt1) & "<br>"))
XRay_Datatable(dt1, "#" & intCounter)
Next
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_DataSet_ToPage(ByVal dsparm1 As DataSet, ByVal strDsName As String)
Dim strTask As String = "Xray_DataSet_ToPage"
Try
Dim dt1 As Object ' datatable
Dim intTableCount As Integer
Dim intTableCurrent As Integer
Dim intCounter As Integer
Dim dg1 As DataGrid
intTableCount = dsparm1.Tables.Count()
plcXray.Controls.Add(New LiteralControl("<hr>"))
plcXray.Controls.Add(New LiteralControl("Dataset name=" & strDsName & "<br>" & intTableCount - 1 & " DataTables are in this DataSet<br>"))
For intCounter = 0 To intTableCount - 1
' plcXray.controls.add(new literalcontrol(intCounter))
dt1 = dsparm1.Tables(intCounter)
' plcXray.controls.add(new literalcontrol("dt1 TypeName=" & typename(dt1) & "<br>"))
XRay_Datatable_ToPage(dt1, "Dataset name=" & strDsName & " Datatable #" & intCounter & " of " & intTableCount - 1)
Next
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Datatable(ByVal dtparm1 As DataTable, ByVal strDtName As String)
Dim strTask As String = "Xray_Datatable"
If bolXrayToPage_ Then
XRay_Datatable_ToPage(dtparm1, "Datable named " & strDtName)
Exit Sub
End If
Try
Dim datarow1 As DataRow
If dtparm1.Rows.Count = 0 Then
logActivity("xray", strTask, "Empty DataTable named " & strDtName)
Exit Sub
End If
Dim intfieldcounter As Integer = 0
Dim intcolscount As Integer = dtparm1.Columns.Count - 1
Dim colname(intcolscount) As String
Dim dc1 As DataColumn
For Each dc1 In dtparm1.Columns
colname(intfieldcounter) = dc1.ColumnName
intfieldcounter += 1
Next
intfieldcounter = 0
Dim intRowcounter As Integer = 0
Dim sbXray As New StringBuilder
Dim strDataTableName As String = "DataTable:" & strDtName & "<br>"
sbXray.Append(strDataTableName)
For Each datarow1 In dtparm1.Rows
For intfieldcounter = 0 To intcolscount
Try
With sbXray
.Append("<font color='blue'> row:" & intRowcounter)
.Append(" col:")
.Append(intfieldcounter)
.Append(" columnName:")
.Append(colname(intfieldcounter))
.Append(" type:")
.Append(TypeName(datarow1(intfieldcounter)))
.Append("</font>")
.Append("<br>value:")
.Append(datarow1(intfieldcounter))
.Append("<br><br>")
End With
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
Next
intRowcounter += 1
Next
logActivity(strTask, "Xray", sbXray.ToString())
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Datatable_ToPage(ByRef objbnd As Object, ByVal strDtName As String)
Dim strTask As String = "Xray_Datatable_ToPage"
Try
'plcXray.controls.add(new literalcontrol("TypeName=" & typename(objBnd) & "<br>"))
Dim dg1 As DataGrid
plcXray.Controls.Add(New LiteralControl("<hr>"))
Select Case TypeName(objbnd)
Case "DataTable"
Dim dtTemp As DataTable = objbnd
If dtTemp.Rows.Count = 0 Then
plcXray.Controls.Add(New LiteralControl(strDtName & " IS EMPTY<br>"))
Exit Sub
End If
Case Else
LogHint(strTask, "typename=" & TypeName(objbnd) & " Non Bindable object passed to Xray_DataTableToPage")
Exit Sub
End Select
plcXray.Controls.Add(New LiteralControl(strDtName & "<br>"))
dg1 = New DataGrid
dg1.HeaderStyle.BackColor = ColorTranslator.FromHtml("#aaaadd")
dg1.DataSource = objbnd
dg1.DataBind()
plcXray.Controls.Add(dg1)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_HashTable(ByVal p1 As Hashtable, ByVal p2HashName As String)
Dim strTask As String = "Xray_HashTable"
If bolXrayToPage_ Then
XRay_HashTable_ToPage(p1, p2HashName)
Exit Sub
End If
logActivity("xray", strTask, p2HashName & " count=" & p1.Count())
Dim d As DictionaryEntry
For Each d In p1
logActivity("xray", strTask, p2HashName & "(""" & d.Key & """)=" & d.Value)
Next d
End Sub
Private Sub XRay_HashTable_ToPage(ByVal htParm As Hashtable, ByVal strName As String)
Dim strTask As String = "sub XRay_HashTable_ToPage"
Dim dt1 As DataTable
Try
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("Index", GetType(String)))
dt1.Columns.Add(New DataColumn("Value", GetType(String)))
Dim d As DictionaryEntry
For Each d In htParm
Dim dtblrowtemp As DataRow
dtblrowtemp = dt1.NewRow
dtblrowtemp(0) = d.Key
dtblrowtemp(1) = d.Value
dt1.Rows.Add(dtblrowtemp)
Next d
XRay_Datatable_ToPage(dt1, "HashTable named " & strName)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
Private Sub XRay_Object(ByVal p1 As Object, ByVal p2Name As String)
Dim strTask As String = "Xray_Object"
If bolXrayToPage_ Then
' add later
Exit Sub
End If
logActivity(p2Name, "Xray", "typename()=" & TypeName(p1))
End Sub
private function XrayHeading(strNameOfXray,strTypeName) as string
DIM sb1 as new stringbuilder
With Sb1
.append("<hr>Xray of <b><font color='red'>")
.append(strNameOfXray)
.append("</b></font> (type=")
.append(strTypeName)
.append(")<br>")
end with
return sb1.ToString()
end function
sub XRayObject(strParamObjName as string,objParam as object)
XrayObject("XrayObject","application",strParamObjName,objParam)
end sub
sub XRayObject(strParamTaskName as string,strParamTaskLogType as string,strParamObjName as string,objParam as object)
LogActivity(strParamTaskLogType,strParamTaskName,XrayObjectDetails(strParamObjName,objParam))
end sub
private function XrayObjectDetails(strParamObjName as string,objParam as object) as string
Dim sbXray as new stringbuilder
with sbXray
.Append("<table><tr>")
.Append("<td>name</td>")
If TypeOf(objParam) IS system.web.ui.control
.Append("<td bgcolor='lightblue'><b> id </b></td>")
END IF
.Append("<td bgcolor='silver'><b>type</b></td><td>Details</td>")
.Append("<tr>")
.Append("<td>" & strParamObjName & "</td>")
If TypeOf(objParam) IS system.web.ui.control
.Append("<td bgcolor='lightblue'><b>" & ObjParam.id & "</td>")
END IF
.Append("<td bgcolor='silver'><b>" & typename(objParam) & "</td>")
.Append("<td>" & XrayObjectInfo(objParam) & "</td>")
.Append("</tr></table>")
'If TypeOf(objParam) IS system.web.ui.control
' .Append("<br>id => <b>")
' .Append(ObjParam.id)
' .Append("</b>")
' END IF
.Append("<font color='blue'>")
.Append(XrayObjectValue(objParam))
.Append("</font>")
end with
return(sbXray.ToString())
end function
function XRayObjectInfo(objParam as object) as string
dim sbInfo as new stringbuilder
SELECT CASE typename(objParam) ' objParam.GetType.ToString() not working
CASE "System.String","String"
sbInfo.Append("Length=")
sbInfo.Append(objParam.Length())
CASE "System.Collections.Hashtable","HashTable"
sbInfo.Append("Count=")
sbInfo.Append(objParam.Count())
CASE ELSE
return("n/a")
END SELECT
return (sbinfo.ToString())
end function
function XRayObjectValue(objParam as object) as string
DIM sbValue as new stringbuilder
SELECT CASE typename(objParam) ' objParam.GetType.ToString() not working
CASE "System.String","String"
return(server.htmlencode(ObjParam.ToString()))
CASE "System.String[]","String[]"
Dim intarraycounter As Integer = 0
Dim intArrayRowCount as integer=objParam.GetUpperBound(0)
Dim strCell As string
sbValue.Append(XRayFormatHeader())
For intarraycounter = 0 To intArrayRowCount
strCell = objParam(intarraycounter)
with sbValue
.Append(XrayFormatRow(intArrayCounter,strCell))
end with
Next
sbValue.Append(XrayFormatFooter())
return(sbValue.ToString())
CASE "System.Collections.Hashtable","Hashtable"
'TRY
Dim d As DictionaryEntry
sbValue.Append(XRayFormatHeader())
For Each d In objParam
with sbValue
.Append(XrayFormatRow(d.key,d.value))
end with
Next d
sbValue.Append(XrayFormatFooter())
'CATCH exc1 as exception
' sbValue.Append("empty hashtable")
'END TRY
return(sbValue.ToString())
CASE ELSE
' return(ObjParam.ToString())
return(typename(ObjParam))
END SELECT
end function
function XRayFormatRow(p1 as string, p2 as string)
dim sbRow as new stringbuilder
with sbRow
.Append(XrayFormatRowStart())
'.Append(XrayFormatCellStart())
.append("<td bgcolor='silver'>")
.append(p1)
.Append(XrayFormatCellEnd())
.append(XRayFormatCellStart())
.append("<font color='blue'><b>")
.append(p2)
.append("</b></font>")
.append(XrayFormatCellEnd())
.append(XRayFormatRowEnd())
end with
return(sbRow.ToString())
end function
function XrayFormatHeader() as string
return("<table border='0'>")
end function
function XrayFormatFooter() as string
return("</table>")
end function
function XRayFormatCellStart() as string
return("<td>")
end function
function XRayFormatCellEnd() as string
return("</td>")
end function
function XRayFormatRowStart() as string
return("<tr>")
end function
function XRayFormatRowEnd() as string
return("</tr>")
end function
Sub XrayPage(ByVal p1 As System.web.ui.Page)
logActivity("xray", "SUB Xray()", "Page.controls.Count()=" & Page.Controls.Count())
XRay_Controls(p1)
End Sub
Private Sub XRay_Q(ByVal p1 As Queue, ByVal p2Name As String)
Dim strTask As String = "Xray_Q"
If bolXrayToPage_ Then
XRay_Q_ToPage(p1, p2Name)
Exit Sub
End If
logActivity("xray", strTask, p2Name & " count=" & p1.Count())
Dim strQItem As String
Dim intQItemcount As Integer
For Each strQItem In p1
logActivity("xray", strTask, p2Name & "(" & intQItemcount & ")=" & strQItem.ToString())
intQItemcount += 1
Next
End Sub
Private Sub XRay_Q_ToPage(ByVal QParm As Queue, ByVal strName As String)
Dim strTask As String = "sub XRay_Q_ToPage"
Dim dt1 As DataTable
Try
dt1 = New DataTable
dt1.Columns.Add(New DataColumn("Index", GetType(String)))
dt1.Columns.Add(New DataColumn("Value", GetType(String)))
Dim strQItem As String
Dim intQItemcount As Integer
For Each strQItem In QParm
Dim dtblrowtemp As DataRow
dtblrowtemp = dt1.NewRow
dtblrowtemp(0) = "(" & intQItemcount & ")"
dtblrowtemp(1) = strQItem.ToString()
dt1.Rows.Add(dtblrowtemp)
intQItemcount += 1
Next
plcXray.Controls.Add(New LiteralControl(""))
XRay_Datatable_ToPage(dt1, "Que named " & strName)
Catch ex1 As Exception
LogException(strTask, ex1)
Finally
End Try
End Sub
private sub Xray_Request()
WITH System.Web.HttpContext.Current
Xray(.request.AcceptTypes, "request.AcceptTypes")
Xray(.request.ApplicationPath, "request.ApplicationPath")
Xray(.request.Browser, "request.Browser")
Xray(.request.ClientCertificate, "request.ClientCertificate")
Xray(.request.ContentEncoding, "request.ContentEncoding")
Xray(.request.ContentLength, "request.ContentLength")
Xray(.request.ContentType, "request.ContentType")
Xray(.request.Cookies, "request.Cookies")
Xray(.request.CurrentExecutionFilepath, "request.CurrentExecutionFilepath")
Xray(.request.Filepath, "request.FilePath")
Xray(.request.Files, "request.Files")
Xray(.request.Filter, "request.Filter")
Xray(.request.Form, "request.Form")
Xray(.request.Headers, "request.Headers")
Xray(.request.HTTPMethod, "request.HTTPMethod")
Xray(.request.InputStream, "request.InputStream")
Xray(.request.IsAuthenticated, "request.IsAuthenticated")
Xray(.request.IsSecureConnection, "request.IsSecureConnection")
' todo
' Argument not specified for parameter 'key' of 'Public ReadOnly Default Property Item(key As String) As String'
' Xray(.request.Item, "request.item")
Xray(.request.Params, "request.Params")
Xray(.request.PathInfo, "request.PathInfo")
Xray(.request.PhysicalApplicationPath, "request.PhysicalApplicationPath")
Xray(.request.PhysicalPath,"request.PhysicalPath")
Xray(.request.QueryString, "request.QueryString")
Xray(.request.RawURL, "request.RawURL")
Xray(.request.RequestType, "request.RequestType")
Xray(.request.ServerVariables, "request.ServerVariables")
Xray(.request.TotalBytes, "request.TotalBytes")
Xray(.request.Url, "request.Url")
Xray(.request.UrlReferrer, "request.UrlReferrer")
Xray(.request.UserAgent, "request.UserAgent")
Xray(.request.UserHostAddress, "request.UserHostAddress")
Xray(.request.UserHostName, "request.UserHostName")
Xray(.request.UserLanguages, "request.UserLanguages")
END WITH
end sub
Private Sub XRay_SortedList(ByVal p1 As SortedList, ByVal p2Name As String)
' TODO: tracetopage
Dim strTask As String = "Xray_SortedArray"
logActivity("xray", strTask, p2Name & " count=" & p1.Count())
Dim d As DictionaryEntry
For Each d In p1
logActivity("xray", strTask, p2Name & "(""" & d.Key & """)=" & d.Value)
Next d
End Sub
Private Sub XRay_Stack(ByVal p1 As Stack, ByVal p2Name As String)
' TODO: tracetopage
logActivity("xray", "SUB XRay_Stack", p2Name & " count=" & p1.Count())
Dim enumtemp As IEnumerator = p1.GetEnumerator
Do While enumtemp.MoveNext
logActivity("xray", "SUB XRay_Stack", p2Name & "=" & enumtemp.Current & "")
Loop
End Sub
Private Sub Xray_String(ByVal p1 As Object, ByVal p2 As String)
If bolXrayToPage_ Then
plcXray.Controls.Add(New LiteralControl(XrayHeading(p2,"string; length=" & p1.length) & strToScreen(p1)))
Else
logActivity(p2, "Xray", "Length=" & p1.length() & ";<br>value=" & server.htmlencode(p1))
End If
End Sub
Private Sub XRay_UB()
Dim strTask As String = "Xray_UB"
' don't forget SCC_ guys
'Xray(strLogFileName_,"strLogFileName")
Xray(BolAdvice_, "BolAdvice_")
Xray(bolCache_, "bol_Cache")
Xray(bolErrEmail_, "bolErrMail_")
Xray(bolErrFriendly_, "fix")
Xray(bolErrHide_, "bolErrHide_")
Xray(bolErrIgnoreNext_, "bolErrIgnoreNext_")
Xray(bolErrNullNestedIgnore_, "bolErrNullNestedIgnore_")
Xray(bolErrRaw_, "bolErrorRaw_")
Xray(bolErrThrowBack_, "bolErrorThrowBack_")
Xray(bolErrorDetails_, "bolErrorDetails")
Xray(BolHints_, "BolHints_")
Xray(bolLogCacheHitMiss_, "bolLogCacheHitMiss")
Xray(bolLogDbg_, "bolLogDbg")
Xray(bolLogSQLShow_, "bolLogSQLShow")
Xray(bolLogSQLreturn_, "bolLogSQLreturn_")
Xray(bolLogSensitive_, "bolLogSensitive_")
Xray(bolLogUBFlow_, "bolLogUBFlow")
Xray(bolLogWarning_, "bolLogWarning")
Xray(bolMessages_, "bolMessages")
Xray(bolSuperTraceToTraceStream_, "bolSuperTraceToTraceStream_")
Xray(bolSuperTrace_, "bolSuperTrace_")
Xray(bolXrayOn_, "bolXrayOn_")
Xray(bolXrayToPage_, "bolXrayToPage_")
Xray(dsXray, "dsXray")
Xray(errorCountGlobal_, "errorCountGlobal")
Xray(errorCount_, "errorCount")
Xray(errorOccuredGlobal_, "ErrorOccuredGlobal")
Xray(errorOccured_, "errorsOccured_")
Xray(intCacheMinutes_, "intCacheMinutes_")
Xray(intCacheSeconds_, "intCacheSeconds_")
Xray(intReaderUnClosedCount, "intReaderUnClosedcount")
Xray(objNull_, "objNull")
Xray(plcException_, "plcException_")
Xray(plcXray_, "plcXray")
Xray(strAmazonDevToken_, "strAmazonDevToken_")
Xray(strAmazonPromoCode_, "strAmazonPromoCode")
Xray(strErrMessage_, "strErrMessage_")
Xray(strMailErrorSubject_, "strMailErrorSubject")
Xray(strMailErrorsTo_, "strMailErrorsTo")
Xray(strMailSmtpServer_, "strMailSmtpServer_")
Xray(strSuperTraceHide_, "strSuperTrace_")
Xray(strSuperTraceShow_, "strSuperTraceShow_")
Xray(strVersion, "strVersion")
End Sub
Private Sub XRay_XML(ByVal p1FileName As String, ByVal p2Name As String)
' TODO: tracetopage
Dim strtask As String = "SUB Xray_XML"
Dim dtTemp As DataTable
Try
LogTaskStart(strtask)
dtTemp = XMLToDataTable(p1FileName)
Xray(dtTemp, " XML File named " & p1FileName)
LogTaskEnd(strtask)
Catch ex1 As Exception
LogException(strtask, ex1)
Finally
End Try
End Sub
private sub DataTableAddIDColumn(ByRef dtParm as DataTable)
with dtParm
.Columns.Add(New DataColumn("ID", GetType(Integer)))
.Columns(0).AutoIncrementSeed = 1
.Columns(0).AutoIncrementStep = 1
.Columns(0).AutoIncrement = True
end with
end sub
Function LumberJackLogsCreate() as DataSet
Dim dtCurrent as DataTable
Dim dsTemp As New DataSet
Dim dtLumberJackMain As New DataTable("LumberJackMain")
dtCurrent=dtLumberJackMain
Call DataTableAddIDcolumn(dtCurrent)
With dtCurrent
.Columns.Add(New DataColumn("RecordType", GetType(String)))
.Columns.Add(New DataColumn("Name", GetType(String)))
.Columns.Add(New DataColumn("Details", GetType(String)))
.Columns.Add(New DataColumn("DetailsKey", GetType(Integer)))
.Columns.Add(New DataColumn("UBVersion", GetType(Decimal)))
.Columns.Add(New DataColumn("EventTickCount", GetType(Decimal)))
.Columns.Add(New DataColumn("Elapsed", GetType(Decimal)))
End With
dsTemp.Tables.Add(dtCurrent)
Dim dtLumberJackDetails As New DataTable("LumberJackDetails")
dtCurrent=dtLumberJackDetails
Call DataTableAddIDcolumn(dtCurrent)
With dtCurrent
.Columns.Add(New DataColumn("Value", GetType(Object)))
.Columns.Add(New DataColumn("CheckSum", GetType(String)))
.Columns.Add(New DataColumn("Changed", GetType(Boolean)))
End With
dsTemp.Tables.Add(dtCurrent)
Dim dtLumberJackRecordTypes As New DataTable("LumberJackRecordTypes")
dtCurrent=dtLumberJackRecordTypes
Call DataTableAddIDcolumn(dtCurrent)
With dtCurrent
.Columns.Add(New DataColumn("RecordTypeName", GetType(String)))
End With
dsTemp.Tables.Add(dtCurrent)
Dim dtLumberJackLabels As New DataTable("LumberJackLabels")
dtCurrent=dtLumberJackLabels
Call DataTableAddIDcolumn(dtCurrent)
With dtCurrent
.Columns.Add(New DataColumn("LabelName", GetType(String)))
End With
dsTemp.Tables.Add(dtCurrent)
Dim dtLumberJackLabelsRelate As New DataTable("LumberJackLabelsRelate")
dtCurrent=dtLumberJackLabelsRelate
Call DataTableAddIDcolumn(dtCurrent)
With dtCurrent
.Columns.Add(New DataColumn("KeyLumberJackMain", GetType(Integer)))
.Columns.Add(New DataColumn("KeyLumberJackLabels", GetType(Integer)))
End With
dsTemp.Tables.Add(dtCurrent)
return (dsTemp)
end function
Function XrayDataSetCreate() As DataSet
dim strTask as string="XrayDataSetCreate"
Dim dsTemp As New DataSet
Dim dtCurrent as DataTable
TRY
Dim dtSuperTrace As New DataTable("SuperTrace")
Call DataTableAddIDcolumn(dtSuperTrace)
With dtSuperTrace
.Columns.Add(New DataColumn("Caller", GetType(String)))
.Columns.Add(New DataColumn("LogType", GetType(String)))
.Columns.Add(New DataColumn("EventDescription", GetType(String)))
.Columns.Add(New DataColumn("EventTickCount", GetType(Decimal))) ' kkk
.Columns.Add(New DataColumn("Elapsed", GetType(Decimal)))
End With
dsTemp.Tables.Add(dtSuperTrace)
Dim dtSuperTraceSummary As New DataTable("SuperTraceSummary")
Call DataTableAddIDcolumn(dtSuperTraceSummary)
With dtSuperTraceSummary
.Columns.Add(New DataColumn("Item", GetType(String)))
.Columns.Add(New DataColumn("ItemCount", GetType(Integer)))
.Columns.Add(New DataColumn("ItemType", GetType(String)))
.Columns.Add(new DataColumn("Caller",GetType(String)))
.Columns.Add(New DataColumn("ItemDescription", GetType(String)))
.Columns.Add(New DataColumn("ItemElapsedPretty", GetType(Decimal)))
.Columns.Add(New DataColumn("ItemElapsed", GetType(Decimal)))
.Columns.Add(New DataColumn("ItemChecksum", GetType(String)))
' dtSuperTraceSummary fields
' Item,ItemCount,ItemType,ItemDescription,ItemElapsedPretty,
' ItemElapsed,ItemCheckSum
End With
dsTemp.Tables.Add(dtSuperTraceSummary)
Dim dtErrors As New DataTable("Errors")
Call DataTableAddIDcolumn(dtErrors)
With dtErrors
.Columns.Add(New DataColumn("Caller", GetType(String)))
.Columns.Add(New DataColumn("ExceptionType", GetType(String)))
.Columns.Add(New DataColumn("HelpLink", GetType(String)))
.Columns.Add(New DataColumn("Message", GetType(String)))
.Columns.Add(New DataColumn("StackTrace", GetType(String)))
.Columns.Add(New DataColumn("TargetSite", GetType(String)))
' ToString is just alamgam of above
End With
dsTemp.Tables.Add(dtErrors)
Dim dtHints As New DataTable("Hints")
Call DataTableAddIDcolumn(dtHints)
With dtHints
.Columns.Add(New DataColumn("Caller", GetType(String)))
.Columns.Add(New DataColumn("HintNum", GetType(String)))
.Columns.Add(New DataColumn("Hint", GetType(String)))
End With
dsTemp.Tables.Add(dtHints)
Dim dtAdvice As New DataTable("Advice")
Call DataTableAddIDcolumn(dtAdvice)
With dtAdvice
.Columns.Add(New DataColumn("Caller", GetType(String)))
.Columns.Add(New DataColumn("Advice", GetType(String)))
End With
dsTemp.Tables.Add(dtAdvice)
Dim dtMessages As New DataTable("Messages")
Call DataTableAddIDcolumn(dtMessages)
With dtMessages
.Columns.Add(New DataColumn("Caller", GetType(String)))
.Columns.Add(New DataColumn("Type", GetType(String)))
.Columns.Add(New DataColumn("Message", GetType(String)))
End With
dsTemp.Tables.Add(dtMessages)
CATCH exc1 as exception
LogException(strTask,exc1)
END TRY
Return (dsTemp)
End Function
Function XrayDataSetForDisplay() As String
' Used when we can only response.write and NOT use DataGrids
Dim sbMessage As New StringBuilder
' SuperTrace
If dsXray.Tables(0).Rows.Count > 0 Then
Dim datarow1 As DataRow
For Each datarow1 In dsXray.Tables(2).Rows
With sbMessage
.Append("<b>ID</b>=")
.Append(datarow1(0))
.Append("<br>")
.Append("<b>EventCaller</b>=")
.Append(datarow1(1))
.Append("<br>")
.Append("<b>EventCategory</b>=")
.Append(datarow1(2))
.Append("<br>")
.Append("<b>EventDescription</b>=")
.Append(datarow1(3))
.Append("<br>")
.Append("<b>EventTickcount</b>=")
.Append(datarow1(4))
.Append("<br>")
.Append("<b>Elapsed</b>=")
.Append(datarow1(5))
.Append("<br>")
End With
Next
sbMessage.Append("<hr>")
End If
' Raw Errors
If dsXray.Tables(1).Rows.Count > 0 Then
Dim datarow1 As DataRow
For Each datarow1 In dsXray.Tables(1).Rows
With sbMessage
.Append("<b>ID</b>=")
.Append(datarow1(0))
.Append("<br>")
.Append("<b>Caller</b>=")
.Append(datarow1(1))
.Append("<br>")
.Append("<b>ExceptionType</b>=")
.Append(datarow1(2))
.Append("<br>")
.Append("<b>HelpLink</b>=")
.Append(datarow1(3))
.Append("<br>")
.Append("<b>Message</b>=")
.Append(datarow1(4))
.Append("<br>")
.Append("<b>StackTrace</b>=")
.Append(datarow1(5))
.Append("<br>")
.Append("<b>TargetSite</b>=")
.Append(datarow1(6))
.Append("<br>")
End With
Next
sbMessage.Append("<hr>")
End If
' Hints
If dsXray.Tables(2).Rows.Count > 0 Then
Dim datarow1 As DataRow
For Each datarow1 In dsXray.Tables(2).Rows
With sbMessage
.Append("<b>ID</b>=")
.Append(datarow1(0))
.Append("<br>")
.Append("<b>Caller</b>=")
.Append(datarow1(1))
.Append("<br>")
.Append("<b>Hint</b>=")
.Append(datarow1(2))
.Append("<br>")
End With
Next
sbMessage.Append("<hr>")
End If
Return (sbMessage.ToString())
End Function
End Class
End Namespace
|