<%
'****************************************************************************
' Diagnostic Tool for VP-ASP Shopping Cart
' Can be used to test database access and mail access
' Version 5.00 June 3, 2003 Free Version
'*****************************************************************************
Const LangTestHeader="VP-ASP Diagnostics 5.00"
const LangDatabaseTest="Test Database"
const LangMailTest="Test Mail"
Const LangTestConfig="Test your current or new configuration"
Const LangTestChanges="Changes are not automatically updated in shop$config.asp"
Const LangTestMailfail=" is probably not installed on this system"
Const LangTestMailInfo="This is test from VP-ASP using "
Const LangTestWriteFail="Database cannot be written"
Const LangTestReadFail="Database cannot be read"
Const LangTestWriteOK="Database can be written"
Const LangTestVerify="Verify that the database is at the physical location in the open message"
Const LangTestPerFail="Database Permissions are not correct"
Const LangTestRead="Database Read"
Const LangTestWrite="Database Write"
Const LangTestReadOK="Database can be read"
Const LangTestDirectory="Verify that the database is in a folder that has both read and write access"
Const LangTestPer="Database Permissions"
Const LangTestPerOK="Database permissions tested OK"
Const LangTestReadFAQ="Read the FAQ on our web site regarding permission for the anonymous user IUSR"
Const LangTestSummary="No problems reading or writing database "
Const LangTestFileRead="Test file read"
'
dim sAction
Dim strbody
Dim strSubject
Dim strFrom
dim strFromemail
dim currentURL
Dim Fieldnames(30)
Dim Fieldvalues(30)
Dim fieldname
Dim Fieldvalue
Dim Fieldcount
Dim Serrors
Dim curTest
Dim PrevTest
Dim errorCount
dim my_system
dim my_from
dim my_fromAddress
dim my_subject
dim my_to
dim my_toAddress
dim body
dim htmlformat
Dim Msg
Dim mailtype
Dim mailer
Dim Emailformat
dim tablerowcolor
dim initapp
'
If Getconfig("init")="No" then
SetConfig "init",""
end if
sAction=request("database")
if saction<>"" then
saction="DATABASE"
else
saction=request("mail")
if saction<>"" then
sACTION="MAIL"
else
saction=request("Fileread")
if saction<>"" then
sACTION="READFILE"
end if
end if
end if
currentURL="diag_dbtest.asp"
dbtable="tbluser"
dbfield="flddatabase"
GetFieldNames
GetFieldvalues
if saction="" then
SpecPageHeader
DisplayForm
specPageTrailer
else
ProcessForm
WriteDiagnosticHeader
RunTests
WriteDiagnosticTrailer
end if
Sub DisplayForm
response.write "")
response.write ""
end sub
Sub FormatRow (fieldname,fieldvalue, sRowColor)
If Fieldname<>"xFont" then
Response.Write(tablerow & tablecolumn & trim(fieldname) & tablecolumnend & tablecolumn & "" & tablecolumnend & tablerowend)
else
Response.Write(tablerow & tablecolumn & trim(fieldname) & tablecolumnend & tablecolumn & Fieldvalue & tablecolumnend & tablerowend)
end if
end sub
Sub ProcessForm
dim strname
dim strvalue
For Each key in Request.Form
strname = key
strvalue = Request.Form(key)
SetSess strname, strvalue
'debugwrite key & "=" & strvalue
Next
end sub
'
Sub GetFieldnames
Fieldnames(0)="xDatabase"
Fieldnames(1)="xDblocation"
Fieldnames(2)="xdatabasetype"
Fieldnames(3)="xEmail"
Fieldnames(4)="xEmailName"
Fieldnames(5)="xEmailSubject"
Fieldnames(6)="xEmailSystem"
Fieldnames(7)="xEmailType"
Fieldnames(8)="xOrdernumber"
fieldcount=8
end sub
'
Sub GetFieldvalues
Dim strvalue
strvalue=GetSess(fieldnames(0))
if strvalue="" then
SetDefaultValues
else
for i = 0 to fieldcount
fieldvalues(i)=Getsess(fieldnames(i))
next
strbody=GetSess("body")
end if
end sub
Sub SetDefaultValues
Fieldvalues(0)=xdatabase
Fieldvalues(1)=xdblocation
Fieldvalues(2)=xdatabasetype
Fieldvalues(3)=getconfig("xemail")
Fieldvalues(4)=getconfig("xemailname")
Fieldvalues(5)=getconfig("xemailsubject")
Fieldvalues(6)=getconfig("xEmailsystem")
Fieldvalues(7)=getconfig("xEmailType")
Fieldvalues(8)=xordernumber
end sub
Sub RunTests
ErrorCount=0
if saction="MAIL" then
RunMailtests
exit sub
end if
if saction="DATABASE" then
RunDatabaseTests
exit sub
end if
if saction="READFILE" then
RunFileReadTests
exit sub
end if
end sub
Sub RunDatabaseTests
dim dbc
dim testsql
dim testrs
dim rstemp
Serrors=""
Shopinit
SetSess "db",request("xdatabase")
SetSess "dblocation",request("xdblocation")
SetSess "xdatabasetype", request("xdatabasetype")
databasetype=GetSess("xdatabasetype")
database=GetSess("db")
curTest="Database Open"
setsess "diagnostic","Yes"
DiagnosticOpen dbc, database, databasetype
setsess "diagnostic",""
on error resume next
curTest=LangTestRead
testsql = "select * from " & dbtable
Set testrs = dbc.Execute(Testsql)
fieldvalue=testrs(dbfield)
if err.number > 0 then
addError "" & LangTestReadFail & ""
addError LangTestVerify
CheckMicrosoftError dbc
Adderror GetSess("dbc")
AddError "Microsoft Message " & GetSess("Openerror")
else
addInfo LangTestReadOk
end if
testrs.close
curTest=LangTestWrite
if Getconfig("xmysql")="Yes" or ucase("xdatabasetype")="MYSQL" then
Testsql="Update " & dbtable & " set " & dbfield & "='shopdbtest'"
dbc.execute(testsql)
else
Set rstemp = Server.CreateObject("ADODB.Recordset")
rstemp.open dbtable, dbc, 1, 3
rstemp.update
rstemp(dbfield)="shopdbtest"
rstemp.update
end if
If err.number > 0 then
addError "" & LangTestWriteFail & ""
addError LangTestDirectory
AddError "Microsoft Message " & GetSess("Openerror")
else
If dbc.errors.count> 0 then
addError "" & langtestwritefail & ""
addError LangTestDirectory
AddError "Microsoft Message " & GetSess("Openerror")
CheckMicrosoftError dbc
else
addInfo LangTestwriteOK
end if
end if
'
curTest=LangTestPer
dim mysql
mysql="select * from products"
Set rstemp = Server.CreateObject("ADODB.RecordSet")
rstemp.cursorlocation=aduseclient
If Getconfig("xmysql")="Yes" or ucase("xdatabasetype")="MYSQL" then
else
rstemp.cachesize=5
end if
rstemp.Open MYSQL,dbc,adOpenKeyset,adLockReadOnly, adCmdText
If err.number > 0 then
addError "" & LangTestPerFail & ""
addError LangTestReadFAQ
else
If dbc.errors.count> 0 then
addError "" & LangTestWriteFail & ""
addError LangTestVerify
CheckMicrosoftError dbc
else
addInfo LangTestPerOK
end if
end if
dbc.close
set dbc=nothing
curTest="Summary"
if Errorcount=0 Then
addinfo errorinfostart & LangTestSummary & errorinfoend
end if
end sub
'
Sub addError (msg)
if curtest<>PrevTest then
Response.write "
" & curtest & "
"
else
Response.write "
"
end if
Response.write "
" & msg & "
"
errorcount=errorCount+1
PrevTest=CurTest
end sub
Sub addInfo (msg)
if curtest<>PrevTest then
Response.write "
" & curtest & "
"
else
Response.write "
"
end if
Response.write "
" & msg & "
"
PrevTest=CurTest
end sub
Sub WriteDiagnosticHeader
specPageHeader
Response.Write("
")
End Sub
'
Sub WriteDiagnosticTrailer
Response.Write("
")
specPageTrailer
End Sub
'
Sub RunMailTests
shopwriteerror "Mailing is not supported in this version"
exit sub
'****************************************************
' Run tests with user supplied mail, if it fails try CDONTS
'****************************************************
Dim description
dim acount
htmlformat=getsess("Xemailformat")
htmlformat=ucase(htmlformat)
my_toaddress = GetSess("xEmail")
my_to=GetSess("xEmailName")
my_from="VP-ASP Diagnostic Test"
my_Fromaddress=GetSess("xEmail")
my_system=GetSess("xEmailSystem") ' imail2.innerhost.com'
mailtype=Request("xEmailType") ' ASPmail, CDONTS, JMail, ASPEMAIL
my_subject=GetSess("xEmailsubject")
body=LangTestMailInfo & mailtype & " at " & date & " " & Time()
If htmlformat="HTML" then
addhtml body
end if
'debugwrite server.htmlencode(body)
CurTest="Mailing using " & mailtype
SetSess "mailerror",""
acount=0
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,htmlformat,my_attachment,acount
If GeTsess("mailerror")="" then
AddInfo "Mail OK"
exit sub
end if
AddError "" & mailtype & LangTestMailFail & " " & Getsess("Mailerror")
end sub
'************
Sub CheckMicrosoftError (dbc)
dim counter
If dbc.errors.count> 0 then
AddError "Error count=" & dbc.errors.count
For counter= 0 to dbc.errors.count-1
AddError "Error #" & dbc.errors(counter).number
addError "Error desc. -> " & dbc.errors(counter).description
next
End If
end sub
Sub AddHtml(body)
dim htmlstuff
htmlstuff="" & langTestHeader & ""
htmlstuff=htmlstuff & "
"
body=htmlstuff & htmlformat & " " & Body & "
"
body=body & ""
end sub
Sub RunFileReadTests
on error resume next
dim whichfile, fsobj, recordobj
whichfile=server.mappath("license.txt")
CurTest="Reading " & whichfile
set fsObj = Server.CreateObject("Scripting.FileSystemObject")
set RecordObj= fsObj.OpenTextFile(whichfile, 1, False)
If Err.number=0 then
AddError "Read successful"
else
adderror err.description
end if
recordobj.close
set recordobj=nothing
set fsoobj=nothing
end sub
sub Specpageheader
%>
VP-ASP Shopping Cart 5.00 Diagnostic
