Perl Limericks

Use small Perl code examples directly from this document with cut&paste

Send corrections/remarks/questions to: sb@c-lab.de

One of the many uses of Perl is fast prototyping using very compact code. This document supplies many examples of short Perl programs doing a task with only a few lines of code. The programs are tested on Solaris and Linux. For some constructs, Perl 5.005 is required.

If you have access to the electronic version of this document, use the cut&paste facility of the mouse to extract the code examples and execute them directly. Keep an eye on the amount of text the cut&paste buffer can store.

You can use this document for seeing quickly how to do a special task in Perl. But be careful, no warranty of whatsoever is given. Especially error trapping is mostly ignored in small examples, but there is one special section devoted to this near the end of this document.

In literature, a limerick is a 5 line poem where the first, second and last line take the rhyme with, as do the third and fourth line, e. g.

	There was a young Lady of Riga
	Who rode with a Smile on a Tiger
	They returned from the Ride
	With the Lady inside
	And the Smile on the Face of the Tiger.

Most of the Perl code examples shown here are about that size, so we call them Perl Limericks. But have in mind: a Limerick in Perl might be a novel in C - much longer and no rhyme.

Hints: Often myfile is used as example for an input filename, but every collection of files should do. Furthermore, when storing the Perl code into a file, the path to the Perl interpreter must be adopted to match the local environment.

When using a shell with history mechanism use not instead of the ! operator (e.g. when followed by - ). Furthermore, the trailing escaped newlines ( \ ) at the end of a line must be removed for Bourne Shells, so for interactive testing a C-Shell can be used more directly.

When used from a DOS command shell, double quotes (") are required instead of single quotes (') to submit the Perl code from the shell to the Perl interpreter. In this case the constructs qq{...} and q{...} as substitutes for " ... " and ' ... ' might be helpful.

An alternative is to take the Perl code from stdin (using - ) and finish it with __END__. For a Bourne Shell on Linux 2.0, an explicit Return may be needed. When used with cut&paste, first take the commandline starting with perl - and then the whole rest to avoid an error message like

Illegal character \015 (carriage return) at - line 1.
(Maybe you didn't strip carriage returns after a network transfer?)

Note: Some browsers have a problem to display backquotes correctly, but this is not true for a printout or the reaction of cut&paste, see e. g. the code for tabular expansion.

Accessing the Command Line
Data Extraction
Data Manipulation
Data Types and Parameter Passing
Nested Data Structures
Information about Files
Manipulating Files
Further File Access
Accessing the Directory Tree
Accessing the User Environment
Time and Date
System and User Information
Exhausting the System
Handling Signals and Timeouts
Setuid Scripts
Regular Expressions
Modules and Packages
Named Pipes
Formatting
Accessing the Display
Persistent Data Storing
System Access and Error Trapping
Miscellaneous
Links

1. Accessing the Command Line

Print all command line arguments:

	perl -le 'foreach $word (@ARGV) {print $word}' one -two +three

Print only the first command line argument:

	perl -le 'print $ARGV[0]' one -two +three

Test the number of command line arguments:

	perl -le 'if (@ARGV == 3) {print "3 args is ok"} \
		elsif (@ARGV < 3) {die "missing args"} \
		else {warn "superfluous args @ARGV[3..$#ARGV]"}' 1 2 3 4 5 6

Ok, this is a clumsy version, dependend on Unix (single quotes for grouping the value of Perl's -e option) and even the command Shell used on Unix (continuation lines of the C-Shell). Here is an alternative form, which works on Unix (C-Shell and Bourne Shells) and even MS DOS:

	perl -l - 1 2 3 4 5 6
		if (@ARGV == 3) {print "3 args is ok"} 
		elsif (@ARGV < 3) {die "missing args"}
		else {warn "superfluous args @ARGV[3..$#ARGV]"}
		__END__

Test lowercase single letter command line switches (using symbolic references):

	perl -ls - -a -m="mid" -z
		no strict; 
		foreach $O ("a".."z") {print "-$O=$$O" if $$O}
		__END__

If you are only interested in Options a and m:

	perl -ls - -a -m="mid" -z
		no strict; 
		@Accpt_Opts = ("a", "m");
		foreach $O (@Accpt_Opts) {print "-$O=$$O"}
		__END__

Processing files, but taking commands from stdin is done by placing - as programfile between options and arguments. Here, each line of myfile is output together with the line number:
```
	perl -p - myfile
		s{^}{$.\t};
	__END__
```

For more sophisticated option handling use Getopt::Std or Getopt::Long.

2. Data Extraction

Print all lines from file containing the word OLD, after substituting it by NEW, while obeying word boundaries.:
```
	perl -ne 's/\bOLD\b/NEW/ and print' myfile
```
Print each second last word between line 10 and 20 in one line:
```
	perl -lane '9 < $. and $. < 21 and print $F[-2]' myfile
```
Print each line of containing more than 72 characters:
```
	perl -ne 'print if length > 72' myfile
```

Print columns 5 to 7:

	perl -lane 'print substr($_,4,3)' myfile

Print each line that does not contain the same number of words as the previous line:
```
	perl -ane 'print if @F != $old; $old = @F' myfile
```

Add all last words of each line which are decimal integers and print the number of addends and the total result:

	perl -an - myfile 
	if ($F[-1] =~ /^\d+$/) {$sum += $F[-1]; $smd++}; 
	END {print "$smd addends with total: $sum\n"};
	__END__

Print each word on a separat line:

	perl -ane 'BEGIN {$\=$,="\n"}; print @F' myfile

Print line numbers and all non-ascii characters if there are some:

	perl -n - myfile
		tr/\0-\37\177-\377//cd;
		print $., " ", $_ unless m/^\s*$/;
		__END__

Count the number of characters "a" in a file:

	perl -n - myfile
		$x += tr/a/a/;
		END {print "Character a occured $x time(s)\n"};
		__END__

Count the number of characters "a" in each line of a file:

	perl -n - myfile
		$x = tr/a/a/;
		print "$. : Character a occured $x time(s)\n";
		__END__

Find mismatch of brackets { and }

	perl -n - myfile
		BEGIN {$l = 0}; 
		$b += tr/{/{/; $b -= tr/}/}/; unless ($b) {$l = $.}; 
  		if ($b < 0) {die "Wrong block closing in line $.\n"}; 
		END {print "Last balance in line $l, now: $b\n"};
		__END__

Extract all text between all occurrences of <pre> and </pre> :

	perl -n - myfile
		$/=undef;
		while (s@<pre>(.*?)</pre>@@s) {
			$t .= $1}; 
		END {print $t};
		__END__

Hexadecimal dump of a binary file.
The output consists of 3 column blocks: a hexadecimal file offset, 4 words, each consisting of 4 hex numbers; the last block is an ASCII representation of the 4 words or a dot (.) if the byte is not ASCII. In the last line output, the middle part may be padded with non existent 0's.

	perl - myfile
	
	open(STDIN, $ARGV[0]) || die "Can't open $ARGV[0]: $!\n"
		if $ARGV[0];
	
	$empty = pack "N4", 0, 0, 0, 0; # for the last line, if < 16
	
	while ($len = read (STDIN, $data, 16)) { # take 16 Bytes at once
	    @array = unpack('N4', ($len < 16) ? ($data | $empty) : $data);
	    $data =~ tr/\0-\37\177-\377/./;
	    printf "%8.8lx\t%8.8lx %8.8lx %8.8lx %8.8lx\t%s\n",
		$offset, @array, $data;
	    $offset += 16;
	}
	__END__

Extracting ASCII sequences.
A modification of the previous code allows to extract ASCII strings with 4 or more letters to be extracted from a binary file (a la strings ). Here, all files in the current directory tree are searched for the word secret by a subsequent grep command. It is strongly recommended to check the error status of the shell (eg. with echo $status) after such a command.
```
	perl -0777 - `find . -type f -print` | grep 'secret'
	while (<>) {
	  PARSER: {
	     m/([^\0-\37\177-\377]+)/g && do {
		  print "$ARGV: $1\n" if (length($1) >= 4); redo PARSER};
	  }
	}
	__END__
```
Find peculiar block matchings.
A closing parenthesis is regarded to be peculiar if its column number is less than the one of its corresponding opening parenthesis.
For each input line, each character becomes an entry in @F. To use this for LISP code e. g., tabular expansion and comment stripping should be done before, see below.
```
	perl -anF'//' - myfile
	for ($i=0; $i<@F; $i++) {
	  if ($F[$i] eq "(") {push @Col, $i; push @Line, $.}
	  if ($F[$i] eq ")") {
	      $col = pop @Col; $line = pop @Line;
	      if ($col > $i) {
		 print "Line $line column $col",
		   " mismatch to line $., column ", $i, "\n";
	      }
	  }
	}
	__END__
```

Print each word on a single line:

	echo "abc def   hi  j" | perl -pe 'tr/[ \t]/\n/s'

Find double words in lines, i. e. output each line containing a word followed directly by the same word. Here, a word is every string between word boundaries.
```
	perl -ne 'print if m/(\b\B+\b)\s*\b\1\b/' myfile
```
Check if last word of the previous line is equal to first word on the current line. If so, print previous and current line and the word found. This time, words consist of alphanumeric characters and case is ignored.
```
	perl -n - myfile
	  if ($lw and m/^\W*$lw\W*/i and $. > 1) {
	      print $ll;
	      print;
	      print "Found \"$lw\"\n";
	  }
	  m/(\b\w+)\W*$/;
	  $ll = $_; # last line
	  $lw = $1; # last word
	__END__
```

Create new HTML references from all existing ones (HTML index).

	perl -n - myfile
	  BEGIN {print "     <ul>\n"};
	  if (m/<a\b.*\bname\b\s*=\s*"([^"]*)"/i) {
		print "\t<li> <a href=\"#$1\"> $1 </a>\n"
	  }
	  END {print "     </ul>\n"};
	__END__

Extract headers from Mail folder and subsequent attachment, if any. This relies on headers consisting of a single paragraph finished with an empty line. Therein, a line starting with "From" or one with " filename=" is required.
```
	perl -00 -n - ~/nsmail/Inbox > /tmp/result
	   if (/^From/m || /^\s*filename="/m) {
	   	s/.*^---------//ms;
		print;
	   }
	   __END__
```

Extract lines surrounding one with a given search pattern (similar to the UNIX/GNU command grep -B -A ):

	perl -n - "Mon, 15 Jan 2001" 4 2 ~/nsmail/Inbox 
	    BEGIN{$pat = shift; $before = shift; $after=shift};
	      if (push (@Lines, $_) > $before) {shift @Lines};
	      if (m/$pat/) {print join ('', @Lines); undef @Lines;$fin=$after}
	      elsif ($fin) {print; print "--\n" unless (--$fin)};
	__END__

3. Data Manipulation

Delete the first 15 lines in file myfile:

	perl -i -pe 'if ($. <= 15) {s/^.*\n//}' myfile

or alternatively:

	perl -i -ne 'print if $. > 15' myfile

Convert UNIX file myfile into DOS format with backup in myfile.unix:
```
	perl -i.unix -pe 's/\n/\015\012/' myfile
```
Convert DOS file myfile into UNIX format with backup in myfile.dos:
```
	perl -i.dos -pe 's/\r\n/\012/' myfile
```
Expand tabs (tabular expansion) to 8-column spacing (Thanks to the Perl Manpage):
```
	perl -i -pe 'while (s/\t+/" " x (length($&)*8 - length($`)%8)/e) {}' myfile
