[Jax.PM] wposion ?

Wed Oct 2 22:14:43 CDT 2002

Hi All :)

What do you guys think about this:

#!/usr/bin/perl -w

# wpoison.pl - Version 1.8p
#
# For usage instructions see http://www.monkeys.com/wpoison/
#
# Original idea by Ronald F. Guilmette <rfg at monkeys.com>
# Code implemented by Ronald F. Guilmette <rfg at monkeys.com>
#
# Copyright (c) 2000,2001 Ronald F. Guilmette; All rights reserved.
#
# Redistribution and use in source form ONLY, with or without 
modification,
# is permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
# 2. All advertising materials mentioning features or use of this 
software
#     must display the following acknowledgement:
#      This product includes software developed by Ronald F. Guilmette.
# 3. Neither the name of Ronald F. Guilmette nor the names of other con-
#     tributors to this software may be used to endorse or promote 
products
#     derived from this software without specific prior written 
permission.
# 4. Either a copy of, or a link to the official Wpoison logo 
graphic (which
#     may be found at http://www.monkeys.com/wpoison/logo.gif) must be
#     included in, and clearly and legibly visible on the home page 
of any
#     web site which uses, employs, includes, or makes reference to this
#     software or any derivative or modified version thereof.  Also, the
#     official Wpoison logo itself must be include in an HTML hyperlink
#     so that any usser clicking on any part of the logo image will be
#     directed/linked to the Wpoison home page at:
#	
#	http://www.monkeys.com/wpoison/
#
#     In order to satisfy this requirement, you may simply include the
#     following HTML code somewhere (anywhere) on your web site 
home page:
#
#	<A HREF="http://www.monkeys.com/wpoison/">
#		<IMG SRC="http://www.monkeys.com/wpoison/logo.gif">
#	</A>
#
# Disclaimer
# ----------
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 
PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE 
LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 
GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 
CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 
ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

use strict;
use FileHandle;
use POSIX;
use vars qw($pname $tmp_words_file $num_cached_randwords @randwords 
@tl_domains_1 @tl_domains_2);

$pname="wpoison";
$tmp_words_file = "/tmp/wpoison.words";
$num_cached_randwords = 4096;
my $creation_time;
my $age_in_seconds;
my $email_addr;
my $num_addresses;
my $num_links;
my $script_name = getenv ("SCRIPT_NAME") || $0;

@tl_domains_1 = (
   "com", "com", "com", "com",
   "net", "net", "net",
   "org", "org",
   "edu", "edu",
   "gov",
   "mil",
   "int");

@tl_domains_2 = (
   "uk", "su",
   "af", "al", "dz", "as", "ad", "ao", "ai", "aq", "ag", "ar", "am", 
"aw", "au",
   "at", "az", "bs", "bh", "bd", "bb", "by", "be", "bz", "bj", "bm", 
"bt", "bo",
   "ba", "bw", "bv", "br", "io", "bn", "bg", "bf", "bi", "kh", "cm", 
"ca", "cv",
   "ky", "cf", "td", "cl", "cn", "cx", "cc", "co", "km", "cg", "ck", 
"cr", "ci",
   "hr", "cu", "cy", "cz", "dk", "dj", "dm", "do", "tp", "ec", "eg", 
"sv", "gq",
   "er", "ee", "et", "fk", "fo", "fj", "fi", "fr", "fx", "gf", "pf", 
"tf", "ga",
   "gm", "ge", "de", "gh", "gi", "gr", "gl", "gd", "gp", "gu", "gt", 
"gn", "gw",
   "gy", "ht", "hm", "hn", "hk", "hu", "is", "in", "id", "ir", "iq", 
"ie", "il",
   "it", "jm", "jp", "jo", "kz", "ke", "ki", "kp", "kr", "kw", "kg", 
"la", "lv",
   "lb", "ls", "lr", "ly", "li", "lt", "lu", "mo", "mk", "mg", "mw", 
"my", "mv",
   "ml", "mt", "mh", "mq", "mr", "mu", "yt", "mx", "fm", "md", "mc", 
"mn", "ms",
   "ma", "mz", "mm", "na", "nr", "np", "nl", "an", "nc", "nz", "ni", 
"ne", "ng",
   "nu", "nf", "mp", "no", "om", "pk", "pw", "pa", "pg", "py", "pe", 
"ph", "pn",
   "pl", "pt", "pr", "qa", "re", "ro", "ru", "rw", "kn", "lc", "vc", 
"ws", "sm",
   "st", "sa", "sn", "sc", "sl", "sg", "sk", "si", "sb", "so", "za", 
"gs", "es",
   "lk", "sh", "pm", "sd", "sr", "sj", "sz", "se", "ch", "sy", "tw", 
"tj", "tz",
   "th", "tg", "tk", "to", "tt", "tn", "tr", "tm", "tc", "tv", "ug", 
"ua", "ae",
   "gb", "us", "um", "uy", "uz", "vu", "va", "ve", "vn", "vg", "vi", 
"wf", "eh",
   "ye", "yu", "zr", "zm", "zw");

sub
death
{
   my ($message) = @_;

   print STDOUT ("Content-Type: text/html\n",
		"\n",
		"<HTML>\n",
		"<HEAD><TITLE>WPOISON - Unexpected Error</TITLE></HEAD>\n",
		"<BODY BGCOLOR=\"white\" TEXT=\"#c00000\"><BIG><BIG>\n");

   print "$pname: $message\n";

   print ("</BIG></BIG></BODY>\n</HTML>\n");
   exit 0;
}

sub
gen_new_random_words_list
{
   my $dictfile;
   my $total_words;
   my @words;
   my %already_taken;

   if (-f $tmp_words_file) {
     if (not unlink ($tmp_words_file)) {
       death ("Error unlinking file \`$tmp_words_file\': $!");
     }
   }

   if ( -f "/usr/dict/words") {
     $dictfile = "/usr/dict/words";
   } elsif (-f "/usr/share/dict/words") {
     $dictfile = "/usr/share/dict/words"
   } elsif (-f "words") {
     $dictfile = "words";
   } else {
     death ("Cannot find dictionary file!");
   }

   death ("Error opening dictionary file \`$dictfile\': $!")
     unless (open (DICTFILE, "<$dictfile"));

   $total_words = 0;
   while (<DICTFILE>) {
     chop;
     push @words, $_;
     $total_words++;
   }

   close DICTFILE;

   death ("Error opening tmp words file \`$tmp_words_file\': $!")
     unless (open (RWORDS, ">$tmp_words_file"));

# We will now pick $num_cached_randwords words at random

   srand;

   for (1..$num_cached_randwords) {
   try_again:
     my $rand_index = int (rand $total_words);

     goto try_again if (defined $already_taken{$rand_index});
     $already_taken{$rand_index} = 1;
     print RWORDS "$words[$rand_index]\n";
   }

   close RWORDS;
}

sub
read_random_words
{
   death ("Error opening tmp words file \`$tmp_words_file\': $!")
     unless (open (RWORDS, "<$tmp_words_file"));

   chop(@randwords = <RWORDS>);

   close RWORDS;
}

sub
random_word
{
   my $word_index;

   $word_index = int (rand $num_cached_randwords);
   return $randwords[$word_index];
}

sub
gen_random_words
{
   my ($min_words, $max_words) = @_;
   my $num_words;
   my $word_index;
   my $i;

   $num_words = $min_words + (rand ($max_words - $min_words));
   for $i (1..$num_words) {
     $word_index = int (rand $num_cached_randwords);
     print $randwords[$word_index];
     print " " if ($i < $num_words);
   }
}

sub
gen_random_color
{
   my $red_code = int (rand 256);
   my $green_code = int (rand 256);
   my $blue_code = int (rand 256);

   printf "#%02x%02x%02x", $red_code, $green_code, $blue_code;
}

sub
random_letter
{
   return chr (unpack ("%c", 'a') + int (rand 26));
}

sub
random_domain
{
   my $rindex;

   if (int (rand 4) == 0) {
     $rindex = int (rand ($#tl_domains_2 + 1));
     return $tl_domains_2[$rindex];
   } else {
     $rindex = int (rand ($#tl_domains_1 + 1));
     return $tl_domains_1[$rindex];
   }
}

autoflush STDOUT 1;

if (not -r $tmp_words_file) {
   gen_new_random_words_list ();
} else {
   $creation_time = (stat $tmp_words_file)[9];
   $age_in_seconds = time - $creation_time;
   gen_new_random_words_list () if ($age_in_seconds > (30 * 60));
}

read_random_words ();

print STDOUT ("Content-Type: text/html\n",
		"\n",
		"<HTML>\n",
		"<HEAD>\n",
		"<TITLE>");

gen_random_words (2, 6);

print STDOUT ("</TITLE>\n",
		"<META NAME=\"ROBOTS\" CONTENT=\"NOINDEX, NOFOLLOW\">\n",
		"</HEAD>\n",
		"<BODY BGCOLOR=\"");
gen_random_color ();
print ("\" TEXT=\"");
gen_random_color ();
print ("\" LINK=\"");
gen_random_color ();
print ("\" VLINK=\"");
gen_random_color ();
print ("\">\n", "<BIG>\n");

gen_random_words (10, 30);
print ("<P>\n");

$num_addresses = 2 + int (rand 16);
for (1..$num_addresses) {
   $email_addr = random_word ();
   $email_addr .= "@";
   if (int (rand 4) == 0) {
     $email_addr .= random_word () . ".";
   }
   $email_addr .= random_word () . random_letter () . "." . 
random_domain ();
   print "<A HREF=\"mailto:$email_addr\">$email_addr</A><BR>\n";
}

print ("<P>\n");
gen_random_words (2, 20);
print ("<P>\n");

$num_links = 1 + int (rand 16);
for (1..$num_links) {
   print "<A HREF=\"";
   print $script_name;
   print "/";
   print (random_word ());
   print ("\">");
   gen_random_words (1, 9);
   print ("</A><BR>\n");
}

print ("<P>\n");

gen_random_words (2, 20);

# Sleep for four seconds when finishing each page to avoid server 
overload.

sleep (4);

print ("</BIG>\n</BODY>\n</HTML>\n");

exit 0;

__END__
-Sx-
_________________________________________________________
"Well, in general, the thing I don't like about other
computer languages is that they're not Perl." -Larry Wall