<%
'###########################################################
'## COPYRIGHT (C) 2002-2005, Metasun Software Corp.
'##
'## For licensing details, lease read the license.txt file
'## included with MetaTraffic or located at:
'## http://www.metasun.com/products/metatraffic/license.asp
'##
'## All copyright notices regarding MetaTraffic
'## must remain intact in the scripts and in the
'## outputted HTML. All text and logos with
'## references to Metasun or MetaTraffic must
'## remain visible when the pages are viewed on
'## the internet or intranet.
'##
'## For support, please visit http://www.metasun.com
'## and use the support forum.
'###########################################################
%>
<% 'Option Explicit %>
<%
Dim intMTSiteName : intMTSiteName = 0
Dim intMTSiteUrl : intMTSiteUrl = 1
Dim intMTEnableLog : intMTEnableLog = 2
Dim intMTIPExclude : intMTIPExclude = 3
Dim intMTQuerystringFilter : intMTQuerystringFilter = 4
Dim intMTDefaultDoc : intMTDefaultDoc = 5
Dim intMTQuerystringName : intMTQuerystringName = 6
Dim intMTSiteAliases : intMTSiteAliases = 7
Dim intMTSessionDuration : intMTSessionDuration = 8
Dim intMTShowGraph : intMTShowGraph = 9
Dim intMTTruncateUrls : intMTTruncateUrls = 10
Dim intMTShortDateFormat : intMTShortDateFormat = 11
Dim intMTLongDateFormat : intMTLongDateFormat = 12
Dim intMTTimeOffset : intMTTimeOffset = 13
Dim aryMTConfig(13)
aryMTConfig(intMTSiteName) = "Insert Site Name Here"
aryMTConfig(intMTSiteUrl) = "http://www.gardenofe.com"
aryMTConfig(intMTEnableLog) = -1
aryMTConfig(intMTIPExclude) = ""
aryMTConfig(intMTQuerystringFilter) = ""
aryMTConfig(intMTDefaultDoc) = ""
aryMTConfig(intMTQuerystringName) = "mtc"
aryMTConfig(intMTSiteAliases) = ""
aryMTConfig(intMTSessionDuration) = 60
aryMTConfig(intMTShowGraph) = -1
aryMTConfig(intMTTruncateUrls) = -1
aryMTConfig(intMTShortDateFormat) = "mm/dd/yyyy"
aryMTConfig(intMTLongDateFormat) = "mmmm dd yyyy"
aryMTConfig(intMTTimeOffset) = 0
%>
<%
Dim aryMTDB(5), objConn
aryMTDB(0) = "MSSQL"
aryMTDB(1) = "192.168.99.188"
aryMTDB(2) = "traffic"
aryMTDB(3) = "gofe"
aryMTDB(4) = "garden1."
aryMTDB(5) = "uhc_"
%>
<%
'###########################################################
'## COPYRIGHT (C) 2002-2005, Metasun Software Corp.
'##
'## For licensing details, lease read the license.txt file
'## included with MetaTraffic or located at:
'## http://www.metasun.com/products/metatraffic/license.asp
'##
'## All copyright notices regarding MetaTraffic
'## must remain intact in the scripts and in the
'## outputted HTML. All text and logos with
'## references to Metasun or MetaTraffic must
'## remain visible when the pages are viewed on
'## the internet or intranet.
'##
'## For support, please visit http://www.metasun.com
'## and use the support forum.
'###########################################################
Function FormatDatabaseDate(datDate)
Dim datDateTemp, datTimeTemp, strDateFormat, strTimeFormat
Dim datTemp, strSeparator, datDatabaseDate, datDatabaseTime, datFull
' SET DATABASE DATE AND TIME FORMATS
strDateFormat = "YYYY-MM-DD"
strTimeFormat = "HH:MM:SS"
' MAKE SURE FORMAT IS ALL UPPERCASE
datDateTemp = UCase(strDateFormat)
datTimeTemp = UCase(strTimeFormat)
' BEGIN REPLACING TOKENS ON DATE
datDateTemp = Replace(datDateTemp, "DD", FormatDatePart(Day(datDate)))
datDateTemp = Replace(datDateTemp, "MMMM", MonthName(Month(datDate), False))
datDateTemp = Replace(datDateTemp, "MMM", MonthName(Month(datDate), True))
datDateTemp = Replace(datDateTemp, "MM", FormatDatePart(Month(datDate)))
datDateTemp = Replace(datDateTemp, "YYYY", Year(datDate))
datDateTemp = Replace(datDateTemp, "YY", Right(Year(datDate), 2))
' BEGIN REPLACING TOKENS ON TIME
datTimeTemp = Replace(datTimeTemp, "HH", FormatDatePart(DatePart("h", datDate)))
datTimeTemp = Replace(datTimeTemp, "MM", FormatDatePart(DatePart("n", datDate)))
datTimeTemp = Replace(datTimeTemp, "SS", FormatDatePart(DatePart("s", datDate)))
If aryMTDB(0) = "MSACCESS" Then
strSeparator = "#"
Else
strSeparator = "'"
End If
' BUILD FINAL DATE FORMAT
datTemp = strSeparator & datDateTemp & " " & datTimeTemp & strSeparator
FormatDatabaseDate = datTemp
End Function
Function FormatDatePart(datPart)
Dim datTemp
If Len(datPart) = 1 Then
datTemp = "0" & datPart
Else
datTemp = datPart
End If
FormatDatePart = datTemp
End Function
Function FormatDatabaseString(strString, intLength)
Dim strTemp
strTemp = "'" & Replace(Left(strString, intLength), "'", "''") & "'"
FormatDatabaseString = strTemp
End Function
Function Authenticate(blnRequireAdmin, strTablePrefix)
Dim blnAdmin, intAuth : intAuth = 0
Dim strUsername : strUsername = Request.Cookies("metatraffic")("username")
Dim strPassword : strPassword = Request.Cookies("metatraffic")("password")
If strUsername <> "" Then
Dim strSql : strSql = "SELECT u_admin " &_
"FROM " & strTablePrefix & "Users " &_
"WHERE u_username = " & FormatDatabaseString(strUsername, 20) & " " &_
"AND u_password = " & FormatDatabaseString(strPassword, 20)
Dim rsAuth : Set rsAuth = Server.CreateObject("ADODB.Recordset")
rsAuth.Open strSql, objConn, 1, 2, &H0001
If Not rsAuth.Eof Then
blnAdmin = CBool(rsAuth(0))
If blnRequireAdmin = True Then
If blnAdmin = True Then
intAuth = 1
Else
intAuth = -1
End If
Else
intAuth = 1
End If
End If
rsAuth.Close : Set rsAuth = Nothing
Else
intAuth = -2
End If
If intAuth <> 1 Then
Response.Redirect "login.asp?action=failure&code=" & intAuth
End If
Authenticate = blnAdmin
End Function
Sub CreateDatabaseConnection(intError)
Dim strSql, strConn, strLocationType, strTemp, intPort, aryServer
Dim blnPort : blnPort = False
If InStr(aryMTDB(1), ":") > 0 And aryMTDB(0) <> "MSACCESS" Then
aryServer = Split(aryMTDB(1), ":")
aryMTDB(1) = aryServer(0)
intPort = Int(aryServer(1))
If intPort > 0 Then
blnPort = True
End If
End If
If aryMTDB(0) = "MSSQL" Then
strConn = "DRIVER={SQL Server};" &_
"SERVER=" & aryMTDB(1) & ";"
If blnPort = True Then
strConn = strConn & "PORT=" & intPort & ";"
End If
strConn = strConn & "DATABASE=" & aryMTDB(2) & ";" &_
"UID=" & aryMTDB(3) & ";" &_
"PWD=" & aryMTDB(4) & ";" &_
"Provider=MSDASQL.1"
ElseIf aryMTDB(0) = "MYSQL" Then
strConn = "DRIVER={MySQL ODBC 3.51 Driver};" &_
"SERVER=" & aryMTDB(1) & ";"
If blnPort = True Then
strConn = strConn & "PORT=" & intPort & ";"
Else
strConn = strConn & "PORT=3306;"
End If
strConn = strConn & "DATABASE=" & aryMTDB(2) & ";" &_
"UID=" & aryMTDB(3) & ";" &_
"PWD=" & aryMTDB(4) & ";Option=16387"
Else
If Len(aryMTDB(1)) > 2 Then
If Mid(aryMTDB(1), 2, 1) = ":" Or Mid(aryMTDB(1), 1, 2) = "\\" Then
strLocationType = "ABSOLUTE"
Else
strLocationType = "VIRTUAL"
End If
Else
strLocationType = "VIRTUAL"
End If
If strLocationType = "ABSOLUTE" Then
strTemp = aryMTDB(1) & "\" & aryMTDB(2)
Else
strTemp = Server.MapPath(aryMTDB(1) & "/" & aryMTDB(2))
End If
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strTemp
End If
Set objConn = Server.CreateObject("ADODB.Connection")
If intError = 0 Then
objConn.Open strConn
ElseIf intError = 1 Then
On Error Resume Next
objConn.Open strConn
If Err.Number <> 0 Then
Call DisplayDBConnError(Err)
End If
On Error Goto 0
Else
On Error Resume Next
objConn.Open strConn
On Error Goto 0
End If
End Sub
Sub CloseDatabaseConnection()
If IsObject(objConn) Then
objConn.Close : Set objConn = Nothing
End If
End Sub
Function FormatDisplayDate(datDate, strFormat)
Dim datTemp : datTemp = UCase(strFormat)
datTemp = Replace(datTemp, "DDDD", WeekdayName(Weekday(datDate), False))
datTemp = Replace(datTemp, "DDD", WeekdayName(Weekday(datDate), True))
datTemp = Replace(datTemp, "DD", Day(datDate))
datTemp = Replace(datTemp, "MMMM", MonthName(Month(datDate), False))
datTemp = Replace(datTemp, "MMM", MonthName(Month(datDate), True))
datTemp = Replace(datTemp, "MM", Month(datDate))
datTemp = Replace(datTemp, "YYYY", Year(datDate))
datTemp = Replace(datTemp, "YY", Right(Year(datDate), 2))
FormatDisplayDate = datTemp
End Function
Sub DisplayDBConnError(Err)
With Response
.Write("")
.Write("")
.Write("
If you have not setup MetaTraffic yet, go to the ")
.Write("setup page.
")
.Write("
")
.Write("")
End With
Response.End
End Sub
%>
<%
'###########################################################
'## COPYRIGHT (C) 2002-2005, Metasun Software Corp.
'##
'## For licensing details, lease read the license.txt file
'## included with MetaTraffic or located at:
'## http://www.metasun.com/products/metatraffic/license.asp
'##
'## All copyright notices regarding MetaTraffic
'## must remain intact in the scripts and in the
'## outputted HTML. All text and logos with
'## references to Metasun or MetaTraffic must
'## remain visible when the pages are viewed on
'## the internet or intranet.
'##
'## For support, please visit http://www.metasun.com
'## and use the support forum.
'###########################################################
Class MTLog
Private strSql, strExtra, aryConfig, aryDB
Private strDatabaseType, strTablePrefix
Private blnEnableLog, strIPExclude
Private strQuerystringFilter, strDefaultDoc
Private strQuerystringName, strAction, strAmount, sngAmount
Private strOrder, strPageTitle, strFormatDate
Private intTimeOffset
Public Property Let Database(pDatabase)
aryDB = pDatabase
strDatabaseType = aryDB(0)
strTablePrefix = aryDB(5)
End Property
Public Property Let Config(pConfig)
aryConfig = pConfig
blnEnableLog = aryConfig(intMTEnableLog)
strIPExclude = aryConfig(intMTIPExclude)
strQuerystringFilter = aryConfig(intMTQuerystringFilter)
strDefaultDoc = aryConfig(intMTDefaultDoc)
strQuerystringName = aryConfig(intMTQuerystringName)
intTimeOffset = aryConfig(intMTTimeOffset)
End Property
Public Property Let Action(pAction)
strAction = pAction
strAction = Left(Trim(strAction), 20)
End Property
Public Property Let Amount(pAmount)
strAmount = pAmount
strAmount = Trim(strAmount)
If IsNumeric(strAmount) Then
sngAmount = strAmount
Else
sngAmount = 0
End if
End Property
Public Property Let Order(pOrder)
strOrder = pOrder
strOrder = Left(Trim(strOrder), 100)
End Property
Public Property Let PageTitle(pPageTitle)
strPageTitle = pPageTitle
strPageTitle = Left(Trim(strPageTitle), 100)
End Property
Public ActualUrl
Public Sub LogFile(strLogUrl, intLogType, strResolution)
intLogType = CInt(intLogType)
Dim strDateTime : strDateTime = DateAdd("h", intTimeOffset, Now())
Dim strReferrer : strReferrer = Request.ServerVariables("HTTP_REFERER")
Dim strScriptName : strScriptName = Request.ServerVariables("SCRIPT_NAME")
Dim strUserAgent : strUserAgent = Request.ServerVariables("HTTP_USER_AGENT")
Dim strQuerystring : strQuerystring = Request.Querystring
Dim intSessionID : intSessionID = Session.SessionID
Dim strHost : strHost = Request.ServerVariables("REMOTE_HOST")
Dim StrLanguage : strLanguage = Request.ServerVariables("HTTP_ACCEPT_LANGUAGE")
Dim strIPAddress : strIPAddress = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
strIPAddress = FormatIPAddress(strIPAddress)
If strIPAddress = "" Then
strIPAddress = Request.ServerVariables("REMOTE_ADDR")
Else
If IsPrivateIP(strIPAddress) = True Then
If IsPrivateIP(Request.ServerVariables("REMOTE_ADDR")) = False Then
strIPAddress = Request.ServerVariables("REMOTE_ADDR")
End If
End If
End If
If IsIPAddress(strHost) = True Then
strHost = ""
End If
Dim strQuerystringClean
Select Case intLogType
Case 0
Dim strScriptUrl : strScriptUrl = strScriptName
strQuerystringClean = FilterQuerystring(strQuerystring)
If strQuerystringClean <> "" Then
strScriptUrl = strScriptUrl & "?" & strQuerystringClean
End If
Case 1
strScriptName = ExtractScriptName(strLogUrl)
strScriptUrl = strLogUrl
Case 2
strScriptName = ExtractScriptName(strReferrer)
strQuerystring = ExtractQuerystring(strReferrer)
strQuerystringClean = FilterQuerystring(strQuerystring)
strScriptUrl = ExtractScriptName(strReferrer)
If strQuerystringClean <> "" Then
strScriptUrl = strScriptUrl & "?" & strQuerystringClean
End If
strReferrer = strLogUrl
If strDefaultDoc <> "" Then
If Right(strScriptName, 1) = "/" Then
strScriptName = strScriptName & strDefaultDoc
End If
If Right(strScriptUrl, 1) = "/" Then
strScriptUrl = strScriptUrl & strDefaultDoc
ElseIf InStr(strScriptUrl, "/?") > 0 Then
Dim aryScript : aryScript = Split(strScriptUrl, "/?")
If UBound(aryScript) = 1 Then
strScriptUrl = aryScript(0) & "/" & strDefaultDoc & "?" & aryScript(1)
ElseIf UBound(aryScript) = 0 Then
strScriptUrl = aryScript(0) & "/" & strDefaultDoc
End If
End If
End If
End Select
Dim blnLogFile
If strScriptName = "" Then
blnLogFile = False
Else
blnLogFile = True
End If
If blnLogFile = True Then
Dim strPath : strPath = ExtractPath(strScriptName)
Dim strExtension : strExtension = ExtractFileType(strScriptName)
strSql = "SELECT pn_id, pn_url, pn_page, pn_path, pn_extension, pn_label " &_
"FROM " & strTablePrefix & "PageNames " &_
"WHERE pn_url = " & FormatDatabaseString(strScriptUrl, 255)
Dim rsUrl : Set rsUrl = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsUrl.CursorLocation = 3
End If
rsUrl.Open strSql, objConn, 1, 2, &H0001
If rsUrl.Eof Then
rsUrl.AddNew
rsUrl(1) = ProtectInsert(strScriptUrl, 255)
rsUrl(2) = ProtectInsert(strScriptName, 255)
rsUrl(3) = ProtectInsert(strPath, 255)
rsUrl(4) = ProtectInsert(strExtension, 10)
rsUrl(5) = ProtectInsert(strPageTitle, 100)
rsUrl.Update
ElseIf strPageTitle <> "" Then
If rsUrl(5) <> strPageTitle Or IsNull(rsUrl(5)) Then
rsUrl(5) = ProtectInsert(strPageTitle, 100)
rsUrl.Update
End If
End If
Dim intPage : intPage = rsUrl("pn_id")
rsUrl.Close : Set rsUrl = Nothing
Dim intIPNumber : intIPNumber = ConvertIPAddressToLong(strIPAddress)
Dim rsDefinitions : Set rsDefinitions = Server.CreateObject("ADODB.Recordset")
strSql = "SELECT d_id, d_name, d_regexp, d_extra, d_type " &_
"FROM " & strTablePrefix & "Definitions " &_
"ORDER BY d_id ASC"
rsDefinitions.Open strSql, objConn, 0, 1, &H0001
Dim intUserAgent
Dim strRobot : strRobot = MatchDefinition(rsDefinitions, strUserAgent, 3)
If strRobot = "" Then
strSql = "SELECT s_id, s_ip, s_hostname, s_useragent, s_browser, " &_
"s_os, s_language, s_country, s_screenarea " &_
"FROM " & strTablePrefix & "Sessions " &_
"WHERE s_id = " & intSessionID
Dim rsSession : Set rsSession = Server.CreateObject("ADODB.Recordset")
rsSession.Open strSql, objConn, 1, 2, &H0001
If rsSession.Eof Then
Dim strCountry
If IsPrivateIP(strIPAddress) = True Then
strCountry = "00"
Else
strCountry = GetCountry(intIPNumber)
End If
Dim strBrowser : strBrowser = MatchDefinition(rsDefinitions, strUserAgent, 1)
Dim strOS : strOs = MatchDefinition(rsDefinitions, strUserAgent, 2)
strLanguage = CleanLanguage(strLanguage)
intUserAgent = CheckName(2, strUserAgent)
Dim intHost : intHost = CheckName(1, strHost)
Dim intResolution : intResolution = CheckName(3, strResolution)
Dim intBrowser : intBrowser = CheckName(4, strBrowser)
Dim intOs : intOs = CheckName(5, strOs)
rsSession.Addnew
rsSession(0) = intSessionID
rsSession(1) = intIPNumber
rsSession(2) = intHost
rsSession(3) = intUserAgent
rsSession(4) = intBrowser
rsSession(5) = intOs
rsSession(6) = ProtectInsert(strLanguage, 5)
rsSession(7) = ProtectInsert(strCountry, 2)
rsSession(8) = intResolution
rsSession.Update
End If
rsSession.Close : Set rsSession = Nothing
Dim intReferrer : intReferrer = 0
If strReferrer <> "" Then
strSql = "SELECT r_id, r_url, r_rn_id, r_k_id " &_
"FROM " & strTablePrefix & "Referrers " &_
"WHERE r_url = " & FormatDatabaseString(strReferrer, 255)
Dim rsReferrer : Set rsReferrer = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsReferrer.CursorLocation = 3
End If
rsReferrer.Open strSql, objConn, 1, 2, &H0001
If rsReferrer.Eof Then
Dim strReferrerPage : strReferrerPage = ExtractPage(strReferrer)
strSql = "SELECT rn_id, rn_page, rn_host, rn_domain, rn_extension " &_
"FROM " & strTablePrefix & "ReferrerNames " &_
"WHERE rn_page = " & FormatDatabaseString(strReferrerPage, 255)
Dim rsReferrerName : Set rsReferrerName = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsReferrerName.CursorLocation = 3
End If
rsReferrerName.Open strSql, objConn, 1, 2, &H0001
If rsReferrerName.Eof Then
Dim strReferrerHost : strReferrerHost = ExtractHost(strReferrer)
Dim strReferrerDomain : strReferrerDomain = ExtractDomain(strReferrerHost)
Dim strReferrerExtension : strReferrerExtension = ExtractExtension(strReferrerDomain)
rsReferrerName.AddNew
rsReferrerName(1) = ProtectInsert(strReferrerPage, 255)
rsReferrerName(2) = ProtectInsert(strReferrerHost, 255)
rsReferrerName(3) = ProtectInsert(strReferrerDomain, 100)
rsReferrerName(4) = ProtectInsert(strReferrerExtension, 10)
rsReferrerName.Update
End If
Dim intReferrerName : intReferrerName = rsReferrerName(0)
rsReferrerName.Close : Set rsReferrerName = Nothing
Dim intKeywords : intKeywords = 0
If InStr(strReferrer, Request.ServerVariables("SERVER_NAME")) = 0 Then
Dim strSite : strSite = MatchDefinition(rsDefinitions, strReferrer, 4)
If strSite <> "" Then
Dim strKeywordPrefix : strKeywordPrefix = strExtra
Dim strKeywords : strKeywords = ExtractKeywords(strReferrer, strKeywordPrefix)
If strKeywords <> "" Then
Dim intSite : intSite = CheckName(8, strSite)
strSql = "SELECT k_id, k_value, k_site " &_
"FROM " & strTablePrefix & "Keywords " &_
"WHERE k_value = " & FormatDatabaseString(strKeywords, 255) & " " &_
"AND k_site = " & intSite
Dim rsKeywords : Set rsKeywords = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsKeywords.CursorLocation = 3
End If
rsKeywords.Open strSql, objConn, 1, 2, &H0001
If rsKeywords.Eof Then
rsKeywords.AddNew
rsKeywords(1) = ProtectInsert(strKeywords, 255)
rsKeywords(2) = intSite
rsKeywords.Update
End If
intKeywords = rsKeywords("k_id")
rsKeywords.Close : Set rsKeywords = Nothing
End If
End If
End If
rsReferrer.Addnew
rsReferrer(1) = ProtectInsert(strReferrer, 255)
rsReferrer(2) = intReferrerName
rsReferrer(3) = intKeywords
rsReferrer.Update
End If
intReferrer = rsReferrer(0)
rsReferrer.Close : Set rsReferrer = Nothing
If Request.Cookies("mt")("rid") = "" Then
Response.Cookies("mt")("rid") = intReferrer
Response.Cookies("mt").Expires = DateAdd("d", 3650, strDateTime)
End If
End If
rsDefinitions.Close : Set rsDefinitions = Nothing
Dim rsLog : Set rsLog = Server.Createobject("ADODB.Recordset")
strSql = "INSERT INTO " & strTablePrefix & "PageLog (pl_datetime, pl_pn_id, pl_r_id, pl_s_id) VALUES(" &_
FormatDatabaseDate(strDateTime) & ", " &_
intPage & ", " &_
intReferrer & ", " &_
intSessionID & ")"
rsLog.Open strSql, objConn, 0, 2, &H0001
Set rsLog = Nothing
Dim strCampaignCode : strCampaignCode = ExtractCampaignCode(strQuerystring)
strFormatDate = FormatDatabaseDate(strDateTime)
strFormatDate = Mid(strFormatDate, 2, Len(strFormatDate) - 2)
If strCampaignCode <> "" Then
Dim rsCampaign : Set rsCampaign = Server.Createobject("ADODB.Recordset")
strSql = "SELECT cl_datetime, cl_ca_code, cl_s_id " &_
"FROM " & strTablePrefix & "CampaignLog " &_
"WHERE cl_ca_code LIKE " & FormatDatabaseString(strCampaignCode, 20) & " " &_
"AND cl_s_id = " & intSessionID
If strDatabaseType = "MYSQL" Then
rsCampaign.CursorLocation = 3
End If
rsCampaign.Open strSql, objConn, 1, 2, &H0001
If rsCampaign.Eof Then
rsCampaign.AddNew
rsCampaign(0) = strFormatDate
rsCampaign(1) = ProtectInsert(strCampaignCode, 12)
rsCampaign(2) = intSessionId
rsCampaign.Update
End If
rsCampaign.Close : Set rsCampaign = Nothing
If Request.Cookies("mt")("cc") = "" Then
Response.Cookies("mt")("cc") = strCampaignCode
Response.Cookies("mt").Expires = DateAdd("d", 3650, strDateTime)
End If
End If
If strAction <> "" Then
strCampaignCode = Request.Cookies("mt")("cc")
intReferrer = Request.Cookies("mt")("rid")
If IsNumeric(intReferrer) Then
intReferrer = Int(intReferrer)
Else
intReferrer = 0
End If
Dim rsActionCheck : Set rsActionCheck = Server.CreateObject("ADODB.Recordset")
strSql = "SELECT a_code FROM " & strTablePrefix & "Actions " &_
"WHERE a_code LIKE " & FormatDatabaseString(strAction, 12)
rsActionCheck.Open strSql, objConn, 1, 2, &H0001
If Not rsActionCheck.Eof Then
Dim rsAction : Set rsAction = Server.CreateObject("ADODB.Recordset")
strSql = "SELECT al_datetime, al_unique, al_amount, al_a_code, al_ca_code, al_s_id, al_r_id " &_
"FROM " & strTablePrefix & "ActionLog " &_
"WHERE al_a_code LIKE " & FormatDatabaseString(strAction, 12) & " "
If strOrder <> "" Then
strSql = strSql & "AND al_unique LIKE " & FormatDatabaseString(strOrder, 100)
Else
strSql = strSql & "AND al_s_id = " & intSessionID
End If
If strDatabaseType = "MYSQL" Then
rsAction.CursorLocation = 3
End If
rsAction.Open strSql, objConn, 1, 2, &H0001
If rsAction.Eof Then
rsAction.AddNew
rsAction(0) = strFormatDate
rsAction(1) = ProtectInsert(strOrder, 100)
rsAction(2) = sngAmount
rsAction(3) = ProtectInsert(strAction, 20)
rsAction(4) = ProtectInsert(strCampaignCode, 20)
rsAction(5) = intSessionID
rsAction(6) = intReferrer
rsAction.Update
End If
rsAction.Close : Set rsAction = Nothing
End If
rsActionCheck.Close : Set rsActionCheck = Nothing
End If
Else
intUserAgent = CheckName(2, strUserAgent)
Dim intRobot : intRobot = CheckName(6, strRobot)
Dim rsRobot : Set rsRobot = Server.Createobject("ADODB.Recordset")
strSql = "INSERT INTO " & strTablePrefix & "RobotLog (rl_datetime, rl_pn_id, rl_useragent, rl_robot, rl_ip) VALUES(" &_
FormatDatabaseDate(strDateTime) & ", " &_
intPage & ", " &_
intUserAgent & ", " &_
intRobot & ", " &_
intIPNumber & ")"
rsRobot.Open strSql, objConn, 0, 2, &H0001
End If
End If
End Sub
Private Function ConvertIPAddressToLong(strIPAddress)
Dim strTemp : strTemp = strIPAddress
Dim aryIP : aryIP = Split(strTemp, ".")
Dim intNumber : intNumber = (Int(aryIP(0)) * 16777216) + (Int(aryIP(1)) * 65536) + (Int(aryIP(2)) * 256) + Int(aryIP(3))
intNumber = intNumber - 2147483647
ConvertIPAddressToLong = intNumber
End Function
Private Function ExtractPath(strScriptName)
Dim strTemp : strTemp = Left(strScriptName, InStrRev(strScriptName, "/"))
ExtractPath = strTemp
End Function
Private Function ExtractFileType(strScriptName)
Dim strTemp
If InstrRev(strScriptName, ".") > 0 And Right(strScriptName, 1) <> "/" Then
strTemp = Mid(strScriptName, InStrRev(strScriptName, ".") + 1)
Else
strTemp = ""
End If
ExtractFileType = strTemp
End Function
Private Function GetCountry(intIPNumber)
Dim strValue
If Not IsNumeric(intIPNumber) Then
strValue = ""
Else
strSql = "SELECT ic_code FROM " & strTablePrefix & "IPCountry " &_
"WHERE " & intIPNumber & " BETWEEN ic_ipstart and ic_ipend"
Dim rsCountry : Set rsCountry = Server.CreateObject("ADODB.Recordset")
rsCountry.Open strSql, objConn, 1, 2, 1
If Not rsCountry.Eof Then
strValue = rsCountry(0)
Else
strValue = ""
End If
rsCountry.Close
Set rsCountry = Nothing
End If
GetCountry = strValue
End Function
Private Function CheckName(intType, strName)
Dim intValue
If strName = "" Then
intValue = 0
Else
strSql = "SELECT n_id, n_value, n_type FROM " & strTablePrefix & "Names WHERE n_value = " & FormatDatabaseString(strName, 255)
Dim rsName : Set rsName = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsName.CursorLocation = 3
End If
rsName.Open strSql, objConn, 1, 2, &H0001
If rsName.Eof Then
rsName.AddNew
rsName("n_value") = ProtectInsert(strName, 255)
rsName("n_type") = intType
rsName.Update
End If
intValue = rsName("n_id")
rsName.Close
Set rsName = Nothing
End If
CheckName = intValue
End Function
Public Function ExtractPage(strReferrer)
Dim strTemp : strTemp = strReferrer
If InStr(strTemp, "?") Then
strTemp = Mid(strTemp, 1, InStr(strTemp, "?") - 1)
End If
If Left(LCase(strTemp), 4) <> "http" Then
strTemp = ""
End If
ExtractPage = strTemp
End Function
Public Function ExtractHost(strReferrer)
Dim strTemp : strTemp = strReferrer
strTemp = Replace(strTemp, "http://", "")
strTemp = Replace(strTemp, "https://", "")
If InStr(strTemp, "/") > 0 Then
strTemp = Mid(strTemp, 1, InStr(strTemp, "/") - 1)
End If
ExtractHost = strTemp
End Function
Public Function ExtractDomain(strHost)
Dim strDomain, strExtension
Dim strTemp : strTemp = strHost
If InStr(strTemp, ".") > 0 Then
Dim strEnd : strEnd = Mid(strTemp, InStrRev(strTemp, "."))
If InStr(".com.net.org.edu.gov.mil.int.aero.biz.coop.info.museum.name.pro", strEnd) > 0 Then
strExtension = strEnd
Else
If Len(strEnd) = 3 And Not IsNumeric(Right(strEnd, 2)) Then
Dim strRemainder : strRemainder = Left(strTemp, Len(strTemp) - Len(strEnd))
Dim strPart : strPart = Right(strRemainder, Len(strRemainder) - InStrRev(strRemainder, ".") + 1)
Dim strGeneric : strGeneric = ".ac.com.co.edu.go.gv.gov.govt.int.ltd.mi.mil.net.or.org.plc"
Select Case strEnd
Case ".ca"
strExtension = CheckExtension(".ab.bc.mb.nb.nf.ns.nt.nu.on.pe.qc.sk.yk", strPart, strEnd)
Case Else
strExtension = CheckExtension(strGeneric, strPart, strEnd)
End Select
If strExtension = "" Then
strExtension = strEnd
End If
End If
End If
End If
If strExtension <> "" Then
Dim objSearch : Set objSearch = New RegExp
Dim strPattern : strPattern = "[\w|\-]+" & Replace(strExtension, ".", "\.") & "$"
With objSearch
.Pattern = strPattern
.IgnoreCase = True
.Global = False
End With
Dim objResults : Set objResults = objSearch.Execute(strTemp)
If objResults.Count > 0 Then
Dim colItem
For Each colItem In objResults
strDomain = colItem.Value
Exit For
Next
End If
Set objSearch = Nothing : Set objResults = Nothing
Else
strDomain = ""
End If
ExtractDomain = strDomain
End Function
Private Function CheckExtension(strCompare, strPart, strEnd)
Dim strTemp
If InStr(strCompare, strPart) > 0 Then
strTemp = strPart & strEnd
End If
CheckExtension = strTemp
End Function
Public Function ExtractExtension(strDomain)
Dim strTemp : strTemp = strDomain
If strDomain <> "" Then
strTemp = Mid(strTemp, InStr(strTemp, "."))
Else
strTemp = ""
End If
ExtractExtension = strTemp
End Function
Private Function CleanLanguage(strLanguage)
Dim strTemp : strTemp = strLanguage
If InStr(Left(strTemp, 2), "rl") > 0 Then
strTemp = ""
End If
If strTemp <> "" Then
If InStr(strTemp, ",") > 0 Then
strTemp = Trim(Left(strTemp, InStr(strTemp, ",") - 1))
Else
strTemp = Trim(strTemp)
End If
If InStr(strTemp, ";") > 0 Then
strTemp = Trim(Left(strTemp, InStr(strTemp, ";") - 1))
End If
End If
CleanLanguage = strTemp
End Function
Private Function MatchDefinition(rsDefinition, strCompare, intType)
Dim strMatch
rsDefinition.Filter = "d_type = " & intType
Do While Not rsDefinition.Eof
Dim objSearch : Set objSearch = New RegExp
With objSearch
.Pattern = rsDefinition(2)
.IgnoreCase = True
.Global = False
End With
'On Error Resume Next
If objSearch.Test(strCompare) = True Then
strMatch = rsDefinition(1)
If intType = 4 Then
strExtra = rsDefinition(3)
End If
Exit Do
End If
'On Error Goto 0
Set objSearch = Nothing
rsDefinition.Movenext
Loop
MatchDefinition = strMatch
End Function
Private Function ExtractKeywords(strReferrer, strPrefix)
Dim strPattern
Dim strKeywords : strKeywords = ""
Dim strTemp : strTemp = Right(strReferrer, Len(strReferrer) - InStr(strReferrer, "?") + 1)
If InStr(strPrefix, "/") > 0 Then
strPattern = strPrefix & "(.+)"
Else
strPattern = "[\?|&]" & strPrefix & "=([^&]+)"
End If
Dim objSearch : Set objSearch = New RegExp
With objSearch
.Pattern = strPattern
.IgnoreCase = True
.Global = False
End With
Dim objResults : Set objResults = objSearch.Execute(strTemp)
If objResults.Count > 0 Then
Dim objMatch : Set objMatch = objResults(0)
strKeywords = objMatch.SubMatches(0)
End If
Set objMatch = Nothing : Set objSearch = Nothing : Set objResults = Nothing
If InStr(strKeywords, "&") > 0 Then
strKeywords = Left(strKeywords, InStr(strKeywords, "&") - 1)
End If
strKeywords = UrlDecode(strKeywords)
ExtractKeywords = strKeywords
End Function
Private Function ExtractScriptName(strScriptName)
Dim strTemp : strTemp = strScriptName
Dim objSearch : Set objSearch = New RegExp
With objSearch
.Pattern = "(http|https)://[\w|\-|\.]+"
.IgnoreCase = True
.Global = False
End With
strTemp = objSearch.Replace(strTemp, "")
If Instr(strTemp, "?") > 0 Then
strTemp = Mid(strTemp, 1, Instr(strTemp, "?") - 1)
End If
Set objSearch = Nothing
ExtractScriptName = strTemp
End Function
Private Function ExtractQuerystring(strScriptName)
Dim strQuerystring
Dim strTemp : strTemp = strScriptName
If Instr(strTemp, "?") > 0 Then
strQuerystring = Mid(strTemp, Instr(strTemp, "?") + 1)
Else
strQuerystring = ""
End If
ExtractQuerystring = strQuerystring
End Function
Public Function MatchIPAddress(strIPList)
Dim intLoop
Dim blnMatch : blnMatch = False
Dim aryIPAddress : aryIPAddress = Split(Replace(strIPList, " ", ""), ",")
Dim strIPAddress : strIPAddress = Request.Servervariables("REMOTE_ADDR")
For intLoop = 0 To UBound(aryIPAddress)
If Instr(aryIPAddress(intLoop), "*") Then
Dim aryIPAddressList : aryIPAddressList = Split(aryIPAddress(intLoop), ".")
Dim aryIPAddressSource : aryIPAddressSource = Split(strIPAddress, ".")
If UBound(aryIPAddressList) = 3 And UBound(aryIPAddressSource) = 3 Then
If aryIPAddressList(2) = "*" Then
aryIPAddressList(2) = aryIPAddressSource(2)
End If
If aryIPAddressList(3) = "*" Then
aryIPAddressList(3) = aryIPAddressSource(3)
End If
Dim strIPAddressCheck : strIPAddressCheck = aryIPAddressList(0) & "." & aryIPAddressList(1) & "." & aryIPAddressList(2) & "." & aryIPAddressList(3)
If strIPAddress = strIPAddressCheck Then
blnMatch = True
Exit For
End If
End If
Else
If strIPAddress = aryIPAddress(intLoop) Then
blnMatch = True
Exit For
End If
End If
Next
MatchIPAddress = blnMatch
End Function
Private Function URLDecode(strDecode)
Dim strSource, strTemp, strResult, intPos
strDecode = Replace(strDecode, "%C3%A4", "ä")
strDecode = Replace(strDecode, "%C3%B6", "ö")
strDecode = Replace(strDecode, "%E5", "å")
strDecode = Replace(strDecode, "%E4", "Ä")
strDecode = Replace(strDecode, "%F6", "Ö")
strDecode = Replace(strDecode, "%C3%A5", "Å")
strDecode = Replace(strDecode, "%C3%B8", "ø")
strSource = Replace(strDecode, "+", " ")
For intPos = 1 To Len(strSource)
strTemp = Mid(strSource, intPos, 1)
If strTemp = "%" Then
If intPos + 2 <= Len(strSource) Then
strResult = strResult & Chr(CInt("&H" & Mid(strSource, intPos + 1, 2)))
intPos = intPos + 2
End If
Else
strResult = strResult & strTemp
End If
Next
URLDecode = strResult
End Function
Private Function IsPrivateIP(strIPAddress)
Dim blnCheck : blnCheck = False
If Left(strIPAddress, 3) = "10." Then
blnCheck = True
ElseIf strIPAddress = "127.0.0.1" Then
blnCheck = True
ElseIf Left(strIPAddress, 7) = "192.168" Then
blnCheck = True
ElseIf Left(strIPAddress, 4) = "172." Then
Dim aryIP : aryIP = Split(strIPAddress, ".")
If UBound(aryIP) = 3 Then
If CInt(aryIP(1)) => 16 And CInt(aryIP(1)) =< 31 Then
blnCheck = True
End If
End If
End If
IsPrivateIP = blnCheck
End Function
Private Function ProtectInsert(strValue, intLength)
ProtectInsert = Left(strValue, intLength)
End Function
Private Function FormatIPAddress(strIPAddress)
Dim strTemp, aryIPAddress
If InStr(strIPAddress, ".") > 0 Then
aryIPAddress = Split(strIPAddress, ".")
If UBound(aryIPAddress) <> 3 Then
Exit Function
End If
If Not IsNumeric(aryIPAddress(0)) Then
Exit Function
ElseIf Not IsNumeric(aryIPAddress(1)) Then
Exit Function
ElseIf Not IsNumeric(aryIPAddress(2)) Then
Exit Function
ElseIf Not IsNumeric(aryIPAddress(3)) Then
Exit Function
Else
strTemp = strIPAddress
End If
End If
FormatIPAddress = strTemp
End Function
Private Function FilterQuerystring(strQuerystring)
Dim strTemp, blnMatch, intLoop, intFilter, aryVariable
If strQuerystringFilter <> "" And strQuerystring <> "" Then
Dim aryQuerystringFilter : aryQuerystringFilter = Split(strQuerystringFilter, ",")
Dim aryQuerystring : aryQuerystring = Split(strQuerystring, "&")
For intLoop = 0 To UBound(aryQuerystring)
blnMatch = False
If InStr(aryQuerystring(intLoop), "=") Then
aryVariable = Split(aryQuerystring(intLoop), "=")
For intFilter = 0 To UBound(aryQuerystringFilter)
If LCase(aryVariable(0)) = LCase(aryQuerystringFilter(intFilter)) Then
blnMatch = True
Exit For
Else
blnMatch = False
End If
Next
End If
If blnMatch = False Then
If strTemp = "" Then
strTemp = strTemp & aryQuerystring(intLoop)
Else
strTemp = strTemp & "&" & aryQuerystring(intLoop)
End If
End If
Next
Else
strTemp = strQuerystring
End If
FilterQuerystring = strTemp
End Function
Private Function ExtractCampaignCode(strQuerystring)
Dim aryTemp, strCode
Dim aryQuerystring : aryQuerystring = Split(strQuerystring, "&")
Dim intLoop : For intLoop = 0 To UBound(aryQuerystring)
aryTemp = Split(aryQuerystring(intLoop), "=")
If UBound(aryTemp) = 1 Then
If strComp(aryTemp(0), strQuerystringName, 1) = 0 Then
strCode = aryTemp(1)
Exit For
End If
End If
Next
ExtractCampaignCode = strCode
End Function
Private Function IsIPAddress(strIPAddress)
Dim blnTemp, aryIPAddress
blnTemp = False
If InStr(strIPAddress, ".") > 0 Then
aryIPAddress = Split(strIPAddress, ".")
If UBound(aryIPAddress) = 3 Then
If IsNumeric(aryIPAddress(0)) And IsNumeric(aryIPAddress(1)) _
And IsNumeric(aryIPAddress(2)) And IsNumeric(aryIPAddress(3)) Then
blnTemp = True
End If
End If
End If
IsIPAddress = blnTemp
End Function
End Class
%>
<%
' GET URL FOR LOGGING / REDIRECTION OR REFERRER
Dim strUrl : strUrl = Request.Querystring("mtr")
Dim blnImage : blnImage = CBool(Request.Querystring("mti"))
' CHECK WHAT TYPE OF LOGGING METHOD IS BEING USED
' 0 - ASP EXECUTE METHOD
' 1 - REDIRECT FILE METHOD
' 2 - JAVASCRIPT METHOD
' SET LOGGING TYPE IN CASE UNSPECIFIED
Dim intType
If strUrl <> "" Then
intType = 1
Else
intType = 0
End If
' GET LOGGING TYPE IF SPECIFIED
If Request.Querystring("mtt") <> "" Then
intType = Request.Querystring("mtt")
End If
' GET SCREENAREA IF AVAILABLE
Dim strScreenarea
If Request.Querystring("mts") <> "x" Then
strScreenArea = Request.Querystring("mts")
End If
Dim blnExclude
If Request.Cookies("mt_exclude") <> "" Then
blnExclude = True
Else
blnExclude = False
End If
' GET ACTION DATA
Dim strAction, strAmount, strOrder, strPageTitle
If intType = 0 Then
strPageTitle = Request.Cookies("mt")("pagetitle")
strAction = Request.Cookies("mt")("action")
strAmount = Request.Cookies("mt")("amount")
strOrder = Request.Cookies("mt")("order")
ElseIf intType = 2 Then
strPageTitle = Request.Querystring("mtpt")
strAction = Request.Querystring("mtac")
strAmount = Request.Querystring("mta")
strOrder = Request.Querystring("mto")
End If
' LOG REQUEST IF LOGGING IS ENABLED
If (aryMTConfig(2) = True Or aryMTConfig(2) = "") And blnExclude = False Then
' INSTANTIATE OBJECT FROM CLASS.ASP FILE
Dim objTrack : Set objTrack = New MTLog
Call CreateDatabaseConnection(0)
' SET SOME PROPERTIES
With ObjTrack
.Database = aryMTDB
.Config = aryMTConfig
.Action = strAction
.Amount = strAmount
.Order = strOrder
.PageTitle = strPageTitle
End With
' CHECK TO SEE IF IP MATCHES LOG EXCLUSION LIST
If Not objTrack.MatchIPAddress(aryMTConfig(3)) Then
' PERFORM LOGGING OPERATION
Call objTrack.LogFile(strUrl, intType, strScreenArea)
End If
Set objTrack = Nothing
Call CloseDatabaseConnection()
End If
' REDIRECT TO PAGE IF USING REDIRECT FILE METHOD (intType = 1)
If CInt(intType) = 1 Then
Response.Redirect strUrl
End If
If blnImage = True Then
Response.ContentType ="image/gif"
%>
GIF89a ‘ ÿÿÿÿÿÿ !ù , T ;
<% End If %>