```

Print German mutated vowels (Umlaute): # on Unix

	perl -l
	foreach ("Ä", "Ö", "Ü", "ä", "ö", "ü", "ß") {
		print
	}
	__END__

Print German mutated vowels (Umlaute):# on Windows

	perl -l
	foreach $c (0216, 0231, 0232, 0204, 0224, 0201, 0341) {
		print chr($c);
	}
	__END__

	perl -l # Unix
	foreach $c (0304, 0326, 0334, 0337, 0344, 0366, 0374) {
		print chr($c);
	}
	__END__

Substitue German mutated vowels (Umlaute): # on Unix

	perl -i -p - myfile 
	  s/\304/Ae/g; s/\326/Oe/g; s/\334/Ue/g;
	  s/\337/sz/g; s/\344/ae/g; s/\366/oe/g; s/\374/ue/g
	  __END__

Substitue German mutated vowels (Umlaute): # on Windows, not ok

	perl -i -p - myfile 
	  s/\0216/Ae/g; s/\0231/Oe/g; s/\0232/Ue/g;
	  s/\0341/sz/g; s/\0204/ae/g; s/\0224/oe/g; s/\201/ue/g
	  __END__

Replace some HTML-characters:

	perl -i -pe - myfile
	  s/&Auml;/\304/g; s/&Ouml;/\326/g; s/&Uuml;/\334/g;
	  s/&szlig;/\337/g; s/&auml;/\344/g; s/&ouml;/\366/g;
	  s/&uuml;/\374/g; s/&amp;/\&/g;
	  s/&lt;/</g; s/&gt;/>/g
	  __END__

Print words on separate lines, while converting decimal numbers into octal ones:
```
	perl -ane 'foreach (@F) {printf("%s = %o\n", $_, $_)}' myfile
```
Print words on separate lines, while converting octal numbers into decimal ones:
```
	perl -ane 'foreach (@F) {print "$_ = ", oct($_), "\n"}' myfile
```

Print ascii values of all characters:

	perl -lne 'print map ord, split //' myfile

Print the words of each line in reverse order:

	perl -lane 'print join " ", reverse @F' myfile

Print the lines of a file in reverse order:

	perl -F"\n" -an - myfile
		BEGIN {$/=undef; $\=$"="\n"}
		@G = reverse @F; 
  		print "@G";
		__END__

Sort a file, output the result:

	perl -F"\n" -an - myfile
		BEGIN {$/=undef; $\=$"="\n"}
		@G = sort @F; 
  		print "@G";
		__END__

Sort a file and output the result, omitting identical entries (a la uniq):

	perl -F"\n" -an - myfile
		BEGIN {$/=undef; $\=$"="\n"}
		@G = sort @F;
		for ($i = 0; $i < @G; $i++) {
		    if ($last ne $G[$i]) {print "$G[$i]"};
		    $last = $G[$i];
		};
		__END__

Join lines ending with backslash (\):

	perl -ape 'if (/\\$/) {chop;chop}' myfile

Find palindrome words in lines:

	perl -an - myfile
	  map  {if ($_ eq (scalar reverse $_)) {print "$_\n"}} @F;
	  __END__

Generate permuted index (ptx) from lines:

	perl -an - myfile
	  for $i (0 .. scalar(@F)-1) {
	      print "@F[$i .. scalar(@F)-1, 0 .. $i-1]\n";
	  }
	  __END__

4. Data Types and Parameter Passing

Use a symbolic reference:

	perl -l
	no strict;
	$index=5; $var = "arr$index";
	$$var = 17; print $arr5;
	__END__

	perl -l
	  no strict; $index=5; $var = "arr$index";
	  $$var = 17; print $arr5'
	__END__

Use a hard reference:

	perl -l
	  use strict "refs";
	  $var=1; *ref = \$var; $ref = 2; print "$var = $ref"
	__END__

Use a hard reference to an anonymous array:

	perl -l
	  use strict "refs";
	  $a = [split (/:/, "a:b:c")];
	  foreach (@$a) {print}
	__END__

Or the other way: Use a hard reference to an anonymous array:

	perl -l
	  use strict "refs";
	  *a = [split (/:/, "a:b:c")];
	  foreach (@a) {print}
	__END__

Use a hard reference to an anonymous hash:

	perl -l
	  use strict "refs";
	  *h = {I => "1", V => "5"};
	  foreach (keys %h) {print "$_ $h{$_}"}
	__END__

Pass a variable by reference:

	perl -l
	  use strict "refs";
	  sub f {local (*l) = @_; $l++; print "l:$l"};
	  print $x=2; f(x); print $x
	__END__

Pass a function as parameter:

	perl -le 'sub f{print "in f"}; sub g{local ($h) = @_; &$h}; &g(\&f)'

Pass a function with arguments as parameter:

	perl -l
	  sub f{print "in f: @_"};
	  sub g{local ($h,$arg) = @_; &$h($arg)};
	  &g(\&f, 12)
	__END__

local variables are visible in calling functions, my variables are not:

	perl
	sub g {$m++; $l++};
	sub f {
	  my $m; local $l;
	  $m++; $l++;
	  g();
	  print "m = $m, l = $l\n";
	}
	f();
	__END__

Print a data structure pointed to be a hard reference:
don't use cut&paste because of shell history commands here, but store in a file instead!

	perl
	
	sub print_ref {
	  my $hdref = $_[0];
	
	  if (ref($hdref) eq "REF") {
	    print "Ref = \"", $hdref, "\"\n";
	  } elsif (ref($hdref) eq "SCALAR") {
	    print "Scalar = \"", $$hdref, "\"\n";
	  } elsif (ref($hdref) eq "ARRAY") {
	    print "Array = [";
	    foreach $comp (@$hdref) {
	      print " $comp ";
	    }
	    print "]\n";
	  } elsif (ref($hdref) eq "HASH") {
	    print "Hash = {";
	    foreach $comp (keys %$hdref) {
	      print " $comp => $$hdref{$comp} ";
	    }
	    print "}\n";
	  } elsif (ref($hdref) eq "CODE") {
	    print "Code = \"", $hdref, "\"\n";
	  } elsif (ref($hdref) eq "IO::Handle") {
	    print "IO = \"", $hdref, "\"\n";
	  } elsif (ref($hdref) eq "GLOB") {
	    print "GLOB = \"", $hdref, "\"\n";
	  } else { 
	    print "not processed: ", $hdref, "\n";
	  }
	}
	
	$sca='three';
	@arr=('one', 'two');
	%har=('alpha' => 'first', 'beta' => 'second', 'gamma' => 'third');
	
	# use with an explicit hard reference variable
	$rs=\$sca;
	print_ref($rs);
	
	# or use with directly with a hard reference
	print_ref(\@arr);
	print_ref(\%har);
	print_ref(\&print_ref);
	print_ref(\$rs);

	$cr = sub {print "hello from anonymous sub\n"};
	print_ref($cr);
	# &{$cr};

	$gr = \*arr;
	print_ref($gr);
	
	$ir = *STDIN{IO};
	print_ref($ir);

	print_ref("my variable");
	
	__END__

5. Nested Data Structures

Generation and access of a multi-dimensional array (list of list).

	perl - # a chess board configuraton
	printf "%53s", "Chess starting configuration\n";
	print "=" x 72, "\n";
	$chess[1][1] = $chess[1][8] = "castle";
	$chess[1][2] = $chess[1][7] = "knight";
	$chess[1][3] = $chess[1][6] = "bishop";
	$chess[1][4] = "queen"; $chess[1][5] = "king";
	foreach $j (1 .. 8) {
		$chess[2][$j] = $chess[7][$j] = "pawn";
		$chess[8][$j] = $chess[1][$j];
	};

	for ($i = 8; $i > 0; $i--) {
		printf "%-8s", $i;
		foreach $j (1 .. 8) {
			printf "%-8s", $chess[$i][$j]
		}
		print "\n";
	} 

	printf "%-8s", "";
	foreach $j ("A" .. "H") {
        	printf "%-8s", $j
	}
	print "\n";
	__END__

Transposing a matrix (i. e. interchanging rows and columns) contained in file inputfile where the elements are separated with ":" is done with:

	perl -F':' -an - inputfile
	chop($F[-1]);
	$M[$.] = [@F];
	$cols = ($cols > scalar @F) ? $cols : scalar @F;
	END {for ($j = 0; $j < $cols; $j++) {
		for ($i = 1; $i <= $.; $i++) {
		     print "$M[$i][$j]";
		     if ($i < $.) {print ":"} else {print "\n"}
		}
	    }
	}
	__END__

Generation and access of a hash of arrays: Each word in the input represents an entry into a hash array, the values of the hash are arrays containing all the line numbers where the word occurred.

	perl - myfile
	while (<>) {
  	  foreach $word (split) {
	    push @{ $LineNo{$word} }, $.;
  	  }
	};
	END {
          foreach $word (keys %LineNo) {
            print "$word:";
            while ($lno = shift @{ $LineNo{$word} }) {
              print " $lno";
            }
            print "\n";
          }
	}
	__END__

Generation, modification and access of a hash of hashes.

	perl
        %Capitals = (
	    Asia => { Japan => "Tokyo", India => "Delhi"},
	    Europe => { Germany => "Bonn", France => "Paris", Spain => "Madrid"},
        );
         
        $Capitals{Europe}{Germany} = "Berlin"; # change an entry

        # add a new hash array:
        $Capitals{Africa} = {Tunesia => "Tunis", Egypt => "Cairo"};

        # add another subhash level, this means loosing Washington :-)
        $Capitals{America}{USA} = {Texas => "Austin", Colorado => "Denver"};

        foreach $continent (keys %Capitals) {
	  print "$continent: ";
	  foreach $nation (keys %{ $Capitals{$continent} }) {
	    if (defined %{ $Capitals{$continent}{$nation} } ) {
		print " $nation (";
		foreach $state (keys %{ $Capitals{$continent}{$nation}}) {
		  print "$state = $Capitals{$continent}{$nation}{$state}, ";
		}
		print ") ";
	    } else {
	       print "$nation = $Capitals{$continent}{$nation}, ";
	    }
	  }
	  print "\n";
        }
      	__END__

6. Information about Files

Print the names of all text files that have been changed this week:

	perl -le 'foreach (@ARGV) {print if (-T and (-M) < 7)}' *

Print all words together with their frequency:

	perl -an - myfile
	foreach $w (@F) {$lex{$w}++};
	END { while (($w, $i) = each %lex) {print "$w\t$i\n"} }
	__END__

If the term word is seen more rigorously, this might be done with:

	perl -n - myfile
	  s/^\W+//; foreach $w (split (/\W+/)) {$lex{$w}++};
	  END { while (($w, $i) = each %lex) {print "$w\t$i\n"} }
	__END__

Print line, word, and character count of a file (a la wc): (Cannot use -l here, it cheats the line count)
```
	perl -ane '$l++; $w += @F; $c += length; END {print "$l $w $c\n"}'  myfile
