Here’s mine: <img alt="beginner code c1998" src="/dumpster-fire.jpg"/>. But seriously, folks, I don’t have any handy… without trying to get an old drive to boot. I think this facsimile faithfully sums up the major issue(s) with my earliest production code and has much shorter line-wraps and better variable names to boot!

for my $what ( keys %should_have_been_an_array )
{
    for my $the ( keys %{$should_have_been_an_array->{$what}} )
    {
        $some_magic_switch_used_later_probably = 1 if fullmoon($the->{
+halfmoon});
        for my $hell ( keys %{$should_have_been_an_array->{$what}->{$t
+he}} )
        {
            my $readable = $should_have_been_an_array->{$what}->{$the}
+->{$hell};
            for my $are ( keys %{$readable} )
            {
                for my $you ( keys %{$readable->{$are}} )
                {
                    my @sorted = _some_other_thing(%{$readable->{$are}
+{$you}});
                    for my $doing ( @sorted )
                    {
                        if ( $doing )
                        {
                            # …
                        }
                        elsif ( $doing->{some_shim_not_in_the_actual_d
+ata} ||
                                $should_have_been_an_array->{$what}{SK
+IP} )
                        {
                            # …
                        }
                        elsif ( $thirteen_elsifs_later_without_an_else
+ )
                        {
                            # …
[download]

I wrote this script somewhere around 1995-97 and it was the first from my pen that was more than a few lines long. I can't find it on disk at the moment but I posted it here in response to this question so I will drag it back from the Monastery in case the original remains elusive.

The platform was SPARC/Solaris, probably 2.5-ish, and maybe run against perl 5.005 if memory serves. There is no use strict and I think the script predated the introduction of the 4-argument form of substr. Package file handles are also in evidence although I'm not sure if lexical file handles were available then. It uses underscores in variables whereas my preference these days is to use camelCase :-)

Old, in the sense of "some of the first Perl I wrote" is around the time I joined PerlMonks so I offer Utility to capture parameters and perform a task and Ook interpreter. Not terrible and not great. I was still fighting K&R in the Perl world. I've since bowed to pressure and use K&R for Perl (only, for other Cish coding I use some close approximation to Whitesmith's).

Christmas 2001 saw The Santa Claus Golf Apocalypse (the first ever code golf tournament played with a test program that all entries must pass before being accepted) launched to the once thriving, now dormant, "fun with perl" (fwp) mailing list. I wrote this historic test program in 2001, tsanta.pl, six months before joining Perl monks.

# tsanta.pl. Santa Claus golf game test program.
use strict;

sub GolfScore {
   my $script = shift;
   open(FF, $script) or die "error: open '$script'";
   my $golf = 0;
   while (<FF>) {
      chomp; next unless length;
      s/^#!.*?perl// if $. == 1;
      $golf += length;
   }
   close(FF);
   return $golf;
}

sub PrintGolfScore {
   my @scr = @_;
   my $tot = 0;
   for my $s (@scr) { $tot += GolfScore($s) }
   print "You shot a round of $tot strokes.\n";
}

sub BuildFile {
   my ($fname, $data) = @_;
   open(FF, '>'.$fname) or die "error: open '$fname'";
   print FF $data;
   close(FF);
}

sub CheckOne {
   my ($scr, $label, $data, $exp) = @_;
   my $intmp  = 'in.tmp';
   BuildFile($intmp, $data);
   my $cmd = "perl $scr $intmp";
   print "$label: running: '$cmd'...";
   my $out = `$cmd`; my $rc = $? >> 8;
   print "done (rc=$rc).\n";
   if ($out ne $exp) {
      warn "Expected:\n"; print STDERR $exp;
      warn "Got:\n"; print STDERR $out;
      die "Oops, you failed.\n";
   }
}

# -----------------------------------------------------

my $file1 = <<'GROK';
1st line
GROK

my $file2 = <<'GROK';
1st line
2nd line
GROK

my $file3 = <<'GROK';
1st line
2nd line
3rd line
GROK

my $file4 = <<'GROK';
1st line
2nd line
3rd line
4th line
GROK

my $file12 = <<'GROK';
1st line
2nd line
3rd line
4th line
5th line
6th line
7th line
8th line
9th line
10th line
11th line
12th line
GROK

my $file21 = <<'GROK';
1st line
2nd line
3rd line
4th line
5th line
6th line
7th line
8th line
9th line
10th line
11th line
12th line









GROK

# -----------------------------------------------------

sub CheckHead {
   my ($scr) = @_;
   my @tt = (
      [ 'file1',  $file1,  "1st line\n" ],
      [ 'file2',  $file2,  "1st line\n2nd line\n" ],
      [ 'file3',  $file3,  "1st line\n2nd line\n3rd line\n" ],
      [ 'file12', $file12,
        "1st line\n2nd line\n3rd line\n4th line\n5th line\n".
        "6th line\n7th line\n8th line\n9th line\n10th line\n" ],
   );
   for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}

sub CheckTail {
   my ($scr) = @_;
   my @tt = (
      [ 'file1',  $file1,  "1st line\n" ],
      [ 'file2',  $file2,  "1st line\n2nd line\n" ],
      [ 'file3',  $file3,  "1st line\n2nd line\n3rd line\n" ],
      [ 'file12', $file12,
        "3rd line\n4th line\n5th line\n6th line\n7th line\n".
        "8th line\n9th line\n10th line\n11th line\n12th line\n" ],
      [ 'file21', $file21, "12th line\n\n\n\n\n\n\n\n\n\n" ],
   );
   for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}

sub CheckRev {
   my ($scr) = @_;
   my @tt = (
      [ 'file1',  $file1,  "1st line\n" ],
      [ 'file2',  $file2,  "2nd line\n1st line\n" ],
      [ 'file3',  $file3,  "3rd line\n2nd line\n1st line\n" ],
      [ 'file21', $file21,
        "\n\n\n\n\n\n\n\n\n12th line\n11th line\n10th line\n".
        "9th line\n8th line\n7th line\n6th line\n5th line\n".
        "4th line\n3rd line\n2nd line\n1st line\n" ],
   );
   for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}

sub CheckMid {
   my ($scr) = @_;
   my @tt = (
      [ 'file1',  $file1,  "1st line\n" ],
      [ 'file2',  $file2,  "1st line\n2nd line\n" ],
      [ 'file3',  $file3,  "2nd line\n" ],
      [ 'file4',  $file4,  "2nd line\n3rd line\n" ],
      [ 'file12', $file12, "6th line\n7th line\n" ],
      [ 'file21', $file21, "11th line\n" ],
   );
   for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}

sub CheckWc {
   my ($scr) = @_;
   my @tt = (
      [ 'file1',  $file1,  "0000000001\n" ],
      [ 'file2',  $file2,  "0000000002\n" ],
      [ 'file3',  $file3,  "0000000003\n" ],
      [ 'file4',  $file4,  "0000000004\n" ],
      [ 'file12', $file12, "0000000012\n" ],
      [ 'file21', $file21, "0000000021\n" ],
   );
   for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}

# -----------------------------------------------------

my $head = 'head.pl';
my $tail = 'tail.pl';
my $rev  = 'rev.pl';
my $mid  = 'mid.pl';
my $wc   = 'wc.pl';
select(STDERR);$|=1;select(STDOUT);$|=1;  # auto-flush
-f $head or die "error: file '$head' not found.\n";
-f $tail or die "error: file '$tail' not found.\n";
-f $rev  or die "error: file '$rev' not found.\n";
-f $mid  or die "error: file '$mid' not found.\n";
-f $wc   or die "error: file '$wc' not found.\n";
PrintGolfScore($head, $tail, $rev, $mid, $wc);
CheckHead($head);
CheckTail($tail);
CheckRev($rev);
CheckMid($mid);
CheckWc($wc);
PrintGolfScore($head, $tail, $rev, $mid, $wc);
print "Hooray, you passed.\n";
[download]

The tournament was won by a Dutch PhD student, Eugene van der Pijll. His five brilliant solutions, shown below, still run fine from tsanta.pl with the latest perl today. It was Eugene's code to reverse the lines in a file (rev.pl) that caused a sensation, with everyone else in the field certain that it was obviously impossible to improve on the prosaic:

print reverse<>
[download]

-p $\=$_.$\}{
[download]

head.pl

#!/usr/bin/perl -p
11..exit
[download]

tail.pl

print+(<>)[-10..-1]
[download]

rev.pl

#!/usr/bin/perl -p
$\=$_.$\}{
[download]

mid.pl

#!/usr/bin/perl -p0
$_=$1while/.^(.+)^/ms
[download]

wc.pl

printf"%010d\n",$.,<>
[download]

After lying dormant for eighteen years, and despite all the golfic trickery, I was delighted to see that tsanta.pl and all five of Eugene's winning solutions, still run fine today with the latest Perl on both Unix and Windows. I think this little example shows how seriously P5P takes backwards compatibility.

So confronting!

1997:

#!/pro/bin/perl
#Selectie van ...

print "\nDe selectie wordt nu afgedrukt,\n";
print "\nmoment geduld a.u.b...\n";

$report  = $ENV{'REPORT'};
$scripts = $ENV{'SCRIPTS'};
$tmpfil  = "/tmp/t.foobar.$$";

open (TMP, ">$tmpfil");

sqlscript ("$report/foobar.sql1");

while (<SQL>) {
    chomp;
    @id = split (/\|/);
    printf TMP "ple -f %03d%04d%03d | RPT $scripts/foobar.rptmsfnr - |
+ lp -dprinter -op17 -onosz -odiac\n", $id[0], $id[1], $id[2];
    }
close (SQL);
close (TMP);

system ('sh ' . "$tmpfil");
unlink $tmpfil;

sub sqlscript
{
    open (SQL, "SQL @_ |");
    }
[download]

I was trying to create a bunch of static HTML pages and bash didn't scale very well with the growing project so I started using more and more Perl and shelled out to the existing .sh scripts.

• no strict
• no warnings
• a lot of try and error because I thought it can't be that difficult, if you already know basic, bash and tcl

for instance I remember being stuck by defining sub func() {...} only to find out that Perl doesn't have proper signatures. Empty parens mean an empty prototype forbidding any arguments at compile-time and bang! :/

still far better than bash.

My old HDD is never too far away:

#! /usr/bin/perl
use strict;
use warnings;
use Storable;
use Scalar::Util;
use File::Basename;
use POSIX;

my $busy = 'busy';
my $is_busy;
if (-e $busy) {$is_busy = ${retrieve($busy)}} else {$is_busy = 0};
if ($is_busy) {exit};
$is_busy = 1;
store(\$is_busy, $busy);

my $magic_string = ' -depth 8 -density 150 -compress Zip ';
my $mydata = 'mydata';
my $folder = 'Hot';
my $folder_done = 'Done';
my @fl1;
my @a1;
my %fl2;

sub find_index {
    my $tmp = -1;
    my $str1 = shift;
    my $str2 = shift;
    my $size1 = length $str1;
    my $size2 = length $str2;
    if ($size1 != $size2) {return -1};
    for (my $i = 0; $i < $size1; $i++) {
        my $c1 = substr $str1, $i, 1;
        my $c2 = substr $str2, $i, 1;
        if ($c1 ne $c2) {
            if ($tmp != -1) {return -1} else {$tmp = $i}
        }
    };
    return $tmp
};

sub good_pair {
    my $str1 = shift;
    my $str2 = shift;
    my $n = find_index($str1, $str2);
    if ($n == -1) {return 0};
    my @tmp = sort (substr($str1, $n, 1), substr($str2, $n, 1));
    if ((ord($tmp[0]) < ord('A')) or (ord($tmp[1]) > ord('Z'))) {retur
+n 0};
    unless (ord($tmp[0]) % 2) {return 0};
    if (ord($tmp[1]) - ord($tmp[0]) - 1) {return 0}; 
    return 1
};

# ********************************************************

opendir DIR, $folder;
@fl1 = readdir DIR;
closedir DIR;

if (-e $mydata) {%fl2 = %{retrieve($mydata)}};

# ...
# hundred+ lines of more horrors (I'll spare you ...:) ), then:

for (my $i = 0; $i < @pdf; $i++) {
    system "lpr -o orientation-requested=3 -o media=Custom.".$w[$i]."x
+".$h[$i]."mm ".'"'.$folder."/$pdf[$i]".'"';
    rename $folder."/$pdf[$i]", $folder_done."/$pdf[$i]";
};

store(\%fl2, $mydata);
$is_busy = 0;
store(\$is_busy, $busy);
[download]

1st check if still busy i.e previous cron job was not finished. Next couple of funny subs are to determine "good pair" of ~ISO-A2 tiff files, face and back, names differ in single char, A & B or C & D... but not e.g. B & C. Skipped part is head to head imposition, IM system calls, +some other fuss, dense and unreadable.

That's how it started, with Linux, and, quite arbitrarily, Perl as scripting language, in 2007, because of "free" lpr to print jobs from hotfolder to wide-roll printer. Not "old code", for that I'd dig for Pascal from 1990 or so. :)

Unfortunately, my long-term archives are in storage, but I can at least describe the nonsense I wrote.

Not long before I started my career path at an Internet Provider in 2000, I was more of an unscrupulous individual with low ethics and had a full-blown wifi hacking setup in my vehicle that I'd use to scan and crack into networks in the Bay St, Toronto, Canada area.

At this time, I was using FreeBSD as my Operating System, with ipfw as my firewall on my "war-driving" equipment.

A few weeks after starting at the ISP, I came across a "Learn Perl in 21 days" book, and having known basic C/C++ at the time, I picked that up quick and figured 'man, this scripting thing would make it easy to automate stuff'.

What'd I do? Wrote an exceptionally hacky wrapper around the ipfw binary so that I could use quick-keys on my keyboard to automate rule sets within the firewall in an instant. It was filled with stuff like:

# do not change these lines unless you know what you're doing!!!
[download]

...even though the lines (looking back) did nothing of real importance, and even a low-level intermediate Perl hacker would laugh at.

I also remember using C-style for() loops, using long lists of global variables, and as I'm sure everyone has, tried to use variables as variable names.

Good times. I'll forever be appreciative for that odd book on the shelf I picked up. I'm thankful for the lessons I've learned, the things I've picked up, and the mistakes that I'll still make that I'll inevitably learn from.

Congratulations on the kick up to Chancellor, haukex. It's very well deserved.

-stevieb

#!/usr/bin/perl
#############################################################
# Name: compare
# Desc: Compare contents of two arrays and print the diff.
#############################################################

@array1 = ("John", "Jane");
@array2 = ("John", "Jane", "Sally", "David", "Joe", "Bev");

local(%mark);
grep($mark{$_}++,@array1);
@result = grep(!$mark{$_},@array2);

print "\n";
print "array1: @array1\n";
print "array2: @array2\n";
print "\n";
print "differ: @result\n";
print "\n";
[download]

Should I really publish my first perpetrations in perl? Ok, since this is long ago and doesn't really matter anyways, here it goes... 1137 lines of naughty code, released on April 15, 1994.

Written for perl 4, patchlevel 36. At our CAD lab in the university, we had to force people to clean up their home directories by themselves. Nine SPARCstation 10, 1 IPX, 2 SPARCstation 2 and a SPARCserver 300 with 16MB of RAM and some disks, doing NFS. All workstations doing NFS, automounting stuff from there to here. Disk storage was expensive, and we didn't have enough. 60-80 students producing huge crap files. We were tired of "Can't login!"-complaints due to "file system full" conditions.

Hence, "hund" (dog).

Run as root, this script sniffed the home dirs of all NIS users (yellow tables) and checked their disk usage. If the home dir was over quota, it installed itself as the only xinit client running in a xterm or cmdtool, so users over quota didn't get their desktop, but this shitty tcsh fake (far from complete or perfect) which it was for non-root, and allowed only commands to reduce disk space. It would persist until the low disk quota watermark (soft limit) was reached. It had escapes, though. My first software with security holes :-)

Believe it or not, this actually *did* run in our network, and it helped a bit. I'm not asking for bug reports or style complaints, thank you. Too much spaghetti, I know. Beat that bloke at 25 years ago, not me.

For publishing, the code was run through perltidy to convert tabs to 4 spaces, and Encode for UTF8, otherwise it is as it had been.
Comments are in german, as is the embedded nroff manual page, sorry about that, i18n wasn't required. My linux nroff -man hund | less -R doesn't grok the diversion and ignore tags (di and ig00) and formats the code as well, but at the end it displays the manual page just fine.

Long time ago, and I was proud of it. Go figure.

My first perl script is Creating a random generator. It has since ballooned into nearly 40 random generation modules on various subjects. I am very embarrassed by my code and attitude back then. My code was extremely messy and my attitude was worse. I am glad the Monks did not excommunicate me.

#!/usr/bin/perl -w
#

use integer;
sub swap
{
    $_[0]=$_[0] ^ $_[1];
    $_[1]=$_[0] ^ $_[1];
    $_[0]=$_[0] ^ $_[1];    
}
sub nsd
{
    my ($a,$b)=@_;
    do 
    {
    if ($a<$b) {$b-=$a}
    elsif ($b<$a) {$a-=$b}
    } until ($a==$b);
    return($a)
}
# main
print ("Array size: ");
chomp($n=<stdin>);
print ("Shift: ");
chomp($d=<stdin>);
print("NSD:",nsd($n,$d),"\n");
for ($i=0;$i++<$n;$array[$i]=$i){}
#
for ($j=0;$j<nsd($n,$d);$j++)
{
    $i=$n-$j;
    $aux=$array[$i];
    unless ($next=($i+$d)%$n) {$next=$n}
    do {
    for($k=0;$k++<$n;printf("%2.0d",$array[$k]),print(",")){}
    print("\n");
    $array[$i]=$array[$next];
    $array[$next]=$aux;
    $i=$next;
    $aux=$array[$i];
    unless ($next=($i+$d)%$n) {$next=$n}
    } until ($next==$n-$j);
}
for($k=0;$k++<$n;print($array[$k],",")){}
[download]

I was probably experimenting with the programming language that was new to me. For some reason, I disliked whitespace. Is this some kind of self-embarassment contest? ;-)

I did it like all ingenious people do it with their early fubar works: I deleted all this crap. But i guess that there is still some weird stuff in the wild AKA prod that i did wrong some years ago. Especially with CGI.

My first perl code was around 1995-1996, and it wasn't until 2001 that . My early code falls squarely into the catagory of:

UGLY AS SIN

#!/usr/bin/perl -w

use strict;
use warnings;

###############################
# CONSTANTS

my $ABSOLUTE_PATH = '/home/lentnews05/public_html';

my $SUCCESS = 0;
my $FAILURE = 1;

###############################
# PROGRAM STARTS HERE

my $INPUT = $ENV{"QUERY_STRING"};
if (!$INPUT) { FAILED("Please provide the Event Number in the address 
+bar followed by a question mark."); exit; }

if (isNaN($INPUT))
{ FAILED("Please provide the Event Number in the address bar."); exit;
+ }

if (length($INPUT) > 10)
{ FAILED("The Event Number cannot be longer than 10 digits."); exit; }

my $NEW_EVENT = $INPUT;

###############################
# MAIN PROGRAM

UPDATE($ABSOLUTE_PATH . '/main.htm');
UPDATE($ABSOLUTE_PATH . '/index.htm');
UPDATE($ABSOLUTE_PATH . '/index.html');

# Success
print "Content-type: text/html\n\n";
print "<HTML><HEAD><TITLE>Update Successful</TITLE></HEAD>\n";
print "<BODY BGCOLOR=006600 TEXT=FFFFCC LINK=CCFFCC ALINK=CCFFCC VLINK
+=CCFFCC>\n";
print "<H1>Update Successful.</H1>\n";
print "<H3>Event Number = $NEW_EVENT</H3>\n";
print "<H3><A TARGET='_blank' HREF='http://www.lentnews05.org'>www.len
+tnews05.org</A></H3>\n";
exit;

###############################
# This function displays an
# error message.
#
sub FAILED
{
  my $MSG = shift;

  # Error message
  print "Content-type: text/html\n\n";
  print "<HTML><HEAD><TITLE>Error</TITLE></HEAD>\n";
  print "<BODY BGCOLOR=550000 TEXT=FFFFFF LINK=FFFFCC ALINK=FFFFCC VLI
+NK=FFFFCC>\n";
  print "<H1>Website did not update.</H1>\n";
  print "<H3>Error: $MSG</H3>\n";
  print "<H3><A TARGET='_blank' HREF='http://www.lentnews05.org'>www.l
+entnews05.org</A></H3>\n";
}
###############################
# This function overwrites the
# Event Number in the index file.
#
sub UPDATE
{
  my $P;
  my $DATA1;
  my $DATA2;
  my $FileName = shift;
  my $DATA = ReadFile($FileName);
  if (length($DATA) == 0)
  { FAILED("Couldn't read $FileName"); exit; }

  $P = index($DATA, 'EVENT_NO = ');
  if ($P < 0) { FAILED("Couldn't find EVENT_NO in $FileName"); exit; }
  $DATA1 = substr($DATA, 0, $P);

  $P = index($DATA, ';', $P);
  if ($P < 0) { FAILED("$FileName doesn't have a proper text body."); 
+exit; }
  $DATA2 = substr($DATA, $P+1);

  $DATA = $DATA1 . "EVENT_NO = $NEW_EVENT;" . $DATA2;

  if (WriteFile($FileName, $DATA))
  { FAILED("Couldn't write to file - $FileName"); exit; }
}
################################################
#
# This function reads an entire file silently
# in raw binary mode and returns the contents
# in one big string. If an error occurs,
# an empty string is returned.
#
# Usage: STRING = ReadFile( FILE_NAME )
#
sub ReadFile
{
  my $N;
  my $DATA;
  my $filename = shift;
  return '' if !(-f $filename);
  my $filesize = -s $filename;
  if ($filesize == 0) { return ''; }
  open(my $FILE, '<:raw', $filename) or return '';
  $N = read($FILE, $DATA, $filesize);
  close $FILE;
  if (!defined $N) { return ''; }
  return substr $DATA, 0, $N;
}
################################################
# This function adds some text to the end of
# a file or returns 1 if something went wrong.
#
# Usage: STATUS = AppendFile( FILE_NAME, STRING )
#
sub AppendFile
{
  my ($filename, $DATA) = @_;
  open(my $FILE, '>>', $filename) or return 1;
  print $FILE $DATA or return 1;
  close $FILE or return 1;
  return 0;
}
################################################
sub WriteFile
{
  my ($filename, $DATA) = @_;
  open(my $FILE, '>', $filename) or return 1;
  print $FILE $DATA or return 1;
  close $FILE or return 1;
  return 0;
}
################################################
# Prints a horizontal line to STDOUT.
#
# Usage: HR(OPTIONAL_STRING_BYTE)
#
#  HR();     --->  ----------------------------
#  HR('=');  --->  ============================
#
#
sub HR
{
  my $C = '-';
  if ((scalar @_) > 0) { $C = shift; }
  print "\n" . (substr($C, 0, 1)) x 80;
}
################################################
# This function extracts arguments from an URL
# string and returns them in pairs.
#
# Example: @R = getArgsURL("http://www.lentnews05.org/g/ar.cgi?c=12305
+5&s=%28Top+Stories+%29#PGTOP");
#   R[0] ---> "c"
#   R[1] ---> "123055"
#   R[2] ---> "s"
#   R[3] ---> "(Top Stories)"
#
sub getArgsURL
{
  my $S = shift;
  my @OUTPUT;
  my @X;
  my $P;

  $S = strAfter($S, '?');
  $S = strBefore($S, '#');
  @X = split('&', $S);

  foreach $S (@X)
  {
    splitAB($S, '=');
    push(@OUTPUT, decodeURLstr($a));
    push(@OUTPUT, decodeURLstr($b));
  }
  return @OUTPUT;
}
################################################
# This function works almost like split()
# however it will only split STRING into two
# chunks. If the pattern is found, the section before
# the first occurrence of PATTERN goes into $a,
# and rest goes into $b.
#
# (This function has no return value. It just
# simply changes the values of $a and $b.)
#
# Usage : splitAB(STRING, PATTERN)
#
sub splitAB
{
  my $S = shift;
  my $P = shift;
  $a = $b = '';
  if (length($S) == 0) { return; }
  if (length($P) == 0) { $a = $S; return; }
  my $N = index($S, $P);
  if ($N < 0) { $a = $S; return; }
  $a = substr $S, 0, $N;
  $b = substr $S, $N + length($P);
}
################################################
# This function returns the first half of STRING
# that comes before the first occurrence of PATTERN.
# If PATTERN is not found, then returns an empty string.
#
# Usage: STRING strBefore(STRING, PATTERN)
#
sub strBefore
{
  my $STRING = shift;
  my $PATTERN = shift;
  my $P = index($STRING, $PATTERN);
  return '' if ($P < 0);
  return substr($STRING, 0, $P);
}
################################################
# This function returns the last half of STRING
# that comes after the first occurrence of PATTERN.
# If PATTERN is not found, then returns an empty string.
#
# Usage: STRING strAfter(STRING, PATTERN)
#
sub strAfter
{
  my $STRING = shift;
  my $PATTERN = shift;
  my $P = index($STRING, $PATTERN);
  return '' if ($P < 0);
  return substr($STRING, $P + length($PATTERN));
}
############################################
#
# This function works like the index() function,
# except it looks for individual characters
# instead of an exact string match. It returns
# the position of the first single character in
# STRING that matches any of the characters in
# CHRS. If none of the characters in STRING
# match any character in CHRS, -1 is returned.
# Matching is case sensitive.
#
# If a third argument is supplied, this function
# works the opposite way: it returns the position
# of the first NON-matching character.
#
# Usage: INTEGER strchr(STRING, CHRS)
#        INTEGER strchr(STRING, CHRS, MODE)
#
# Example: strchr("cat5hr", "0123456789")         ---> 3
#          strchr("sharks", "0123456789")         ---> -1
#          strchr("2,587.91", "0123456789.,", 0)  ---> -1
#          strchr("2,5?7.91", "0123456789.,", 0)  ---> 3
#
sub strchr
{
  my $STRING = shift;
  my $CHRS = shift;
  my $MODE = ((scalar @_) > 0) ? 1 : 0;
  my $C;
  for (my $i = 0; $i < length($STRING); $i++)
  {
    $C = substr($STRING, $i, 1);
    if (((index($CHRS, $C)) < 0 ? 1 : 0) == $MODE)
    { return $i; }
  }
  return -1;
}
############################################
#
# This function compares characters in STRING1
# against a list of legal characters listed
# in STRING2 to see if any character in STRING1
# is not found in STRING2. If all match, the
# return value is 1. If even just one of the
# characters in STRING1 is not found anywhere
# in STRING2, the return value is 0.
# Matching is case sensitive.
#
# Usage: INTEGER chrset(STRING1, STRING2)
#
# Example: chrset("221", "12345")   ---> 1
#          chrset("21x", "12345")   ---> 0
#          chrset("box", "abcdef")  ---> 0
#
sub chrset
{
  my ($S, $SET) = @_;
  for (my $i = 0; $i < length($S); $i++)
  { return 0 if (index($SET, substr($S, $i, 1)) < 0); }
  return 1;
}
############################################
#
# This function returns 0 if the input string
# is a decimal number, or otherwise returns 1.
# Use this function to test small numbers only
# (less than 15 digits is safe)!
#
# Usage: INTEGER isNaN( STRING )
#
# Example:
#     isNaN('.0009')       ---> 0
#     isNaN('12345')       ---> 0
#     isNaN('-1234.5717')  ---> 0
#     isNaN('abc55')       ---> 1
#
sub isNaN
{
  my $N = shift;
  return 1 unless (defined $N);
  return 1 unless (length($N) > 0);

  for (my ($i, $C, $D) = 0; $i < length($N); $i++)
  {
    $C = ord(substr($N, $i, 1));
    if ($C < 48 || $C > 57)
    {
      if ($C == 43 || $C == 45) { next if ($i == 0); }
      elsif ($C == 46) { next if ($D++ == 0); }
      return 1;
    }
  }
  return 0;
}
############################################
#
# This function removes leading and trailing
# spaces, tabs, and new-line characters
# from a string and returns a new string.
# It can also be used to trim other characters
# such as leading and trailing zeroes.
#
# Usage: STRING trim(STRING)
#        STRING trim(STRING, CHRS)
#
# Example: trim("\t  a b c \r\n");       ---> "a b c"
#          trim('$000090.50', '$0');     ---> "90.5"
#          trim('CABxxAxABBCC', 'ABC');  ---> "xxAx"
#
sub trim
{
  my $j = 0;
  my $i = -1;
  my $STR = shift;
  my $REMOVE = ((scalar @_) > 0) ? shift : " \t\r\n";

  if (length($STR) == 0) { return ''; }

  for (my $x = 0; $x < length($STR); $x++)
  {
    if (index($REMOVE, substr($STR, $x, 1)) < 0)
    {
      if ($i < 0) { $i = $x; }
      $j = $x - $i + 1;
    }
  }
  return substr($STR, $i, $j);
}
############################################
#
# This function converts an integer (0-255)
# to a two-digit hexadecimal string.
#
# Usage: STRING toHex( NUMBER )
#
sub toHex
{
  my $N = int( shift );
  return '00' if ($N <= 0);
  return 'FF' if ($N >= 255);

  my $X = '0123456789ABCDEF';
  my $LO = $N & 0x0F;
  my $HI = $N >> 4;
  return substr($X, $HI, 1) . substr($X, $LO, 1);
}
############################################
#
# This function is the same as the escape()
# function in JavaScript. It takes the input
# string and leaves letters and numbers and
# 7 special characters intact but converts
# all the other characters to %XX format
# where XX is a hex number.
#
# Only the following 7 special characters
# are left intact : /@+*-._
#
# Usage: STRING escape( STRING )
#
# Example: "Hello World!" --> "Hello%20World%21"
#
sub escape
{
  my $C;
  my $BYTE;
  my $ENCODE;
  my $INPUT = shift;
  my @OUTPUT;

  for (my $i = 0; $i < length($INPUT); $i++)
  {
    $ENCODE = 0;
    $BYTE = substr($INPUT, $i, 1);
    $C = ord($BYTE);

       if ($C < 42 || $C > 122)  { $ENCODE = 1; }
    elsif ($C > 57 && $C < 64)   { $ENCODE = 1; }
    elsif ($C > 90 && $C < 95)   { $ENCODE = 1; }
    elsif ($C == 44 || $C == 96) { $ENCODE = 1; }

    $BYTE = ($ENCODE) ? '%' . toHex($C) : $BYTE;

    push(@OUTPUT, $BYTE);
  }

  return join("", @OUTPUT);
}
############################################
# This is the opposite of the escape() function.
#
sub unescape
{
  my $XX;
  my $BYTE;
  my $INPUT = shift;
  my @OUTPUT;

  for (my $i = 0; $i < length($INPUT); $i++)
  {
    $BYTE = substr($INPUT, $i, 1);
    if (ord($BYTE) == 37)
    {
      $BYTE = '';
      $XX = substr($INPUT, $i+1, 2);
      if (length($XX) == 2)
      {
        $i += 2;
        $BYTE = chr(hex($XX));
      }
    }
    push(@OUTPUT, $BYTE);
  }
  return join("", @OUTPUT);
}
################################################
# This function decodes an URL-style string.
# Works like the unescape function, however
# it will also convert '+' signs to spaces.
#
sub decodeURLstr
{
  my $S = shift;
  $S =~ tr /+/ /;
  return unescape($S);
}
[download]