perl -de 0

srand;
$item = $array[rand @array];

This prints foo 42 bar:

perl -e 'print "foo @{[ 7 * 6 ]} bar
"'

$^O contains the name of your operating system.

$^T contains the time at which your program began.

$0 contains the name of your program.

Run the widget program bundled with Perl/Tk for an excellent run-through of all the important widgets, complete with cut-and-pasteable source code.

To apply a Perl expression EXPRto a region:

C-u M-| perl -pe 'EXPR'

To apply EXPRto the entire buffer:

C-x h C-u M-| perl -pe 'EXPR'

(Courtesy Mark Jason Dominus.)

{!}perl -pe 's/[eE](?=macs)/silly/g'

Efficiently finding the position of the first and last occurrences of a substring in a string:

$first =  index($string, $substring);
$last  = rindex($string, $substring);

This is faster than using regular expressions.

warn "has nondigits"        if     /D/;
warn "not a natural number" unless /^d+$/;             # rejects -3
warn "not an integer"       unless /^-?d+$/;           # rejects +3
warn "not an integer"       unless /^[+-]?d+$/;
warn "not a decimal number" unless /^-?d+.?d*$/;     # rejects .2
warn "not a decimal number" unless /^-?(?:d+(?:.d*)?|.d+)$/;
warn "not a C float"
       unless /^([+-]?)(?=d|.d)d*(.d*)?([Ee]([+-]?d+))?$/;

(Courtesy The Perl Cookbook.)

perl -e 'print eval join("+", @ARGV)' 6 10 20 11 9 16 17 16 15 10 17 18 7

This prints all elements of the @INC array, which is where Perl searches for modules and library files.

perl -e "print qq($_
) for @INC"

sub unique (&@) {
    my ($c,%hash) = shift;
    grep { not $hash{&$c}++ } @_
}

Sample usages:

@list = unique { $_       } @list;  # Remove duplicate strings from @list.

@obj  = unique { $_->name } @obj;   # Only include one object for each name.

(Courtesy Don Schwarz.)

Any of these snippets will work:

perl -pale '@F{@F}=()} for(sort keys%F){'

perl -la0ne 'print for sort keys%{{map{$_,1}@F}}'

perl -la0ne '@a{@F}++;print for sort keys%a'

perl -la0pe '}for (sort keys%{{map{$_,1}@F}}){'

(Courtesy Peter J. Kernan.)

perl -e 'while (<>) {}; print $.' /usr/dict/words

@a = (0,0);
while (<>) { ++$a[not m/^=w+/s .. m/^=cut/s] }
printf "%d pod lines, %d code lines
", @a;

(Courtesy Sean M. Burke.)

while (<>) {
    $in_header = 1 .. /^$/;
    $in_body   = /^$/ .. eof();
}

(Courtesy The Perl Cookbook.)

sleep can only sleep for an integral number of seconds. If you wanted to sleep for 0.25 seconds, here’s how:

select(undef, undef, undef, 0.25);

To see which modules have been installed on your system, type this:

perldoc perllocal

This script reports on available modules more cleanly:

#!/usr/bin/perl -w
use strict;                            # all variables must be declared
use Getopt::Std;                       # import the getopts method
use ExtUtils::Installed;               # import the package

use vars qw($opt_l $opt_s);            # declaring the two option switches
&getopts('ls'),                        # $opt_l and $opt_s are set to 1 or 0
unless($opt_l or $opt_s) {             # unless one switch is true (1)
  die "pmods: A utility to list all installed (nonstandard) modules
",
      "  Usage: pmods.pl -l  # list each module and all its directories
",
      "         pmods.pl -s  # list just the module names
";
}