```

Print line, word, and character count of stated files (a la wc):

	perl -an - *
	  $l++; $w += @F; $c += length;
	  if (eof) {$L += $l; $W += $w; $C += $c;
	  printf "%7s%8s%8s %s\n", $l, $w, $c, $ARGV; $l=$w=$c=0};
	  END { printf "%7s%8s%8s total\n", $L, $W, $C}
	__END__

List the names of all files in the current directory which are missing or different in directory ../Old. This is an example where a complete file is read into memory with one statement.
```
	perl -0777 - ../Old
	foreach $f (glob("*")) {
	  open(F,$f);
	  $a = <F>;
	  open(G,"$ARGV[0]/$f");
	  $b = <G>;
	  if ($a ne $b) {print "$f\n"}
	}
	__END__
```

Permanently oberserve file "myfile" and print a message when it was modified:

	perl - myfile
	$o = (stat "$ARGV[0]")[9];
	while (sleep 1) {
	  $n = (stat "$ARGV[0]")[9];
	  if ($n != $o) {print "$ARGV[0] modified\n"; $o = $n}
	}
	__END__

Permanently oberserve a set of files and print a message when one of them was modified:

	perl -l - myfiles*
	foreach $word (@ARGV) {
	  $o{$word} = (stat $word)[9]
	}
	while (sleep 1) {
	  foreach $f (keys %o) {
	    $n = (stat $f)[9];
	    if ($n != $o{$f}) {print "$f modified"; $o{$f} = $n}
	  }
	}
	__END__

Comparison of a group of binary files. First, all of them are opened, then compared to the first one. This is an example where the filehandle is given by the filename.

	perl - *
	  foreach $f (@ARGV) {open($f,"$f") or die "Cannot read $f"};
	  $f = shift ARGV;
	  while (sysread $f,$i,1024) {
	     $b++;
	     foreach $g (@ARGV) {
		sysread $g,$j,1024;
		if ($i ne $j) {
		    print STDERR 
		    "Difference between $f and $g in KB $b\n"
		}
	     }
	  }
	  __END__

Sort file listing from ls -l descending by file size:

	perl
	   @LS = `ls -altr`;
	   foreach my $x (@LS) {
	     @F = split(/\s+/,$x);
	     $res{scalar(@LS) * $F[4] + $i++} = $x;
	   };
	   foreach my $r (sort {$b <=> $a} keys %res) {
	     print $res{$r};
	   }
	   __END__

Output the name of each file stated on the commandline which misses a newline as last character:

	perl - myfile1 myfile2
	   for (@ARGV) {
	      open(F, $_) or warn "Cannot open $_" and next;
	      seek(F,-1,2) or warn "Cannot position $_" and next;
	      $c = getc(F) or warn "Cannot read $_" and next;
	      if (ord($c) != 10) {print "$_\n"};
	   }
	   __END__

On Unix Systems, ls -l shows only the day of the last modification, if this is more than a year ago. To get the actual time additionally, use the following, which also sortes by time:

	perl - *
           foreach $file (@ARGV) {
	     $Mod{$file} = (stat $file)[9];
	   }
	   @Sorted = sort { $Mod{$a} cmp $Mod{$b} } keys %Mod;  
	   foreach $file (@Sorted) {
	     print scalar localtime($Mod{$file}), "  $file\n";
	   }
	   __END__

Permanently observe a directory and print a warning if it does not fit onto a floppy disk.

	perl - /tmp/fd1
	     foreach $dir (@ARGV) {
	       while (sleep 1) {
		 ($s) = (`du -sk $dir` =~ m/(\d*)/); 
		   print "$dir: $s\n" if $s > 1440
	       }
	     }

           __END__

7. Manipulating Files

Uuencoding a file, i. e. convert to readable ASCII characters with a fixed line length.
```
	perl -e 'BEGIN {$/=undef}; END {print pack('u', <>)}' myfile
```

The opposite is uudecoding a file:

	perl -e 'BEGIN {$/=undef}; END {print unpack('u', <>)}' myfile

Print all lines of all files prepending filename and line number. The function close resets $. for each new file.
```
	perl - *
	while (<>) {
	  print "$ARGV:$. $_";
	  if (eof) {close ARGV}
	}
	__END__
