<% @ LANGUAGE=VBScript %>
<% Option Explicit %>
<%
dim arrCandidateList(4)
arrCandidateList(0)="abcdefghijklmnopqrstuvwxyz"
arrCandidateList(1)="abcdefghijklmnopqrstuvwxyz abcdefghijklmnopqrstuvwxyz0123456789"
arrCandidateList(2)="abcdefghijklmnopqrstuvwxyz0123456789"
arrCandidateList(3)="ABCDEFGHIJKLMNOPQRSTUVWXYZ ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
arrCandidateList(4)="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
dim arrCandidateListP(4)
arrCandidateListP(0)=844
arrCandidateListP(1)=125
arrCandidateListP(2)=25
arrCandidateListP(3)=5
arrCandidateListP(4)=1
dim arrNameLengthP(7)
arrNameLengthP(0)=1
arrNameLengthP(1)=49
arrNameLengthP(2)=100
arrNameLengthP(3)=150
arrNameLengthP(4)=150
arrNameLengthP(5)=125
arrNameLengthP(6)=100
arrNameLengthP(7)=75
dim arrWordLengthP(15)
arrWordLengthP(0)=1
arrWordLengthP(1)=100
arrWordLengthP(2)=500
arrWordLengthP(3)=400
arrWordLengthP(4)=350
arrWordLengthP(5)=300
arrWordLengthP(6)=250
arrWordLengthP(7)=200
arrWordLengthP(8)=150
arrWordLengthP(9)=100
arrWordLengthP(10)=50
arrWordLengthP(11)=25
arrWordLengthP(12)=1
arrWordLengthP(13)=1
arrWordLengthP(14)=1
arrWordLengthP(15)=1
dim arrWordsOfLength1(1)
arrWordsOfLength1(0)="a"
arrWordsOfLength1(1)="I"
dim arrPartsP(2)
arrPartsP(0)=7
arrPartsP(1)=2
arrPartsP(2)=1
dim arrEndingList(13)
dim arrEndingListP(13)
arrEndingList(0)="com" : arrEndingListP(0)=40
arrEndingList(1)="edu" : arrEndingListP(1)=30
arrEndingList(2)="org" : arrEndingListP(2)=10
arrEndingList(3)="gov" : arrEndingListP(3)=1
arrEndingList(4)="us" : arrEndingListP(4)=1
arrEndingList(5)="fi" : arrEndingListP(5)=1
arrEndingList(6)="nl" : arrEndingListP(6)=5
arrEndingList(7)="uk" : arrEndingListP(7)=4
arrEndingList(8)="net" : arrEndingListP(8)=2
arrEndingList(9)="kr" : arrEndingListP(9)=1
arrEndingList(10)="de" : arrEndingListP(10)=5
arrEndingList(11)="se" : arrEndingListP(11)=1
arrEndingList(12)="no" : arrEndingListP(12)=4
arrEndingList(13)="si" : arrEndingListP(13)=1
dim arrZwho(3)
arrZwho(0)="postmaster"
arrZwho(1)="abuse"
arrZwho(2)="admin"
arrZwho(3)="root"
dim arrZwhereAt(4)
arrZwhereAt(0)=""
arrZwhereAt(1)="@localhost"
arrZwhereAt(2)="@loopback"
arrZwhereAt(3)="@" & Request.ServerVariables("REMOTE_HOST")
arrZwhereAt(4)="@" & Request.ServerVariables("REMOTE_ADDR")
dim arrZautoresponders(21)
arrZautoresponders(0)="jnyynpr@plorecebzb.pbz"
arrZautoresponders(1)="znaerzbir@plorecebzb.pbz"
arrZautoresponders(2)="nohfr@plorecebzb.pbz"
arrZautoresponders(3)="nohfrobg@plorecebzb.pbz"
arrZautoresponders(4)="fraqre@nafjrezr.pbz"
arrZautoresponders(5)="frira@tybonysa.pbz"
arrZautoresponders(6)="yra@hck.arg"
arrZautoresponders(7)="grez@zbarljbeyq.pbz"
arrZautoresponders(8)="gevdhnag@rneguyvax.arg"
arrZautoresponders(9)="qvfarltebhc@nafjrezr.pbz"
arrZautoresponders(10)="yvfgf@nafjrezr.pbz"
arrZautoresponders(11)="serq@svapba.pbz"
arrZautoresponders(12)="rmvar@fcelarg.pbz"
arrZautoresponders(13)="ppo@ploreirefr.pbz"
arrZautoresponders(14)="vasvavgl@haqngn.pbz"
arrZautoresponders(15)="wbuaz@znaafjro.pbz"
arrZautoresponders(16)="wraal31@whab.pbz"
arrZautoresponders(17)="crtnfhf496@cbjrearg.pbz"
arrZautoresponders(18)="pncf@kcbaragvny.pbz"
arrZautoresponders(19)="fgne5@cbobk.unegyrl.ba.pn"
arrZautoresponders(20)="hfpppa@unira.vbf.pbz"
arrZautoresponders(21)="rkarg@obbgf.pbz"
dim HelpScreen : HelpScreen = 0
dim DebugMode : DebugMode=0
dim title : title="SPAM bait"
dim RandomTitle : RandomTitle=-1
dim NumLow : NumLow=900
dim NumHigh : NumHigh=11100
dim FromMode : FromMode=0
dim Chaff : Chaff=0
dim TimeOut : TimeOut=90
dim Svar
dim strConsonants : strConsonants = "bcdfghjklmnpqrstvwxyz"
dim strVowels : strVowels = "aeiou"
'===============================================================
' Read command-line parameters...
'===============================================================
' chaff mode includes random stuff interspersed among addresses
Svar = Request.QueryString("chaff")
if Svar > "" then
Chaff=Svar
NumLow=250
NumHigh=400
end if
' override number of addresses to write
Svar = Request.QueryString("nlow")
if Svar > "" then
NumLow=Svar
NumHigh=Svar
end if
' set to 0 for fixed default title instead of random
Svar = Request.QueryString("randomtitle")
if Svar > "" then RandomTitle=Svar
' over-ride default title if not random
Svar = Request.QueryString("title")
if Svar > "" then
title=Svar
RandomTitle=0
end if
' from mode writes out "from addr" instead of mailto HTML links
Svar = Request.QueryString("frommode")
if Svar > "" then FromMode=Svar
' increase server timeout for running the script if slow
Svar = Request.QueryString("timeout")
if (IsNumeric(Svar)) and (Svar => 90) then Server.ScriptTimeout=Svar
' debug mode?
Svar = Request.QueryString("debug")
if Svar > "" then DebugMode=Svar
' help...
Svar = Request.QueryString("help")
if Svar > "" then HelpScreen=Svar
'===============================================================
' Main code...
'===============================================================
dim tp, p, NumMailTo, strAddress, addresses
randomize
'make a random title
if ( RandomTitle ) then
title = ""
tp = RandomInteger(2,6)
for p = 1 to tp
' pick one or the other
title = title & " " & Capitalize(RandomWordP(""))
' title = title & " " & Capitalize(RandomPronounceableWord(""))
next
end if
'HTML headers
Response.Write("<!DOCTYPE HTML PUBLIC '-//IETF//DTD HTML//EN'>" & vbNewLine)
Response.Write("<HTML><HEAD>" & vbNewLine)
Response.Write("<META HTTP-EQUIV='Content-Type' content='text/html; charset=iso-8859-1'>" & vbNewLine)
Response.Write("<META NAME='GENERATOR' content='Microsoft FrontPage 2.0'>" & vbNewLine)
Response.Write("<TITLE>" & title & "</TITLE>" & vbNewLine)
Response.Write("</HEAD>" & vbNewLine)
Response.Write("<BODY BGCOLOR='#FFFFFF' LINK='#0000FF' VLINK='#0000FF'>" & vbNewLine)
if (HelpScreen) then
Response.Write("<H1>Spam Bait</H1><P>")
Response.Write("<PRE>")
Response.Write("Syntax: http://hostname/scriptname.asp[?parameter=value[&...]]" & vbNewLine)
Response.Write(" where value must be 0, 1, or desired numeric or URL compliant text" & vbNewLine & vbNewLine)
Response.Write("?title= Page Title" & vbNewLine)
Response.Write("?nlow= Number of addresses to write" & vbNewLine)
Response.Write("?randomtitle= 0 to use fixed default title" & vbNewLine)
Response.Write("?frommode= Write from:'s instead of mailto:'s" & vbNewLine)
Response.Write("?chaff= Include random text with mail links interspersed" & vbNewLine)
Response.Write("?timeout= Set to 90 or longer to increase script timeout" & vbNewLine)
Response.Write("?debug= Write debugging data" & vbNewLine)
Response.Write("</PRE>")
else
'write out title in heading
Response.Write("<H1>" & title & "</H1><P>")
'how many fake addresses to make?
NumMailTo = RandomInteger(NumLow,NumHigh)
'main loop to write fake addresses...
for addresses = 1 to NumMailTo
'intersperse some paragraphs?
if ((Chaff) and (RandomInteger(0,10))) then
Response.Write("<P>" & RandomParagraph() & "</P>" & vbNewLine)
end if
strAddress = FakeAddress
if (FromMode) then
Response.Write("From: " & strAddress)
else
Response.Write("<a href='mailto:" & strAddress & "'>" & strAddress & "</a>")
end if
if (RandomInteger(1,3) = 1) then
'throw in an occasional cr-lf
Response.Write("<BR>" & vbNewLine)
else
Response.Write(" ")
end if
next
end if
'Javascript BACK button and HTML trailer
Response.Write("<DIV ALIGN='CENTER'><CENTER>" & vbNewLine)
Response.Write("<TABLE BORDER='0' CELLPADDING='0' CELLSPACING='0'><TR><TD>" & vbNewLine)
Response.Write("<FORM METHOD='POST'><P><INPUT TYPE='button' VALUE='Go Back' ONCLICK='history.back()'></P>" & vbNewLine)
Response.Write("</FORM></TD></TR></TABLE></CENTER></DIV><a href='freeemailaddresses.asp?param=" & RandomInteger(1,3))
Response.Write("'>somewhere else</a>" & vbNewLine)
Response.Write("</BODY></HTML>" & vbNewLine)
'===============================================================
' End of main code,
' Begin functions and subroutines...
'===============================================================
'===============================================================
' Return random integer in specified range low to high
'===============================================================
'standard random function from vbscript tutorial
function RandomInteger(intfrom,intto)
if intfrom = intto then
RandomInteger = intfrom
else
RandomInteger = Int((intto-intfrom+1)*Rnd+intfrom)
end if
end function
'===============================================================
' Weighted throw of the dice. Returns not-quite-random integer
' whose value is between 0 and the number of elements of the
' array passed. Results are weighted by values in the array.
'===============================================================
function IntegerPfunction(p)
dim i, rv, sum, volume, totalvolume
totalvolume = 0 : sum = 0 : rv = 0
for i = 0 to UBound(p)
totalvolume = totalvolume + p(i)
next
volume = RandomInteger(0,totalvolume)
for i = 0 to UBound(p)
sum = sum + p(i)
if ( volume < sum ) then
IntegerPfunction=rv
exit function
end if
rv=rv+1
next
' this should never be reached...
rv=rv-1
IntegerPfunction=rv
end function
'===============================================================
' Returns a random fake e-mail address
'===============================================================
function FakeAddress()
dim i, candidates, rv, parts : i = 1
if (RandomInteger(1,80)=1) then
FakeAddress=Zinger()
exit function
end if
parts = IntegerPfunction(arrPartsP) + 1
candidates = arrCandidateList(IntegerPfunction(arrCandidateListP))
rv = RandomNameP(candidates) & "@" & RandomNameP(candidates)
while (i < parts)
rv = rv & "." & RandomNameP(candidates)
i = i + 1
wend
rv = rv & "." & arrEndingList(IntegerPfunction(arrEndingListP))
FakeAddress=rv
end function
'===============================================================
' Returns addresses created from elements from tables of
' "zingers", occasionally unscrambling some better ones.
'===============================================================
function Zinger()
dim rv, i, n, c, cn
if ( RandomInteger(0,3) ) then
rv = arrZwho(RandomInteger(0,UBound(arrZwho)))
rv = rv & arrZwhereAt(RandomInteger(0,UBound(arrZwhereAt)))
else
rv = arrZautoresponders(RandomInteger(0,UBound(arrZautoresponders)))
for i = 1 to Len(rv)
c = Mid(rv,i,1)
n = InStr(1,"nopqrstuvwxyzabcdefghijklmNOPQRSTUVWXYZABCDEFGHIJKLM",c)
if (n) then
cn = Mid("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ",n,1)
rv = Left(rv,i-1) & cn & Mid(rv,i+1)
end if
next
end if
rv = CamelCase(rv)
Zinger = rv
end function
'===============================================================
' Huh? Defined but not used in original source.
' Return random length random string made from list of
' candidate characters passed as array
'===============================================================
function RandomName(candidates,fromnum,tonum)
dim rv, i, a, b, StrLength, SpacePos : rv = ""
SpacePos=InStr(1,candidates," ")
if (SpacePos) then
a = Mid(candidates,1,SpacePos-1)
b = Mid(candidates,SpacePos+1)
else
a = candidates
b = candidates
end if
StrLength = RandomInteger(fromnum,tonum)
if (StrLength < 1) then
RandomName=rv
exit function
end if
rv = rv & RandomLetter(a)
for i = 1 to StrLength
rv = rv & RandomLetter(b)
next
RandomName=rv
end function
'===============================================================
' Return weighted length random string made from list of
' candidate characters passed as array
'===============================================================
function RandomNameP(candidates)
dim rv, i, a, b, StrLength, SpacePos : i = 1
SpacePos=InStr(1,candidates," ")
if (SpacePos) then
a = Mid(candidates,1,SpacePos-1)
b = Mid(candidates,SpacePos+1)
else
a = candidates
b = candidates
end if
StrLength = IntegerPfunction(arrNameLengthP) + 1
rv = RandomLetter(a)
while (i < StrLength)
rv = rv & RandomLetter(b)
i = i + 1
wend
RandomNameP=rv
end function
'===============================================================
' Return random letter from string of candidate letters
'===============================================================
function RandomLetter(candidates)
RandomLetter=Mid(candidates,RandomInteger(1,len(candidates)),1)
end function
'===============================================================
' Return weighted length word from list of candidates letters.
' Original source declared explicit string instead of candidates
'===============================================================
function RandomWordP(candidates)
dim i, StrLength, rv : rv = ""
StrLength = IntegerPfunction(arrWordLengthP) + 1
for i = 1 to StrLength
rv = rv & RandomLetter("abcdefghijklmnopqrstuvwxyz")
next
RandomWordP=rv
end function
'===============================================================
' Return random pronounceable word
'===============================================================
function RandomPronounceableWord(candidates)
dim StrLength, rv : rv = ""
StrLength = IntegerPfunction(arrWordLengthP) + 1
if StrLength = 1 then
rv = arrWordsOfLength1(RandomInteger(0,1))
else
rv = rv & RandomSyllable()
while (len(rv)<StrLength)
rv = rv & RandomSyllable()
wend
end if
RandomPronounceableWord=rv
end function
'===============================================================
' Return random syllable
'===============================================================
function RandomSyllable()
RandomSyllable=RandomLetter(strConsonants) & RandomLetter(strVowels) & RandomLetter(strConsonants)
end function
'===============================================================
' Return word string with first letter capitalized
'===============================================================
function Capitalize(strWord)
dim c, cn
c=Mid(strWord,1,1)
cn=UCase(c)
Capitalize=Replace(strWord,c,cn,1,1)
end function
'===============================================================
' Return randomly mixed case from text input
'===============================================================
function CamelCase(strWord)
dim i, c, cn
if strWord="" then
CamelCase= ""
else
for i=1 to Len(strWord)
c=Mid(strWord,i,1)
if (RandomInteger(0,1)) then
cn = UCase(c)
else
cn = LCase(c)
end if
strWord=Left(strWord,i-1) & cn & Mid(strWord,i+1)
next
CamelCase=strWord
end if
end function
'===============================================================
' Return sentence of random length and content
'===============================================================
function RandomSentence()
dim part, parts, rv
rv = Capitalize(RandomPronounceableWord(""))
parts= RandomInteger(5,15)
for part = 1 to parts
rv = rv & " " & RandomPronounceableWord("")
next
RandomSentence = rv & ". "
end function
'===============================================================
' Return random sentence, maybe with random mail address links
'===============================================================
function RandomSentenceAddr()
dim part, parts, rv, strLink
rv = Capitalize(RandomPronounceableWord(""))
parts= RandomInteger(5,15)
for part = 1 to parts
if (RandomInteger(0,25)) then
rv = rv & " " & RandomPronounceableWord("")
else
rv = rv & " <a href='mailto:" & FakeAddress & "'>" & RandomPronounceableWord("") & "</a>"
end if
next
RandomSentenceAddr = rv & ". "
end function
'===============================================================
' Return paragraph of random length and content
'===============================================================
function RandomParagraph()
dim part, parts, rv : rv = ""
parts = RandomInteger(2,5)
for part = 1 to parts
rv = rv & RandomSentenceAddr()
next
RandomParagraph = rv
end function
'===============================================================
' Write debugging data to HTML output
'===============================================================
'I look pointless right now but I will be writing to a separate
'browser console when I am done.
public sub Debug(strStuff)
Response.Write("[" & strStuff & "]")
end sub
%>