my $inst  = ExtUtils::Installed->new();
foreach my $mod ( $inst->modules() ) { # foreach of the installed modules
  my $ver = $inst->version($mod);      # version number of the module
     $ver = ($ver) ? $ver : 'NONE';    # for clean operation
  print "MODULE: $mod version $ver
"; # print module names
  map { print "  $_
" } $inst->directories($mod) if($opt_l);
}

(Courtesy William H. Asquith et al.)

To replace substring $x with an equal length substring $y, but preserving the case of $x:

$string =~ s/($x)/"L$y"^"L$1"^$1/ie;

(Courtesy Dean Inada.)

To find the longest common prefix of two strings $x and $y:

($x ^ $y) =~ /^(*)/;
print substr($x, 0, length($1));

If $x were foobar and $y were football, the above snippet would print foo—handy for allowing users to abbreviate commands with the minimum number of letters.

The longest common suffix:

((reverse $x) ^ (reverse $y)) =~ /^(*)/;
print substr($x, -length($1));

If $x were camel and $y were caramel, the above snippet would print amel.

(Courtesy Jarkko Hietaniemi.)

!$a || !$b || !$c ...

is equivalent to:

!($a && $b && $c ...)

To euuencode a file:

perl -0777e 'printf "begin 444 $ARGV[0]
%s`
end
",pack "u*",<>' filename

To uudecode a uuencoded file:

perl -ne 'print unpack "u*",$_' file.uu

(Courtesy Gurusamy Sarathy.)

Use m//g when you know what you want to keep, and split when you know what you want to throw away.

(Courtesy Randal Schwartz.)

@matrix_t = map { my $x = $_;
                  [map { $matrix[$_][$x]} 0..$#matrix] } 0..$#{$matrix[0] };

(Courtesy Tuomas J. Lukka.)

Ever wish backquotes didn’t interpolate variables? qx() is a synonym for backquotes, but if you use single quotes as a delimiter, it won’t interpolate:

qx'echo $HOME'

passes the string echo $HOME to your shell without interpreting $HOME as a Perl scalar.

(Courtesy Tom Christiansen.)

$s &= "177" x length($s);

Given a string in $s, this one-liner turns all of the “funny” characters (like Ã) into regular seven-bit ASCII characters. It works by ANDing the bit representation of each character with 127, which removes the eighth bit. That turns à into L, for instance.

(Courtesy Tom Christiansen.)

perl -0011 -pi -e '/11/&&($_="$` ")'

(Courtesy Abigail.)

perl -e 'sleep(120); while (1) { print "a" }'

This sleeps for 120 seconds and then beeps.

Replace 17 with whatever number you want to test. If the number is prime, this snippet will print PRIME, and nothing otherwise:

perl -le 'print "PRIME" if (1 x shift) !~ /^(11+)1+$/' 17

(Courtesy Abigail.)

sub f{for(2..sqrt($_[0])){return($_,f($_[0]/$_))if!($_[0]%$_)}return$_[0]}
print join",",f(720); print "
";

(Courtesy Tuomas J. Lukka.)

qr-strings are actually objects:

$rob = qr/red/i;

if ($rob->match("Fred Flintstone")) {
    print "Got obj fred!
";
} else {
    print "No obj fred.
";
}

sub Regexp::match {
    my $self = shift;
    my $arg  = @_ ? shift : $_;
    return $arg =~ /$arg/;
}

This prints Got obj fred!.

qr has a magic print value. For instance, if you print a regex like so:

perl -le 'print qr/^watch/i'

you’ll see this, showing that the i modifier is active and the x, s, and m modifiers are inactive, and that the regex is non-capturing:

(?i-xsm:^watch)

(Courtesy Tom Christiansen.)

This snippet lops off the latter half of an array:

$#array /= 2 if @array;

(Courtesy The Perl Cookbook.)

This snippet prints a message if a daylight savings time change occurs within the next 5 days:

print "aTIME CHANGE COMING!
"
  if (localtime(time))[8] ne (localtime(time+5*24*60*60))[8];

(Courtesy J.D. Laub.)

To track the progress of a file as it downloads:

perl -e 'BEGIN{$|=1;$f=$ARGV[0];$s=(stat$f)[7];$t=time}
         while(sleep 1){printf"
$f %s bytes at %.2f Kb/s   ",
         $_=(stat$f)[7],($_-$s)/1024/(time-$t)}' your_downloading_file

(Courtesy Philippe Bruhat.)

You can put this snippet anywhere in your program; when it finishes, the END block will be triggered and the total running time of your program will be printed:

END {
  no integer;
  printf(STDERR "Running time: %5.2f minutes
",((time - $^T) / 60));
}

The Data::Dumper module, bundled with Perl, can save data structures to disk as strings that can be read in by another program.

# indent your here doc
($definition = <<'FINIS') =~ s/^s+//gm;
    The five varieties of camelids
    are the familiar camel, his friends
    the llama and the alpaca, and the
    rather less well-known guanaco
    and vicuña.
FINIS

(Courtesy The Perl Cookbook.)

perl -ne 'push@w,/([A-Z]S*?)/g;END{print"@w"}' file

Replace xterm with whatever command you use to launch a terminal window:

perl -e '$fg = rand 2**24;
         do { $bg = rand 2**24 } while (unpack("%32b*", $bg^$fg) < 10);
         ($fg, $bg) = map { sprintf "#%06x", $_ } $fg, $bg;
         exec("xterm", "-fg", $fg, "-bg", $bg);'

(Courtesy Tkil.)

If you’re trying to get Windows to generate a PostScript file, but it wraps the file with PCL junk, you can remove it with this:

perl -ni -e "!$g&&s/^.*(%!.*)/$1/ && $g or print; last if /^%%EOF/"

This snippet of PDL code graphs the figure shown in Figure 48-1:

use PDL;
use PDL::Graphics::TriD;
$s = 40;
$a = zeroes 2*$s, $s/2;
$t = $a->xlinvals(0,6.284);
$u = $a->ylinvals(0,6.284);
$o = 5;
$i = 1;
$v = $o - $o/2*sin(3*$t) + $i*sin$u;
imag3d([$v*sin$t, $v*cos$t, $i*cos($u) + $o*sin(3*$t)]);

(Courtesy Tuomas J. Lukka.)

This subroutine returns true if and only if all parentheses, brackets, and braces in the given string are balanced:

sub is_balanced {
    my $it = $_[0];
    $it =~ tr/()[ ]{}//cd;
    1 while $it =~ s/()|[]|{}//g;
    return !length($it);
}

Figure 48-1. A Bent Torus, graphed with PDL

(Courtesy Sean M. Burke.)

use strict
            ;sub                  pars
          {my(                     $l,$r
        )=map{                       "Q$_"
      }split//                        ,shift;
    my(@s,@r                            ,$i,$o,
   $v);for(                             split/([
  $l$r])/,                                shift){
  /$l/and                                $s[++$o]=
 ++$i;for                                $v(1..$o)#
 {$r[$v].=                              $_ if$s[$v]
  >0}/$r/and                            $s[(grep##
   $s[$_]==                            $i,0..$#s)
    [0]]=-$i         ,--$i<0&&        last;}($i=
      shift)?        wantarray       ?@r[grep
        -$s[$_       ]==$i,0..       $#s]:$r
          [$i]:      splice@r,      1;}$,
            ="
"     ;print       pars
               (@      ARGV       )#

Basic usage of the pars subroutine that this onomatolexical program provides:

pars('()', "(123 (456) (789) 0)")

prints the three parenthetical expressions:

(123 (456) (789) 0),(456),(789)

You can request a particular depth. In list context, this expression:

pars('()', "(123 (456) (789) 0)", 2)

prints the level-2 expressions:

(456),(789)

In scalar context, the 2 is interpreted to mean the second parenthetical expression:

(456)

(Courtesy Paul Kulchenko.)

Each cell of the table corresponds to a pixel of the image:

use GD;
$f = '#ffffff';
$T = table;
sub p {print @_}
p "<body bgcolor=$f>";
for (@ARGV) {
    open *G,$_ or (warn("$_: $!") && next);
    $g = GD::Image->newFromGif(G) || (warn $_ , ": GD error" and next);
    @c = map { $_ != $g->transparent ?
               sprintf '#' . ('%.2x'x3), $g->rgb($_) :
               $f
            } 0..$g->colorsTotal;
   p "<$T border=0 cellpadding=0 cellspacing=0>";
   ($x, $y) = $g->getBounds;
   for $j (0..$y) {
       p "<tr>";
       for ($i=0; $i<$x; $i++) {
           $s=1;
           $s++ && $i++ while ($i+1 < $x &&
                               $g->getPixel($i+1,$j) == $g->getPixel($i,$j));
           p "<td bgcolor=", $c[$g->getPixel($i,$j)],
             " colspan=$s>&nbsp"
       }
   }
   p "</$T>"
}

(Courtesy Mike Fletcher.)

cvs status | perl -nle 'next unless /Status:/o; print unless /Up-to-date/'

(Courtesy Geoff Simmons.)

perl -e 'for (0..127) { $!=$_; warn $!}'

This is out of date now, but still of historical interest:

#!/usr/bin/perl -0777pi
s/(BITS:.*?)/$_=$&;y,a-z, ,;s,    $,true,gm;s, 512,2048,;$_/es;

(Courtesy Ian Goldberg and Chris Nandor.)

You can create a reference to a scalar like so:

$ref = $var;

An obscure way to do the same thing:

$ref = *var{SCALAR};

The same holds for other data types.

“Regular expressions are to strings with math is to numbers.”

(From an Andrew Clinick column, discussing what Microsoft thinks of Perl. Short answer: they like it, because it can be used “anywhere” via Microsoft’s ActiveX scripting mechanism.)

Asteroid 2000 BF19 was thought to be on a potentially dangerous approach path for us Terrans, with a possible impact in 2022. However, a Perl program called clomon.pl showed that the asteroid cannot come any closer than 0.038 AU for the next fifty years. Sleep tight!

(Courtesy Andrea Milani and Scott Manley.)

($x,$y)=(41,31); $x&1&&$y&1&&$x>1&&$y>1||die; @M=(1)x($x*$y);
sub K { $M[my$p=$_[0]]=0; while($d =
  ($p>$x*2)*$M[$p-2*$x] | ($p<$x*($y-2))*$M[$p+2*$x]*2
  | ($p%$x!=$x-2)*$M[$p+2]*4 | ($p%$x!=1)*$M[$p-2]*8)     {
  $d&1<<($i=3&int rand $d)||redo;
  $M[$p+($j=$i==0?-$x:$i==1?$x:$i==2?1:-1)]=0; K($p+2*$j) } }
K($x+1); $M[1]=$M[-2]=0;
while(@M){$_=join'',splice@M,0,$x;tr<01>< #>;print$_,"
"}

The above snippet generates mazes that look like this:

# #######################################
# #     #     #         #           #   #
# # ### ### # # # ##### # ####### # ### #
# # #     # #   #   # # # #     # #     #
# # ##### # ####### # # # # ### # ##### #
# #   #   #   # #   #   # # # # # #   # #
# ### ### ### # # ####### # # # # # # # #
#   #   # #     # #     # # # #   # # # #
### # # # ####### # ### # # # ##### # # #
# # # # #   #   #     #   # #   #   #   #
# # # # ### # # ########### # # # #######
#   # #   #   #           # # # #   #   #
# ### ### ### ########### # # ##### # ###
# # #   #   # #   #     #   # #     #   #
# # # ##### ### # # ### ##### # ##### # #
# #   #   # #   # # # #   #   # #   # # #
# # ### # # # ### # # # # # ### # ### # #
# # #   #   #   # # # # #   #   # #   # #
# # # ######### # # # # ##### ### # ### #
# # #           # # # #       #     #   #
# # ############# # # ############# # ###
# #       #     # # #     #       # #   #
# # ##### # ### # # # ### ##### # ##### #
# # #   # #   #   #   # #       #       #
# # # # # ### ######### ############### #
# # # # #   #         #         #       #
# ### # ############# # # ####### #######
# #   #   #           # #   #     #     #
# # ##### # ########### ### # ##### ### #
#   #       #             #         #   #
####################################### #

(Courtesy Sean M. Burke.)

Neal Stephenson’s novel Cryptonomicon includes a Perl cryptosystem code-named Pontifex. You can read about it at http://www.well.com/user/neal/cypherFAQ.html#12 and http://www.counterpane.com/solitaire.html. The source code is at http://www.counterpane.com/sol.pl.

Harry used parts of the Perl FAQ to translate a message. In the first shot, this not-quite-syntactically-correct snippet could be seen:

$BSD = -f '/vmunix'; if ($BSD) { system "BIN
cbreak </dev/tty >/dev/tty 2>&1

In the second shot:

set_cbreak(0)
    local($on) = $_[0];
    local($sgttyb,@ary);
    require 'sys/ioctl.ph';

(Courtesy Brendan O’Dea.)

#!/usr/bin/perl

($decimal, $binary) = (shift, ''),
$SIG{USR1} = sub { $binary .= "0" };
$SIG{USR2} = sub { $binary .= "1" };

do { kill $decimal & 1 ? 'USR2' : 'USR1', $$;
     $decimal >>= 1;
} while ($decimal);

print scalar reverse $binary;

(Courtesy Nathan Torkington.)

Swatch’s Internet Time, heralded as a “revolutionary” way of measuring time independent of geography:

perl -e 'print "Internet Time @", int(((time + 3600) % 86400)/86.4)'

This snippet of PDL code implements Conway’s game of Life (pictured in Figure 48-2).

use PDL;
use PDL::Image2D;
use PDL::Graphics::TriD;nokeeptwiddling3d;
$d = byte( random(zeroes(40,40)) > 0.85 );
$k = byte [[1,1,1],[1,0,1],[1,1,1]];
do { imagrgb [$d];
     $s = conv2d($d,$k);
     $d &= ($s<4);
     $d &= ($s>1);
     $d |= ($s==3);
  }  while (!twiddle3d);

(Courtesy Robin Williams and Tuomas J. Lukka.)

Figure 48-2. A PDL version of Conway’s game of Life

This snippet goes through each character of standard input and uppercases it half the time:

perl -ne 'foreach(split//){rand()<0.5?print:print uc;}'

(Courtesy Kyle Burton.)

On certain older Pentium-based systems, this code will crash the computer:

require DynaLoader;
DynaLoader::dl_install_xsub("main::hangme",
                            unpack("I", pack("P4", "xF0x0FxC7xC8")));
hangme();

We provide it here for diagnostic purposes only.

(Courtesy Gisle Aas.)

This prints 7 Magic Cards.

for $a(0..6){$b=1;for $c(1..100){if($c&2**$a){printf
"%3d ",$c;print"
"if!($b++%10)}}print"


"}

Have a friend think of a number from 1 to 100. Show them the cards one at a time and ask if their number is on the card. Mentally sum the first digit of each card for which the answer is yes. The final sum will be their number. (This trick is known to win bar bets.)

(Courtesy Bill Huston.)

sub merge {
    my $enses;

    do {
        not $ave;
        my $inking, @body;
        push @me, @down;
    };

    foreach $econd (%brings) {
        my $oluble, @existence;
        closer_to_your;
        drowning_beauty;
    }
}

(Courtesy Harl.)

%secretly = (
    confidence => 0xFADED,
    under => 0xFED,
    lost => 0xDEAD,
);

sub conscious {
    setpriority $cushion, $the, $fall or
    return $to_safer_ground;
}

print "I am ",conscious(143);
$i_am = $secretly{lost};

#!/usr/bin/perl
#
# Will give errors if run with -w, so don't use -w :)
# Tested on NT with AS (5.005), GS (5.004_02), and Solaris 2.6 (5.004_04)

if ("a packet hits a pocket") {
  On: a;
    socket(ON, A ,PORT,"")

        && the bus is interrupted as a very-last-resort

            && the address of the memory makes your floppy disk, abort;

} else {

    "The socket packet pocket has an";
  error: to-report;
}

if ("your cursor finds a menu item") {
    "followed by a dash"
        && "the double clicking icon";
  puts: your-items-in-the-trash
      && your data is corrupted cause the index("doesn't", "hash");

} else {
    "Your situation is hopeless"
        && Your system's gonna crash;
}

if ("the label on the cable") {
    On-the-table, at-your-house;
    Says_the;
    sub network {"is connected to the button on your mouse"};
 BUT: Your-packets, want-to; {/tunnel to another protocol/};
 that's: repeatedly-rejected;
{/by the printer/}; "down the hall"
    && "YOUR SCREEN is all distorted";
{/by the side effects of Gauss/};
 so: "your icons", in-the-window;
"are as wavy as a souse";

} else {

  YOU: "may as well reboot" && "go out with a !";
 CAUSE: /Sure as Im a poet/;
 THIS: suckers-gonna-hang;
}

print "Seuss as a tech writer - Kevin Meltzer
";

(Courtesy Kevin Meltzer.)

One function to bless them all,

One list to derive them,

One arrow to call them through,

Preorder search to bind them.

(Courtesy Damian Conway.)

Perl was born December 18, 1987.

Zodiac sign: Sagittarius.

Chinese zodiac: Rabbit, signifying docility, gentleness, nonconformity, and longevity.

On December 18 in history, Keith Richards, Steven Spielberg, Brad Pitt, Paul Klee, Mohammed Ali, and Ty Cobb were born. The golf tee was patented, slavery was abolished in the United States, New Jersey became a state, and the UN unanimously condemned hostage-taking.