```

If the previous output was saved to a file, it can be unpacked with:

	perl -ln - /tmp/All
	($f, $c) = m{(.*?):.*? (.*)};
	if ($f ne $old) {open(FH, ">$f"); $old = $f};
	print FH $c
	__END__

And the names of the files therein can be listed with:

	perl -ln - /tmp/All
	  $f = substr($_,0,index($_,":"));
	  if ($f ne $o) {print "$f"};
	  $o=$f
	__END__

Join two nearly identical files a and b by replacing the last column of the first one by the last of the second one, where columns are separated with ":"

	perl - a b
	  open(F, "$ARGV[0]") or die "Cannot open $ARGV[0]";
	  open(G, "$ARGV[1]") or die "Cannot open $ARGV[1]";
	  while(<F>) {
	    @f = split (/:/, $_);@g = split (/:/, <G>);
	    for ($i=0; $i < $#f; $i++) {
	        print "$f[$i]:"
	    }
	    print "$g[-1]";
	  }
	__END__

Cut the binary file myfile into pieces partddd fitting onto a floppy disk: # needs binmode() on Windows # on DOS, use copy /b part000 + part001 + ... part999 myfile # to restore original file

	perl - myfile
	  open(F,"$ARGV[0]") or die "Cannot read $ARGV[0]";
	  binmode F;
	  $o = "part000";
	  while (sysread F,$i, int (1.3*2**20)) {
	    open (G, ">$o") or die "Cannot open $o";
	    binmode G;
	    syswrite G,$i,length($i) or die "Cannot write to $o";
	    close G or die "Cannot close $o";
	    $o++;
	  }
	__END__

Recollection is than done into file AllParts with

	perl - AllParts
	  $o = "part000";
	  open(F,">$ARGV[0]") or die "Cannot write to $ARGV[0]";
	  while (-r $o) {
	    open(G, $o); 
	    sysread G,$i, 2**21;
	    syswrite F,$i,length($i);
	    $o++;
	  }
	__END__

Mutual exclusive file access.
Access to a file can be blocked when all processes running on the same machine use flock .
```
	#! /usr/local/perl5/bin/perl -s
	open(FH, ">>FlockedFile") or die "Can't open FlockedFile: $!";
	select FH; $| = 1;

	if ($f) {print STDOUT "$$ uses flock on FlockedFile\n"};
	while (1) {
	  if ($f) {flock(FH, 2)}; # lock the file
	  print FH "($$"; sleep 1; print FH ")\n";
	  if ($f) {flock(FH, 8)}; # unlock the file
	  sleep 1;
	}
  
```
Storing the above code in the file fl.pl and then executing
```
	chmod +x fl.pl
	./fl.pl -f &
	./fl.pl -f &
  
```
results in FlockedFile containing lines which the process ids of each process enclosed properly inside (). If another fl.pl process is started omitting the option -f, the brackets may become intermixed.
Note: Selecting a filehandle requires print to use it as default, so STDOUT is explicitly required.

Compute a sum of all the characters in a file interpreted as integers:

	perl -nl -0777e '$r = 0; foreach (split //) {$r += ord} print $r' myfile

8. Further File Access

Flushing (or unbuffering) an output stream:

	perl -l - /tmp/perl.fs
	open (FS, ">$ARGV[0]");
	select FS; $| = 1;
	while (++$i) {print FS $i; sleep 1}
	__END__

Reading the file while writing to it is not finished is done with (a la tail -f, but this might cause problems on some systems, have a look at the perl faq):
```
	perl - /tmp/perl.fs
	open (F, "$ARGV[0]");
	while (sleep 3) {
	  while (<F>) {print}
	}
	__END__
```

Redirecting Perls STDOUT and STDERR to one file:

	perl - stdouterr
	  print "Check file $ARGV[0]\n"; 
	  open (STDOUT, ">$ARGV[0]");
	  open (STDERR, ">&STDOUT");
	  print "Hello to STDOUT\n";
	  print STDERR "And to STDERR\n"
	__END__

Generate a listing of all *.pl files in /tmp/listing:

	perl - *.pl > /tmp/listing
	  use Cwd;
	  print "Printing in ", cwd(), ": ", scalar localtime(), "\n\n";
	  foreach $f (@ARGV) {
	    $l = 0;
	    open (F, $f);
	    while (<F>) {$l++};
	    printf "%6d %s\n", $l, $f; $L += $l; 
	  }
	  print "=" x 6, " ", "=" x 20, "\n";
	  printf "%6d %d files\n", $L, scalar(@ARGV);

	  foreach $f (@ARGV) {
	    printf "\n\nFile: %s\tLast Modification: %s\n", $f,
			scalar localtime((stat $f)[9]);
	    close F;
	    open (F, $f);
	    while (<F>) {printf "%6d\t%s", $., $_}
	  }
	  __END__

Generate a sequence of test files. This can be used for the next example:

	perl 
	    $last = 20;
	    for $idx (0 .. $last) {
	      $file = "/tmp/Testfile";
	      print "Generating files ${file}0 - $file$last\n";
	      open(STDOUT, ">$file$idx") or die "Cannot write to $file$idx";
	      print
	        "$file$idx, line 1\n",
	        "$file$idx, line 2\n",
	      ;
	      if ($idx < $last) {print "#include \"$file" , $idx + 1, "\"\n"};
	      print "$file$idx, line 4\n";
	    }
            __END__

Expand include-directives, i. e. if #include "filename" is stated in a file, read the contents of filename. The output is prepended by the filename, each new included file is indented by one blank more (thanks to CPAN). To avoid infinite output on circular includes, files opened are not reopened.

	perl - /tmp/Testfile0
            foreach $file (@ARGV) {
              &process($file, 'fh000', -1);
            }
	    %OpenFiles = (); # keep track of currently open files

            sub process {
              local($filename, $input, $depth) = @_;
              $input++;               # this is a string increment
	      unless (open($input, $filename)) {
		print STDERR "Cannot open $filename: $!\n";
		return;
	      }
              $depth++;
	      $OpenFiles{$filename} = 1;
	      while (<$input>) {      # note the use of indirection
		if (/^#include "([^"]*)"/) {
		  if ($OpenFiles{$1}) {
		     print ' ' x $depth, "$filename: ", $_;
		  } else {
		     &process($1, $input, $depth);
		     next;
		  }
		}
		print ' ' x $depth, "$filename: ", $_;
	      }
	      $OpenFiles{$filename} = 0;
              $depth--;
	      close($input);
            }
             __END__

9. Accessing the Directory Tree

File names.
Print the name of each file in the current directory tree whose name match LOG case insensitive (i). Directories (-d) pointed to by a symbolic link (-l) are not processed:
```
	perl -l -
	   sub g {
		foreach (glob "$_[0]/*") {
		   -d && g($_) unless -l; 
		   print if /LOG/i
		}
	   };
	   g(".")
           __END__
```
The glob might cause problems when too many files are located in one directory. Then you should use readdir or use File::Find instead, e.g. like this to find all HTML files on a Unix machine:
```
	perl -MFile::Find -le 'find(sub {print $File::Find::name if ($_ =~ /\.html$/)}, ".")'
