<%
'' REFERER-INC.ASP
'' Sean P. Nolan
'' http://www.yaywastaken.com/
''
'' This code is free for you to use as you see fit. Copy it, rewrite it,
'' run it yourself, whatever. But no warranties or guarantees either. Who
'' knows what the hell it does. Not me, that's for sure!
''
'' Shared crap for referer service
Response.Buffer = True
Response.Expires = -1000
On Error Resume Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Constants
Const adVarChar = 200
Const adInteger = 3
Const adDBTimeStamp = 135
Const adParamInput = &H0001
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetDatabaseConnection
Function GetDatabaseConnection()
Dim knex
On Error Resume Next
' killme
szSite = Request.QueryString("site")
Select Case szSite
Case "link feedback", "oyay", "amazon rss", "Overdue", _
"roblog", "spookybob", "robbookshelf", "robcdshelf", "robhat", _
"roblighthouse", "robtravel"
' business as usual
Case Else
Set GetDatabaseConnection = Nothing
Exit Function
End Select
Set knex = Server.CreateObject("ADODB.Connection")
Err.Clear
knex.Open "XXXXX"
If (Err.Number <> 0) Then
Set knex = Nothing
End If
Set GetDatabaseConnection = knex
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Misc
Function URLDecode(S3Decode)
' modified from: http://www.softshell.net/asp/urldecode.asp
Dim S3Temp(1,1)
Dim S3In, S3Out, S3Pos, S3Len, S3i, S3Asc
S3In = S3Decode
S3Out = ""
S3In = Replace(S3In, "+", " ")
S3Pos = Instr(S3In, "%")
Do While S3Pos
S3Len = Len(S3In)
If S3Pos > 1 Then S3Out = S3Out & Left(S3In, S3Pos - 1)
S3Temp(0,0) = Mid(S3In, S3Pos + 1, 1)
S3Temp(1,0) = Mid(S3In, S3Pos + 2, 1)
For S3i = 0 to 1
S3Asc = Asc(S3Temp(S3i,0))
If S3Asc > 47 And S3Asc < 58 Then
S3Temp(S3i,1) = S3Asc - 48
ElseIf (S3Asc > 96 And S3Asc < 103) Then
S3Temp(S3i,1) = S3Asc - 97 + 10
Else
S3Temp(S3i,1) = S3Asc - 65 + 10
End If
Next
S3Out = S3Out & Chr((S3Temp(0,1) * 16) + S3Temp(1,1))
S3In = Right(S3In, (S3Len - (S3Pos + 2)))
S3Pos = Instr(S3In, "%")
Loop
URLDecode = S3Out & S3In
End Function
Function TruncateString(sz, nMaxLength)
If (Len(sz) < nMaxLength) Then
TruncateString = sz
Else
If (nMaxLength < 3) Then nMaxLength = 3
TruncateString = Left(sz, nMaxLength - 3) & "..."
End If
End Function
Function BreakLongWords(szTitle, nMaxLengthWord)
Dim szWord
szNewTitle = ""
For Each szWord In Split(szTitle, " ")
If (szNewTitle <> "") Then szNewTitle = szNewTitle & " "
While (Len(szWord) > nMaxLengthWord)
szNewTitle = szNewTitle & Left(szWord, nMaxLengthWord) & " "
szWord = Mid(szWord, nMaxLengthWord + 1)
Wend
szNewTitle = szNewTitle & szWord
Next
BreakLongWords = szNewTitle
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetRefererRSS
Function SanitizeForXML(sz)
SanitizeForXML = Replace(sz, "&", "&")
End Function
Function GetRefererRSS(knex)
Dim szSite, szSiteURL, szCommand, cmd, rows, param, icolTitle
Dim szRSS, szMaxItems, szQry, szDescText, szOrderThing, szTitle
Dim nMaxLengthTitle, szMaxLengthTitle
Dim nMaxLengthWord, szMaxLengthWord, szLastAnd
Dim szDaysPast, dateSearch
szSite = SanitizeForXML(Request("site"))
szSiteURL = SanitizeForXML(Request("url"))
szMaxItems = Request("maxitems")
If (szMaxItems = "") Then szMaxItems = "10"
szQry = Request("qry")
szLastAnd = ""
If (LCase(szQry) = "popular") Then
szDescText = "most popular"
szOrderThing = "v.vcount"
szDaysPast = Request("daysago")
If (szDaysPast <> "") Then
dateSearch = Now - CLng(szDaysPast)
szLastAnd = "and v.last_visit_date >= ?"
End If
Else
szDescText = "recent"
szOrderThing = "v.last_visit_date"
End If
If (Request("notitle") = "") Then
icolTitle = 1
Else
icolTitle = 0
End If
szMaxLengthTitle = Request("maxlen")
If (szMaxLengthTitle = "") Then
nMaxLengthTitle = -1
Else
nMaxLengthTitle = CLng(szMaxLengthTitle)
End If
szMaxLengthWord = Request("maxwordlen")
If (szMaxLengthWord = "") Then
nMaxLengthWord = -1
Else
nMaxLengthWord = CLng(szMaxLengthWord)
End If
szRSS = "<?xml version=""1.0"" ?>" & vbCrLf & _
"<rss version=""0.91"">" & _
"<channel>" & _
"<title>" & szSite & "</title>" & _
"<link>" & szSiteURL & "</link>" & _
"<description>" & szDescText & " referrers for " & _
szSite & "</description>" & _
"<language>en-us</language>" & _
"<image>" & _
"<url>http://www.yaywastaken.com/referer/ref.gif</url>" & _
"<title>" & szSite & "</title>" & _
"<link>" & szSiteURL & "</link>" & _
"<width>1</width><height>1</height>" & _
"</image>"
szCommand = _
" select " & _
" top " & szMaxItems & " " & _
" u.url url, " & _
" u.link_text link_text, " & _
" " & szOrderThing & " order_thing " & _
" from " & _
" referer_sites s, " & _
" referer_urls u, " & _
" referer_service_2 v " & _
" where " & _
" s.name = ? and " & _
" s.site_id = v.site_id and " & _
" v.url_id = u.url_id and " & _
" u.is_valid = 1 " & szLastAnd & " " & _
" order by " & _
" order_thing desc "
If (knex Is Nothing) Then
szRSS = szRSS & "<item><title>new service up at blogtricks.com, it's been more than a year!</title>" & _
"<link>http://www.blogtricks.com</link></item>" & _
"<item><title>maybe you need a vacation</title>" & _
"<link>http://www.my-travel-planner.com/planner</link></item>"
Else
Set cmd = Server.CreateObject("ADODB.Command")
cmd.ActiveConnection = knex
cmd.CommandText = szCommand
Set param = cmd.CreateParameter("s.name", adVarChar, _
adParamInput, Len(szSite), szSite)
cmd.Parameters.Append(param)
If (szLastAnd <> "") Then
Set param = cmd.CreateParameter("v.last_visit_date", _
adDBTimeStamp, _
adParamInput, _
0, dateSearch)
cmd.Parameters.Append(param)
End If
Set rows = cmd.Execute
While Not rows.EOF
szTitle = CStr(rows(icolTitle))
If (nMaxLengthTitle <> -1) Then
szTitle = TruncateString(szTitle, nMaxLengthTitle)
End If
If (nMaxLengthWord <> -1) Then
szTitle = BreakLongWords(szTitle, nMaxLengthWord)
End If
szTitle = SanitizeForXML(szTitle)
szRSS = szRSS & "<item><title>" & _
szTitle & _
"</title><link>" & _
SanitizeForXML(CStr(rows(0))) & _
"</link></item>"
rows.MoveNext
Wend
End If
szRSS = szRSS & "</channel></rss>" & vbCrLf
GetRefererRSS = szRSS
End Function
%>