Source code for http://rectaltronics.com/tdlywnx.asp

COLOR LEGEND

  Server Side Script
  Client Side Script
  Hyperlink
  Include
  Frames
  Comments
  Object Code Link
  Standard HTML and Text


<%  @ LANGUAGE=VBScript %>
<%  Option Explicit %>
<%  

   ' <br><br>IF YOU CAN SEE THIS IT MEANS THAT THE WEB SERVER <br>
   ' DOES NOT SUPPORT ACTIVE SERVER PAGES AND VBSCRIPT <br>
   ' OR THE WEB SERVER IS FUBAR <br><br><br><br><br><br><br><br>
   '===============================================================
   ' TDLYWNX.ASP:
   ' Generate HTML containing bogus addresses, and some not-so-bogus
   ' addresses like "postmaster".
   ' The idea is to keep SPAMers and junkmailers who search web pages
   ' for addresses too busy with bogus addresses to flood valid ones.
   ' No good web site should be without at least a few thousand bogus
   ' addresses that are changed often.
   '===============================================================
   ' Original Perl source code kind courtesy of johnbob @ io.com.
   ' Converted to VBScript (ASP) Brad Berson 1998041900 on a prayer.
   ' Tested on MS Internet Information Server 4.0 and Option Pack 4.
   ' Cleaned up some code, added some header HTML to make it look
   ' less suspicious in context, added some other distractions, and
   ' added a JavaScript [back] button for errant humans. Also added
   ' detection of remote domain and/or IP addr to create abuse@ and
   ' localhost@ destinations for same.
   '===============================================================
   ' Comments or suggestions to brad.berson @ rectaltronics.com.
   ' Please copy and use freely. Copy updates to Brad Berson.
   ' If you use this script, I only ask you write to say "thanks."
   '===============================================================
   ' Last Update: 1998041900 - Brad Berson - Original debugged
   '===============================================================

   '===============================================================
   ' Global variable and array initialization...
   '===============================================================

   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=1100
   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>" & 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

%>