```

File names returned as array or hash.
If the files are to be processed further, it might be preferable to store them in a list resp. array.
Return the names of each file in /tmp and print them. Directories pointed to by a symbolic link are ignored again. This time directories are also checked for read access by using _ for the last stat call on a file:

	perl
	sub g {
	  my @res = ();
	  foreach $file (glob "$_[0]/*") {
	    if (-d $file and -r _ and not -l $file) {
		push (@res, g("$file"));
	    }
	    push (@res, "$file");
	  }
	  return @res;
	}

	@res = g("/tmp");
	foreach $f (@res) {print "$f\n"}
	
	__END__

And here is a version taking a reference to a hash array as argument:

	perl
	sub g {
	  foreach $file (glob "$_[0]/*") {
	    if (-d $file and -r _ and not -l $file) {
		g("$file", $_[1]);
	    }
	    ${$_[1]}{"$file"} = 1;
	  }
	}
	
	$res = {};
	g("/tmp", $res);
	
	foreach $f (keys %$res) {print "$f\n"}
	__END__

File ownership.
Print the name of each file in the current directory tree which is not owned by the calling user:

	perl
	  sub g {
	    foreach (glob "$_[0]/*") {
	  	-d && g($_) unless -l;
		print "$_\n" if ($> != (stat $_)[4]);
	    }
	  }
	  g(".")
	__END__

File contents.
Print the name of each file in the current directory tree containing the text findMe in it:

	perl -l - findMe
	  sub g {
	    foreach $f (glob "$_[0]/*") {
	    	-d $f && g($f) unless -l $f;
		open (F,"$f");
		my $h = 0;
		while (<F>) {
		  $h++ if (/$ARGV[0]/)
		}
		print $f if $h
	    }
	  }
	  g(".")
	__END__

Outside symbolic links
Print the name of each file in the current directory tree which is a symbolic link pointing outside the tree:

	perl
	use Cwd;
	select STDERR; $| = 1;
	select STDOUT; $| = 1;
	$rootDir = cwd();
	
	sub listLinks {
	  $actDir = $_[0];
	  if ($v) {print "Directory $actDir\n"};
	  if (! -r $actDir) {
	     print STDERR "Cannot read $actDir\n";
	     return;
	  };
	  foreach $f (glob "$actDir/*") {
	     if ($v) {print "Processing $f\n"};
	     -d $f && listLinks($f) unless -l $f;
	     if (-l $f) { # only search for symbolic links
		$s = $f; # remember source file name
		while (-l $f) { # find final file
		   $f = readlink $f;
		};
		if ($d && not -d $f) {next}; # -d: only process directories
		$f =~ s{^./}{};	# remove leading ./
		if ($f !~ m{^/}) { # for relative file names ...
		   $f = $actDir . "/" . $f; # append current directory 
		}
		$f =~ s{//*}{/}g; # remove multiple / inside name
		while ($f =~ s{/[^./]+/\.\.}{}) { 
		   ; # remove parts /subdir/.. inside file names
		};
		if ($rootDir ne substr($f,0, length($rootDir))) {
		   print "$s -> $f\n"; # sym link pointing outside rootDir
		}
	     }
	  };
	};
	listLinks($rootDir);
	__END__

To see each directory and file, replace the first line by perl -s - -v >& /tmp/OutSideLinks and check the resulting file.
Furthermore, appending -d to - processes only those symbolic links which point to directories.

Directory changing.
Step throught the directory tree and print each subdirectory indented by 2 blanks more. Non-accessible subdirectories or subdirectories pointed to by symbolic links are not stepped into. Files are output, too; directories get a slash appended.

	perl -l
	  sub f {
	    chdir $_[0] or return;
	    print "  " x $d++, "$_[0]/"; # append slash after directory
	    foreach (glob "*") {
	    	-f && print "  " x $d, "$_"; # print file name
	    	-d && f($_) unless -l
	    }
	    chdir("..");
	    $d--
	  }
	  f(".")
	  __END__

Find empty subdirectories of /tmp

	perl - /tmp
	  use File::Find;
	  $ARGV[0] = '.' unless $ARGV[0];
	  find(\&wanted, $ARGV[0]);

	  sub wanted {
	      if (-d) {
		  opendir(DIR, "$_") || die "can't opendir $_: $!";
		  @Files = readdir(DIR);
		  if (scalar(@Files) <= 2) {
		     print "$File::Find::name\n";

		  }
	      }
	  }
	  __END__

10. Accessing the User Environment

Print all directory entries in the MANPATH that do not exist:

	perl -le 'foreach (split ":", $ENV{MANPATH}) {print if not -d}'

For each argument given, print the full filename of each executable file on PATH implementing argument (similar to the UNIX command which ):
```
	perl -l - dir perl
	foreach $d (split (":", $ENV{"PATH"})) {
  	  foreach $w (@ARGV) {print "$d/$w" if (-x "$d/$w")}
	}
	__END__
```
Find the directory containing the Perl Module Tk :
```
	perl -le 'foreach (@INC) {print if glob "$_/*Tk*"}'
```
If the module contains submodules, e.g. File::Find , substitute :: by the path separator ( / on Unix, \ on Windows).
The total path name to the module can be used to view its documentation, like
```
 perldoc /usr/lib/perl5/File/Find.pm 
   
```
or
```
 perldoc `which pod2latex`
   
```

Print all available Perl modules:

 perl
	sub g {
	  opendir(DIR, "$_[0]") or die "Cannot open $_[0]";
	  foreach $f (readdir(DIR)) {
	    if ($f ne '.' && $f ne '..' &&
	    		-d "$_[0]/$f" && not -l "$_[0]/$f") {
		g("$_[0]/$f");
	    };
	    print "$_[0]/$f\n" if ($f =~ /\.pm$/)
	  }
	  closedir(DIR);
	};
        foreach $d (@INC) {g("$d")};
	__END__

Collect all manpages for tools starting with "perl" in one file:

 perl - > /tmp/manpages
        foreach $dir (split ":", $ENV{MANPATH}) {
	  if (-d $dir) {
	    foreach $mp (grep {s{^.*\/}{}; s{\..*$}{}} glob "$dir/man*/perl*") {
	      $manpage{$mp}++;
	    }
	  }
	}
	foreach $mp (keys %manpage) {
	  print `man $mp | col -b`;
	}
	__END__

Print all mail entries from user sb@c-lab.de:

	perl -an0777 -F'/From\s/' -e 'foreach (@F) {\
		print "From ", $_ if /^sb\@c-lab.de/}' /var/cmail/sb

Print all mail entry ids from user sb@c-lab.de, and wait for new ones to be printed, too:

	perl -0777 -e 'while (sleep 1) {open (F, "/var/cmail/sb") or \
		die "no access"; \
     	while (<F>) { foreach $m (split /From\s/) { \
	  if ($m =~ /^sb\@c-lab.de/) { \
	      if ($m =~ /message-id:\s<(.*)>/i) { \
	       unless (exists $h{$1}) {$h{$1} = 1; print $1, "\n"; } } } } } }'

Print environment variable MANPATH, but suppress double entries:

	perl 
	foreach (split ":", $ENV{MANPATH}) {
	  if (not exists $h{$_}) {
	    push @a, $_; $h{$_}++}
	}
	END{print join ":", @a}
	__END__

11. Time and Date

Print the current time in seconds (except leap seconds) counted since 1.1.1970:
```
	perl -le 'print time()'
```
Print the current time and date:
```
	perl -le 'print scalar localtime()'
```

Print the current time and date in German format:

	perl -l
	@t=localtime(); $t[4]++; $t[6]++; $t[7]++; $t[5]+=1900;
	print STDOUT (So, Mo, Di, Mi, Do, Fr, Sa)[$t[6]],
		", $t[3].$t[4].$t[5], $t[2]:$t[1]:$t[0]h",
		", $t[7]. Tag im Jahr, ",
		$t[8] ? "Sommerzeit" : "Winterzeit"
	__END__

Print the number of the current week:

	perl
	    @t=localtime();
	    $year = $t[5] + 1900;
	    open (F, "cal 1 $year |") or die "cannot call cal";
	    while (<F>) {
	      if ($. == 3) {
		@F = split(' ');             
		$week = int (($t[7] + 7 - scalar(@F))/7);
		last;
	      }
	    }
	    print "This is week number $week\n";
            __END__

Print the current time permanently:

	perl -e '$|=1; while (1) {print "\r", scalar localtime; sleep 1}'

12. System and User Information

Output some system information:

	perl -e 'print "Process $$ running on $^O by $^X $] from $0 at $^T\n"'

	perl -l
	print "Started by process ", getppid, ",
	time consumed: ", times
	__END__

Output some user information:

	perl -l
	print "I am user $> (real: $<) from group $) (real: $()"; 
	print "My username: ", scalar getpwuid ($<), " (", getlogin, ")"; 
	print "My real name is ", (getpwnam(getlogin))[6];
	print "This is line ", __LINE__, " in file ", __FILE__,
		", package ", __PACKAGE__
	__END__

Inform about users entering/leaving the current machine:

	perl - 
	open(F, "who|") or die "cannot execute who";
	while (<F>) {
	  @F = split;
	  $Old{$F[0]} = "@F";
	}
	close(F) or die "cannot close who";
	while (sleep 1) {
	  open(F, "who|") or die "cannot execute who again";
	  while (<F>) {
	    @F = split;
	    $New{$F[0]} = "@F";
	    if (! exists $Old{$F[0]}) {
	       print "New visitor arrived at " .
	       	scalar localtime() . ": " . $New{$F[0]} . "\n";
	    }
	  }
	  close(F) or die "cannot close who again";
	  foreach $user (keys %Old) {
	    if (! exists $New{$user}) {
	       print "Old visitor left at " . 
	       	scalar localtime() . ": " . $Old{$user} . "\n";
	    }
	  }
	  %Old = %New;
	  %New = ();
	}
	__END__

13. Exhausting the System

The examples stated here are useful to take resources away from a system in order to test other software.

Putting load on the CPU, i. e. wasting processor time:
```
	perl -e 'while (1) {}'
