[Jax.PM] wposion ?
iudicium ferat
sneex at bellsouth.net
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
More information about the Jacksonville-pm
mailing list