```

The maximal number of additional processes:

	perl -l
	while (++$i) {$pid = fork; last unless $pid};
	unless (defined $pid) {print --$i, " additional processes"}
	__END__

Thus putting 200 useless processes onto the system is done with:

	perl -l
	while (++$i <200) {$pid = fork; last unless $pid};
	if ($pid) {while (sleep 10) {}}
	__END__

A similar construct can be used to generate a zombie child process:

	perl -l
	$pid = fork;
	if ($pid) {print "parent: $$"; while (1) {}}
	else {print "child: $$"};
	END {print "process $$ finished"}
	__END__

Determine the number of file descriptors per process, assuming 3 for STDIN, STDOUT and STDERR already exist:

	perl 
	while (++$i) {open("F$i", "/dev/null") or
	die $i + 2, " file descriptors available per process\n"}
	__END__

Allocate main memory per megabyte until there is no more available:

	perl 
	while (++$i) {
	  vec($v[$i], 2**20, 8) = 1;
	  print "Allocated about $i MB\n"
	}
	__END__

Exhausting at least 16 MB of system memory permanently:

	perl 
	vec($v, 16*2**20, 8) = 1;
	while (1) {}
	__END__

Write to a disk file megabyte chunks until there is no more disk space free. Print the number of megabytes written.

	perl - HugeFile
	vec($w, 2**20, 8) = 1; # allocate 1 MB
	open("F", ">$ARGV[0].$$") or die "Cannot write to $ARGV[0].$$";
	while (syswrite F, $w, 2**20) {$i++};
	warn "Nearly $i MB allocated\n";
	print "Please remove $ARGV[0].$$\n"
	__END__

Find the highest integer representable on this system. (On some systems, this is already the lowest negative integer :-()

	perl 
	use integer;
	$o = 0; $n = 2**16;
	while ($o < $n) {$o = $n; $n += 2**16};
	$n = $o + 1;
	while ($o < $n) {$o = $n; $n++};
	print "Highest/Lowest integer on system is: $n\n"
	__END__

Find the highest floating point number representable on this system:

	perl 
	$o = 0; $n = 1;
	while ($n/2 < $n) {$o = $n; $n *= 2};
	$d = $o;
	while ($d > 1) {
	  if ($n/2 < $n) {$o = $n} else {$n = $o};
	  $n += $d; $d /= 2;
	}
	print "Highest float on system is ~ : $o\n"
	__END__

Find the approximately finest time resolution of the machine:

	perl
	$n = 100; # number of trials per second, vary it ...
	
	$t = 10; # 10 seconds total time
	$c = $t * $n; # total number of calls
	$d = 1/$n; # time set for one call
	$t0 = time();
	while ($c--) {select undef, undef, undef, $d};
	$t1 = time();
	print "Time resolution is ", ($t1 - $t0)/($t * $n),
		" seconds or less\n";
	__END__

And finally, every machine is brought to its knees by executing Ackermann's example of a recursive function that is not primitive recursive:

	perl
	sub ack ($$) {
	  my($l, $r) = @_;
	  if ($l == 0) {return $r+1}
	  elsif ($r == 0) {return ack($l-1, 1)}
	  else {return ack($l-1, ack($l, $r-1))}
	}

	for ($i = 0; $i <= 4; $i++) {
	  print "ack($i,$i) = ", ack($i,$i), "\n";
	}
	__END__

14. Handling Signals and Timeouts

Signals give processes a chance to react to actions which might arise asynchronously.

A simple signal handler. Starting it in the background with & and sending it kill commands shows the effect:

	perl -l 
	$SIG{"TERM"} = sub {print "I want to live forever!"};
	print "Process $$ started";
	while (1) {}
	__END__

After a signal is processed, execution continues where it resumed:

	perl 
	$SIG{"TERM"} = sub {print " -- SIGTERM ignored! -- "};
	$| = 1;
	while (1) {
	  print "Thinking ...  "; sleep 5;
	  print "Eating ...\n"; sleep 5
	}
	__END__

Sending signal 0 just tests the existence of a process without harming it. Print Process ID of each process that may be signalled to and has a lower PID than the current one:
```
	perl -le 'while (++$i < $$) {if (kill 0 => $i) {print "$i"}}'
```
Toggling a variable when SIGUSR1 is delivered to this process with kill. This can be used to configure a process at runtime without restarting it.
```
	perl -le '$SIG{"USR1"} = sub {$v = 1-$v; print "$v"}; while (1) {}'
```
Sending SIGUSR1 to the above started process toggles the status of $v. This can be done either with the UNIX kill command or from Perl (assuming 704 being the process id):
```
	perl -e 'kill "USR1", 704'
```

Stopping a long action after some time (3 seconds). This can be used for very rough benchmarks:

	perl
	$i = 0;
	$SIG{"ALRM"} = sub {die "Counted up to $i\n"};
	alarm 3;
	while (1) {$i++}
	__END__

Generate an infinite sequence of actions with random run time. Stop each one that takes longer than 3 seconds. Here integer parts of random numbers for sleeping are used. Each alarm that is executed kills the previous one.
```
	perl -l
	$SIG{"ALRM"} = sub {warn "Woke up $i after 3 seconds\n"};
	while (++$i) {
	  alarm 3;
	  $st = 1 + int(rand 6);
	  print "$i: sleeping for $st seconds";
	  sleep $st
	}
	__END__
```

An argument 0 for alarm does not call $SIG{"ALRM"}, it only cancels the alarm set previously.
This can be used to timeout user input (Thanks to Tom Christiansen):

	perl
	  $SIG{"ALRM"} = sub {die "TimeOut"};
	  eval {alarm 5; print "Input: "; $s = <>; alarm 0};
	  if ($@) {print "\nYou waited too long: $@"}
	  else {print "You entered $s"}
	__END__

Kill the parent shell:
```
	perl -e 'kill "KILL", getppid'
```

Stop and resume the parent shell after 10 seconds:

	perl -e 'kill "STOP", getppid; sleep 10; kill "CONT", getppid' &

Inform about a killed child process. Even when the child is killed hard with
kill -KILL pid-of-child
the parent will be alive and informed. Of course, the parent should not be killed.
```
	perl -l
	$pid = fork; 
	if ($pid) {
	  print "Parent: $$";
	  $cpid = wait;
	  print "Child $cpid died";
	} else {print "Child: $$";
	  while (sleep 2) {print $i++};
	}
	__END__
```

And here is a variation where each time when a child is killed a new one is started.

	perl 
	sub daemon {while (sleep 2) {print $i++, "\n"}};
	while (1) {
	  $pid = fork; 
	  if ($pid) {
	    print "Parent: $$\n";
	    $cpid = wait;
	    print "Child $cpid died\n";
	  } else {
	    print "New Child: $$\n";
	    daemon();
	  }
	}
	__END__

15. Setuid Scripts

Setuid scripts give processes started by others limited access to the resources of the script owner.

A simple append.
Setuid scripts have the s-bit set, so when executing them a user takes over the effective user id of the user who owns the script.
Here is an example of a script which appends standard input to the text file append.txt.
```
	#! /usr/local/perl5/bin/perl
	open (TRG, ">>append.txt") or die "Cannot append to append.txt: $!\n";

	while (<>) {
		print TRG;
	}
  
```
The trick is, that other users may execute the script but not access the text file append.txt directly. This is done by storing the above code in the file append.pl and then doing
```
	chmod u+s,g+x,a+x append.pl
	touch append.txt
	chmod u=wr,g=,o= append.txt
  
```

A more complex append.
Another possibility is to create a child process with is reset to the access rights of the real user. This is done with:

	#! /usr/local/perl5/bin/perl
	$ENV{'PATH'} = "/bin:/usr/bin";

	open (TRG, ">>append.txt") or die "Cannot append to append.txt: $!\n";

	die "Can't fork: $!" unless defined ($pid = open(KID, "-|"));

	if ($pid) { # parent
	    while (<>) {
		print KID $_; # parent redirects its STDIN to the child
	    }
	} else { # child
	    $> = $<; # set effective userid to real one
	    while (<>) {
		print TRG; # now the tainted operation is allowed
	    }
	}

16. Regular Expressions

Zero width negative look ahead.
Split on ":" but not if preceded by "\"

	echo "one:two\:too:three" |\
	perl -lne 'require 5.005; foreach (split /(?<!\\):/) {print}'

C++ comments.
For a C++ source text file being stored completely in $_, C++ line comments (//) can be changed to C comments with (thanks to Jeffrey Friedl, line breaks are inserted for readability):
```
	
    s#//(.*)|/\*[^*]*\*+([^/*][^*]*\*+)*/|"(\\.|[^"\\])*"|'
    	(\\.|[^'\\])*'|[^/"']+#  $1 ? "/*$1 */" : $& #ge;
  
```
C comments.
For a C source text file being stored completely in $_, C comments can be stripped off with (thanks to Jeffrey Friedl, line breaks are inserted for readability):
```
	
    s#/\*[^*]*\*+([^/*][^*]*\*+)*/|([^/"']*("[^"\\]*(\\[\d\D][^"\\]*)*
    "[^/"']*|'[^'\\]*(\\[\d\D][^'\\]*)*'[^/"']*|/+[^*/][^/"']*)*)#$2#g;
  
```
A simple parser.
Files are read line by line. Blocks of text between $begin and $end are collected and output between quotes with the line number where the block begins.
Blocks may span several lines, multiple blocks in one line are allowed, but nesting is not.
Shrink each sequence of two or more blank lines to only two empty lines.

17. Modules and Packages

Define a package:

	#! /usr/local/perl5/bin/perl
	package myPackage;	# declare a new namespace
	require Exporter;	# explicit exportation from this package
	@ISA	= qw(Exporter);
	@EXPORT_OK = qw($u @v f);	# for referring without qualification

	$u = 6;		# an exported scalar variable
	@v = qw("one" "two"); # an exported array variable
	$w = 8;		# this variable is not exported
	sub f {print "Hi from function myPackage::f()\n"};

	1;	# return a true value for use

Storing the above code in the file myPackage.pm in a directory pointed to by the environment variable PERL5LIB or PERLLIB and then executing the following code shows the effect:

	perl -w -
	use strict;	# find e.g. name clashes between packages
	use myPackage qw(@v f);	# this must be a subset of the exported objects
	$main::w = 4;		# qualification is required by use strict

	print "\@v=(@v) from myPackage is imported in this namespace\n";
	print "As is function f: "; &f();
	print "\$u must be qualified: $myPackage::u\n";
	print "\$w exists twice\n";
	print "\t\$myPackage::w = $myPackage::w\n";
	print "\t\$main::w = $main::w\n";
	__END__

Print all scalar, array, hash variables and subroutines of package main and their values:

	perl -l
	sub mysub {
	  print "hello from function mysub\n";
	}
	foreach $v (keys %main::) {
	  if (defined $$v) {print $v, "\t\"", $$v, "\""}
	  elsif (defined @$v) {print $v, "\t\"", @$v, "\""}
	  elsif (defined %$v) {print $v, "\t\"", %$v, "\""}
	  elsif (defined &$v) {print $v, "\t\"", &$v, "\""}
	  else  {print "File Handle $v"}
	}
	__END__

Search all text files in the directory tree starting at Projects . If a file contains the entry lizenz then the full file name is output. The output is redirected to the file /tmp/found .

	perl - Projects lizenz > /tmp/found
	use File::Find;
	find(\&wanted, $ARGV[0]);

	sub wanted {
	    if (-T) {
		open (F, "$_");
		while ($l = <F>) { 
		  if ($l =~ /$ARGV[1]/) {
			print "$File::Find::name\n";
			last;
		  }
		}
	    }
	}

	__END__

18. Named Pipes

A process is started which opens a pipe to file CurrentTime. Each time this file is read from another process on the same machine, the pipe process writes the current date and time into it. (Thanks to the Perl Manpage).

	perl
         $FIFO = 'CurrentTime';

         while (1) {
             unless (-p $FIFO) {
                 unlink $FIFO;
                 system('mknod', $FIFO, 'p')
                     && die "can't mknod $FIFO: $!";
             }

             # next line blocks until there's a reader
             open (FIFO, "> $FIFO") || die "can't write $FIFO: $!";
             print FIFO "Date and time now is ", scalar localtime(), "\n";
             close FIFO;
             sleep 2;    # to avoid dup signals
	 }
	 __END__

19. Formatting

Use of the format facility of Perl in a dynamically way, i. e. compute the line size and the number of lines of the output before fixing the format. The following code should be saved to a file prior to execution.

	perl -s - 
	$content = q {This is the long text content which shall be displayed on
		the right side of the page in one block adjusted to the left.
		The length of each object displayed on the format is computed
		dynamically, i. e. if the contents of the variables $content,
		$subject, $date or $from are changed, this does not affect
		the subsequent code, only its execution.
		Words are wrapped but all other formatting in this string is
		lost.
	
		If you want to see the format specification, use -v on the
		commandline, e. g. perl -s - -v from the command interpreter.
		};
	$content =~ s/(\s)\s*/$1/g; # Just for erasing space sequences
	
	$subject = "Dynamic format example with computed sizes";
	$date = scalar localtime();
	$from = (getpwnam(getlogin))[6]; # the name of the user
	
	$left = (length("Date: ") < length("From: ")) ?
		length("From: ") : length("Date: "); # length of left column
	$middle = (length($date) < length($from)) ?
		length($from) : length($date);	# length of middle column
	$right = 72 - $middle -$left -3; # 3 = leading @ resp. ^ and blank
	$lines = int (length($content) / $right);
			# superfluous lines will be ignored
	
	$formattop = "format STDOUT_TOP = \n" . "=" x 72 
		. "\n\t Dynamically Computed Format Example\n"
		. "\nPage No: @>>\n" . '$%' . "\n" . "=" x 72 . "\n.\n";
	
	$format = "format STDOUT = \n" . "Subject: @" . '<' x 60 . "\n"
		. ' ' x length("Subject: ") . '$subject'
		. "\n\nFrom: @" . '<' x $middle . ' ^' . '<' x $right
		. "\n\t" . '$from' . ",\t" . '$content'
		. "\nDate: @" . '<' x $middle . ' ^' . '<' x $right
		. "\n\t" . '$date' . ",\t" . '$content'
		. ("\n~" . ' ' x ($left + $middle) . ' ^' . '<' x $right .
			"\n" . ' ' x ($left + $middle) . '$content') x $lines
		. "\n.\n";
	
	eval $formattop; die $@ if $@;
	if ($v) {print STDERR "formattop: $formattop\n"};
	eval $format; die $@ if $@;
	if ($v) {print STDERR "format: $format\n"};
	write;
	__END__

20. Accessing the Display

Give an alarm signal and a repeated text enclosed in Ctrl-b's after 6 seconds:
```
	perl -e 'sleep 6; print "\aAwake \cb ${\(\"Right Now \" x 7)} \cb\n"'
```
Output numbers between 0 and 100 on the same position, sleeping 1/5 of a second between two adjacent numbers. The output must be unbuffered ($| != 0) to be visible:
```
	perl
	$| = 1;
	for ($i=0; $i<100;$i++) {
	  printf "%6d", $i;
	  select undef, undef, undef, 0.2;
	  print ${\("\b" x 6)}
	}
	__END__
```

Print all 256 hexadecimal characters:

	perl 
	foreach $i (0 .. 9, "A" .. "F") {
	  foreach $j (0 .. 9, "A" .. "F") {
	    print " $i$j: ", chr(hex("$i$j"))
	  }
	  print "\n"
	}
	__END__

Experimenting with video modes: # on Windows not working

	perl
	foreach $v (1 .. 8, qw/d e f r s u/) {
	  print "Video mode $v: \e[${v}m Effect $v \e[m\n"
	}
	__END__

Accessing the title text of the decoration of an xterm:
```
	perl -e 'print "\e]1;myIcon\cG\e]2;myWindow\cG"'
```

Suppressing the keyboard echo on the terminal: # on Windows not working

	perl
	  system "stty", "-echo";
	  print "Enter: ";
	  $answer = <STDIN>;
	  print "\nYou entered: $answer";
	  system "stty", "echo"
	__END__

copy STDIN to STDOUT, wait for return each time after 40 lines. This is similar to more or less

	perl - -- myFile
	open (TTY, "</dev/tty");
	  while (<>) {
	    if (!($. % 40)) {
		print STDOUT "----- press return for more ";
		getc TTY;
	    }
	    print;
	  }
	__END__

Informing the user on all open xterm windows:

	perl -e '$user = getlogin; \
	foreach $t (grep {s#^$user\s+(\S+).*#/dev/\1#x} `who`) { \
	open (F, ">$t"); print F "\e[7m \aInfo for $user on $t\e[m\n"}'

Refining the output of a diff run.
All lines of two corresponding change blocks (indicated by a letter c enclosed in numbers) are compared and the middle parts are output in reverse video mode. Here, the middle part starts with the first character different and ends with the last character different in both blocks. All other input lines remain unchanged.

	perl - myfile1 myfile2
	open (F, "diff $ARGV[0] $ARGV[1] |") or
		die "Cannot diff $ARGV[0] $ARGV[1]";
	while (<F>) {
	  if (m/^\d/) { # a diff header line
	     show(); # the previous one
	     m/c/ ? ($s = 1) : ($s = 0); # for a change block
	     print;
	  } elsif ($s) { # inside change block
	     if (m/^</) {$l .= $_}
	     elsif (m/^>/) {$r .= $_}
	     elsif (m/^---/) {$m = $_}
	     else {die "Error in line $.: "}
	  } else {print};
	}
	END {show()};
	
	sub show {
	  if (!$m) {return};
	  $ql = length($l) - 1;
	  $qr = length($r) - 1;
	  $l =~ s/^</>/gm;
	  while ($qr-- && $ql--) {
	    $c = substr($l, $ql, 1);
	    if ($c ne substr($r, $qr, 1)) {last}
	  }
	  substr($l, $ql+1, 0) = "\e[27m";
	  substr($r, $qr+1, 0) = "\e[27m";
	  $p = -1;
	  while ($p < length($l) and $p < length($r)) {
	    $c = substr($l, ++$p, 1);
	    if ($c ne substr($r, $p, 1)) {last}
	  }
	  substr($l, $p, 0) = "\e[7m";
	  substr($r, $p, 0) = "\e[7m";
	  $l =~ s/^>/</gm;
	  print "$l$m$r";
	  $l = $r = $m = "";
	}
	__END__

21. Persistent Data Storing

Data that must be kept even when the program has finished can be stored in a database or a DBM file. The following code stores the hash array countHash in the DBM files CountDB.dir and CountDB.pag.
Each word stated on the command line of the script increments the corresponding counter in the hash array, the result is printed. If no command line argument is given, the complete hash is printed.

	#! /usr/local/perl5/bin/perl
	use SDBM_File;
	use Fcntl;
	$filename = "CountDB";

	tie(%countHash, SDBM_File, $filename, O_RDWR | O_CREAT, 0640)
		or die "Cannot open $filename";

	if (@ARGV == 0) {
	   foreach $k (keys %countHash) {print "$k\t$countHash{$k}\n"};
	} else {
	   foreach $word (@ARGV) {
		   $countHash{$word}++;
		   print "$word\t$countHash{$word}\n";
	   }
	}

	untie %countHash;

The effect is illustrated by storing the above code in the file count.pl and then executing

	chmod +x count.pl
	./count.pl one two three
	./count.pl three four five
	./count.pl

22. System Access and Error Trapping

Execute a system command and redirect standard error to standard output:
```
	perl -e 'system("cat nofile 2>&1")' 
```

Trapping a system command.

	perl
	  $res = `ls`;
	  if ($?) {die "Problem: $?"}
	  else {print "$res\n"}
	__END__

Calling a system command, printing a warning if it fails:

	perl -e 'eval {$x= `ls nix`}; $st = ($? >> 8); \
	$si = ($? & 127); $core = ($? & 128); \
	if ($?) {warn "status: $st, signal: $si, core: $core\n"}; \
	print "Result: $x\n"'

Redirecting standard error output prior to starting a system command

	perl
	open (STDERR, ">/tmp/stderr");
	system("cat file_does_not_exist");
	print "check file /tmp/stderr\n";
	__END__

Find the Gregorian Calendar lap:

	perl
	$words = 1 + 12 + 12 * 7 + 365; 
	foreach $year (1700 .. 1800) {
	    if ($words > `cal $year| wc -w`) {
	       foreach $month (1 .. 12) {
	         if (2 + 7 + 28 > `cal $month $year | wc -w`) {
	            print `cal $month $year` ;
	            exit; 
	         }  
	       }
	    }
	}
	__END__

Trapping a Perl error.

	perl -l - 5 0
	  eval {$res = $ARGV[0] / $ARGV[1]};
	  if ($@) {die "Division error: $@"}
	  else {print "Quotient is: $res"}
	__END__

Accessing the system error message:

	perl -le 'while (++$i) {$pid = fork; last unless $pid}; \
		unless (defined $pid) {print "System error message: $!"}'

Piping to a system command.
Starting a pipe with open returns the PID of the started child process. If the pipe fails, the parent will be informed with a SIGPIPE signal, at least when the pipe is to read from the current process. Closing the pipe with close returns a value containing the status of the child process.
For Unix Systems, unknown should execute the die function from the signal handler and make -f - should execute the die function subsequent to the close function, while wc should execute without calling die.
```
	perl
	$Tool = "unknown"; # or "wc" or "make -f -"
	local $SIG{PIPE} = sub {die "Pipe broke:"};
	open (TOPIPE, "| $Tool") or die "Can't fork: $!";
	sleep 2; # give the child process a chance to react
	print TOPIPE "Hello from Perl\n";
	close TOPIPE or die "Pipe returned: ", ($? >> 8);
	$SIG{PIPE} = 'DEFAULT';      # Switch to default signal handling
	__END__
```
Separating output, error output, and exit status from a system command.
If the input can be submitted in one step, it might be preferable to use redirection instead of piping. Thus, if the input is stored in file stdin , use
```
	system("$Tool $args < stdin 1> stdout 2> stderr");
```
instead of open in the previous example. No sleep is required, because system waits for the child process to finish.
Check the standard output in file stdout, the standard error output in file stderr. The exit value is $? >> 8, core is dumped if $? & 128 is true, and a signal occured if $? & 127 is true.

Piping from a system command.
For a reading pipe, no SIGPIPE signal will occur.
For Unix Systems, unknown and make should execute the die function subsequent to the close function, while ls should execute without calling die.

	perl
	$Tool = "unknown"; # or "ls" or "make"
	open (FROMPIPE, "$Tool |") or die "Can't fork: $!";
	while (<FROMPIPE>) {
		print "Child says: $_";
	}
	close FROMPIPE or die "Pipe returned: ", ($? >> 8);
	__END__

Starting an xterm when a specified time hour:minute has come (similar to the UNIX command at ):

	perl - 13:40
	($hour, $minute) = split (/:/, $ARGV[0]);
	print "Starting xterm at $hour:$minute\n";
	while (sleep 60) {
	  @t=localtime();
	  last if ($t[2] >= $hour and $t[1] >= $minute);
	}
	`xterm -bg red -title alarm` or die;
	__END__

23. Miscellaneous

Evaluate an expression inside a string:

	perl -e '$x=4; $y=5; print "$x * $y = ${\( $x * $y )}\n"'

Evaluate a function call inside a string:

	perl -e '@l = ("one", "two"); print "l = @{[join '::', @l]}\n"'

Handle trap and check for specific Perl version:

	perl -le 'eval {require 5.004}; warn $@ if $@; print "go on"'

Redeclaration of a built-in function:

	perl -l
	use subs 'print';
	sub print {CORE::print "You said: @_"; };
	&print("Hello\n")
	__END__

A skeleton for a Perl script file. Make sure to have the second appearance of END-OF-MANPAGE to be totally alone on one line. When using the vi-editor a command like

 :se noai nosm tw=100 sw=4

before mouse pasting and

 :1,$<

thereafter might help.
Save the contents to a file myfile.pl (or replace myfile.pl in the text). Then use

	chmod +x myfile.pl 
	./myfile.pl
	./myfile.pl -h

And here is the text:

#!/usr/local/perl5/bin/perl -ws
            
use strict;		# for variables, subroutines and symbolic references

use vars qw($v $h);	# declare all global variables here


my $USAGE = "$0 [-h] | [-v] file ...";
my ($ProgBaseName) = ($0 =~ m/.*\/([^.]*)/);

# Begin of embedded documentation

=head1 NAME

F<myfile.pl> - example of a Perl script file

=head1 SYNOPSIS

C<myfile.pl [-h] | [-v] file ...>

=head1 VERSION

If this file is checked into an RCS or CVS repository, the
following Id will be set to the correct file name.
$Id: Limericks.html,v 1.75 2002/05/07 11:37:22 sb Exp $

=head1 DESCRIPTION

This script is an example of a more B<production oriented> Perl script.
I<Embedded documentation> may be cluttered inside the code.

Have in mind to insert a newline before each embedded documentation
command (i. e. lines starting with C<=> in the first column).

=head2 PROCESSING

=over 4

=item 0 Read all filenames from the commandline

=item 1 Process each file

=item 2 Exit with Return Code

=back

=cut
# End of embedded documentation

if ($h) {manpage()};

sub manpage {
print <<"END-OF-MANPAGE";

NAME 
     $0

SYNOPSIS 
     $USAGE

DESCRIPTION 
     $0 is an example for a perl skeleton file.
     To output a manpage, a here document is best fit.
     When started with -h, this page is output.
     This demands option -s to be stated on the first line of this
     script file.

     For a more detailed description, check the embedded documentation
     which is generated and viewed ...

     ... directly with
	perldoc $0 

     ... for HTML with
	pod2html $0 > $ProgBaseName.html
	# and view it from Netscape

     ... for LaTeX
	pod2latex -full $0
	latex $0.tex
	xdvi $0.dvi
	dvips -o $0.ps $0.dvi
	gv $0.ps

     ... for the man page
	pod2man $0|nroff -man|more
     or
	mkdir man1
	pod2man $0 > man1/$ProgBaseName.1	
	man -M . $ProgBaseName

     ... for the usage
	pod2usage $0

     ... for plain ASCII text
	pod2text $0 > $ProgBaseName.txt
	cat $ProgBaseName.txt

     ... additionally
	there are tools pod2pdf, pod2docbook, pod2rtf, and pod2quark
	and a pre-compiler pnd2pod available on the Internet

OPTIONS
     -h Display this help page and exit.
     -v verbose. Output comments when accessing files or directories.

END-OF-MANPAGE
;
exit 0;
} # End of sub manpage


if ($v) {
	print "Normal processing of @ARGV starts here\n";
} else {
	print STDERR "Usage: $USAGE\n";
	exit 1;
}

# Begin of embedded documentation

=head2 RETURN VALUE

	0 if all files are processed correctly 
	1 if an error occurs

=head1 AUTHOR

Siegfried Bublitz, E<lt>sb@c-lab.deE<gt>.
(This is not ok for LaTeX).

=head1 More POD directives

  =for FMT
  	Next paragraph only for formatter FMT

  =begin FMT
  =end FMT
  	Text between only for formatter FMT

  L<cross reference>
  S<text not broken on spaces>
  X<index entry>
  Z<> zero width character
=cut
# End of embedded documentation

exit 0;

A simple interactive shell:

	perl
	sub f {print "Hello with args @_\n"};

	print "(Usage: f args)> ";
	while (<>) {
	    chomp($answer = $_);
	    eval $answer;
	    print "(Usage: f args)> ";
	} 
	__END__

24. Links

Camel & Llama images are trademarks of O'Reilly & Associates, Inc. Used with permission.