$value = substr($string, $offset, $count);

$value = substr($string, $offset);



substr($string, $offset, $count) = $newstring;

substr($string, $offset, $count, $newstring);  # same as previous

substr($string, $offset)         = $newtail;

# get a 5-byte string, skip 3 bytes,

# then grab two 8-byte strings, then the rest;

# (NB: only works on ASCII data, not Unicode)

($leading, $s1, $s2, $trailing) =

    unpack("A5 x3 A8 A8 A*", $data);



# split at 5-byte boundaries

@fivers = unpack("A5" x (length($string)/5), $string);



# chop string into individual single-byte characters

@chars  = unpack("A1" x length($string), $string);

$string = "This is what you have";

#         +012345678901234567890  Indexing forwards  (left to right)

#          109876543210987654321- Indexing backwards (right to left)

#           note that 0 means 10 or 20, etc. above



$first  = substr($string, 0, 1);  # "T"

$start  = substr($string, 5, 2);  # "is"

$rest   = substr($string, 13);    # "you have"

$last   = substr($string, -1);    # "e"

$end    = substr($string, -4);    # "have"

$piece  = substr($string, -8, 3); # "you"

# use $b if $b is true, else $c

$a = $b || $c;



# set $x to $y unless $x is already true

$x ||= $y;

# use $b if $b is defined, else $c

$a = defined($b) ? $b : $c;



# the "new" defined-or operator from future perl

use v5.9;

$a = $b // $c;

($VAR1, $VAR2) = ($VAR2, $VAR1);

$temp    = $a;

$a       = $b;

$b       = $temp;

$a       = "alpha";

$b       = "omega";

($a, $b) = ($b, $a);        # the first shall be last -- and versa vice

($alpha, $beta, $production) = qw(January March August);

# move beta       to alpha,

# move production to beta,

# move alpha      to production

($alpha, $beta, $production) = ($beta, $production, $alpha);

$num  = ord($char);

$char = chr($num);

$char = sprintf("%c", $num);                # slower than chr($num)

printf("Number %d is character %c\n", $num, $num);

Number 101 is character e

            

@bytes = unpack("C*", $string);

$string = pack("C*", @bytes);



$unistr = pack("U4",0x24b6,0x24b7,0x24b8,0x24b9);

@unichars = unpack("U*", $unistr);

$value     = ord("e");    # now 101

$character = chr(101);    # now "e"

printf("Number %d is character %c\n", 101, 101);

use charnames ':full';

print "\N{GREEK CAPITAL LETTER DELTA} is called delta.\n";



Δ is called delta



use charnames ':short';

print "\N{greek:Delta} is an upper-case delta.\n";



Δ is an upper-case delta



use charnames qw(cyrillic greek);

print "\N{Sigma} and \N{sigma} are Greek sigmas.\n";

print "\N{Be} and \N{be} are Cyrillic bes.\n";



Σ

               and

               σ

               are Greek sigmas

               Б 

               and 

               б 

               are Cyrillic bes

            

use charnames qw(:full);

for $code (0xC4, 0x394) { 

    printf "Character U+%04X (%s) is named %s\n",

        $code, chr($code), charnames::viacode($code);

}



Character U+00C4 (Ä) is named LATIN CAPITAL LETTER A WITH DIAERESIS

@array = split(//, $string);      # each element a single character

@array = unpack("U*", $string);   # each element a code point (number)

while (/(.)/g) {         # . is never a newline here

        # $1 has character, ord($1) its number

    }

%seen = ( );

$string = "an apple a day";

foreach $char (split //, $string) {

    $seen{$char}++;

}

print "unique chars are: ", sort(keys %seen), "\n";

unique chars are:  adelnpy

            

%seen = ( );

$string = "an apple a day";

while ($string =~ /(.)/g) {

    $seen{$1}++;

}

print "unique chars are: ", sort(keys %seen), "\n";

$revchars = reverse($string);

$revwords = join(" ", reverse split(" ", $string));

$gnirts   = reverse($string);       # reverse letters in $string



@sdrow    = reverse(@words);        # reverse elements in @words



$confused = reverse(@words);        # reverse letters in join("", @words)

# reverse word order

$string = 'Yoda said, "can you see this?"';

@allwords    = split(" ", $string);

$revwords    = join(" ", reverse @allwords);

print $revwords, "\n";

this?" see you "can said, Yoda

            

$revwords = join(" ", reverse split(" ", $string));

$revwords = join("", reverse split(/(\s+)/, $string));

$string = "fac\x{0327}ade";         # "façade"

$string =~ /fa.ade/;                # fails

$string =~ /fa\Xade/;               # succeeds



@chars = split(//, $string);        # 7 letters in @chars

@chars = $string =~ /(.)/g;         # same thing

@chars = $string =~ /(\X)/g;        # 6 "letters" in @chars

use Unicode::Normalize;

$s1 = "fa\x{E7}ade";                

$s2 = "fac\x{0327}ade";                

if (NFD($s1) eq NFD($s2)) { print "Yup!\n" }

$string = v231.780;

#   LATIN SMALL LETTER C WITH CEDILLA

#   COMBINING CARON



$string = v99.807.780;

#         LATIN SMALL LETTER C

#         COMBINING CARON

#         COMBINING CEDILLA



$string = v99.780.807

#         LATIN SMALL LETTER C

#         COMBINING CEDILLA

#         COMBINING CARON

$ff = "\x{FB00}";             # ff ligature

$chars = length($ff);         # length is one character

{

  use bytes;                  # force byte semantics

  $octets = length($ff);      # length is two octets

}

$chars = length($ff);         # back to character semantics

use Encode qw(encode_utf8);



sub somefunc;                 # defined elsewhere



$ff = "\x{FB00}";             # ff ligature

$ff_oct = encode_utf8($ff);   # convert to octets



$chars = somefunc($ff);       # work with character string

$octets = somefunc($ff_oct);  # work with octet string

while ($string =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e) {

    # spin in empty loop until substitution finally fails

}

use Text::Tabs;

@expanded_lines  = expand(@lines_with_tabs);

@tabulated_lines = unexpand(@lines_without_tabs);

while (<>) {

    1 while s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;

    print;

}

1 while s/^(.*?)(\t+)/$1 . ' ' x (length($2) * 4 - length($1) % 4)/e;

1 while s/\t+/' ' x (($+[0] - $-[0]) * 4 - $-[0] % 4)/e;

You owe $debt to me.

$text =~ s/\$(\w+)/${$1}/g;

$text =~ s/(\$\w+)/$1/gee;

our ($rows, $cols);

no strict 'refs';                   # for ${$1}/g below

my $text;



($rows, $cols) = (24, 80);

$text = q(I am $rows high and $cols long);  # like single quotes!

$text =~ s/\$(\w+)/${$1}/g;

print $text;

I am 24 high and 80 long

            

$text = "I am 17 years old";

$text =~ s/(\d+)/2 * $1/eg;

2 * 17

$text = 'I am $AGE years old';      # note single quotes

$text =~ s/(\$\w+)/$1/eg;           # WRONG

$big = uc($little);             # "bo peep" -> "BO PEEP"

$little = lc($big);             # "JOHN"    -> "john"

$big = "\U$little";             # "bo peep" -> "BO PEEP"

$little = "\L$big";             # "JOHN"    -> "john"

$big = "\u$little";             # "bo"      -> "Bo"

$little = "\l$big";             # "BoPeep"  -> "boPeep"

$beast   = "dromedary";

# capitalize various parts of $beast

$capit   = ucfirst($beast);         # Dromedary

$capit   = "\u\L$beast";            # (same)

$capall  = uc($beast);              # DROMEDARY

$capall  = "\U$beast";              # (same)

$caprest = lcfirst(uc($beast));     # dROMEDARY

$caprest = "\l\U$beast";            # (same)

# titlecase each word's first character, lowercase the rest

$text = "thIS is a loNG liNE";

$text =~ s/(\w+)/\u\L$1/g;

print $text;

This Is A Long Line

            

INIT {

    our %nocap;

    for (qw(

            a an the

            and but or

            as at but by for from in into of off on onto per to with

        ))

    {

        $nocap{$_}++;

    }

}



sub tc {

    local $_ = shift;



    # put into lowercase if on stop list, else titlecase

    s/(\pL[\pL']*)/$nocap{$1} ? lc($1) : ucfirst(lc($1))/ge;



    s/^(\pL[\pL']*) /\u\L$1/x;  # first  word guaranteed to cap

    s/ (\pL[\pL']*)$/\u\L$1/x;  # last word guaranteed to cap



    # treat parenthesized portion as a complete title

    s/\( (\pL[\pL']*) /(\u\L$1/x;

    s/(\pL[\pL']*) \) /\u\L$1)/x;



    # capitalize first word following colon or semi-colon

    s/ ( [:;] \s+ ) (\pL[\pL']* ) /$1\u\L$2/x;



    return $_;

}

s/(\w+\S*\w*)/\u\L$1/g;

# with apologies (or kudos) to Stephen Brust, PJF,

# and to JRRT, as always.

@data = (

            "the enchantress of \x{01F3}ur mountain",

    "meeting the enchantress of \x{01F3}ur mountain",

    "the lord of the rings: the fellowship of the ring",

);



$mask = "%-20s: %s\n";



sub tc_lame {

    local $_ = shift;

    s/(\w+\S*\w*)/\u\L$1/g;

    return $_;

}



for $datum (@data) { 

    printf $mask, "ALL CAPITALS",       uc($datum);

    printf $mask, "no capitals",        lc($datum);

    printf $mask, "simple titlecase",   tc_lame($datum);

    printf $mask, "better titlecase",   tc($datum);

    print "\n";

}

$answer = $var1 . func( ) . $var2;   # scalar only

$answer = "STRING @{[ LIST EXPR ]} MORE STRING";

$answer = "STRING ${\( SCALAR EXPR )} MORE STRING";

$phrase = "I have " . ($n + 1) . " guanacos.";

$phrase = "I have ${\($n + 1)} guanacos.";

print "I have ",  $n + 1, " guanacos.\n";

$phrase = "I have ${\( count_em( ) )} guanacos.";

# all in one

($var = << HERE_TARGET) =~ s/^\s+//gm;

    your text

    goes here

HERE_TARGET



# or with two steps

$var = << HERE_TARGET;

    your text

    goes here

HERE_TARGET

$var =~ s/^\s+//gm;

($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

use Text::Wrap;

@output = wrap($leadtab, $nexttab, @para);

use Text::Autoformat;

$formatted = autoformat $rawtext;

  #!/usr/bin/perl -w

  # wrapdemo - show how Text::Wrap works

  @input = ("Folding and splicing is the work of an editor,",

            "not a mere collection of silicon",

            "and",

            "mobile electrons!");

  use Text::Wrap qw($columns &wrap);

  $columns = 20;

  print "0123456789" x 2, "\n";

  print wrap("    ", "  ", @input), "\n";

               01234567890123456789

               Folding and

               splicing is the

               work of an

               editor, not a

               mere collection

               of silicon and

# backslash

$var =~ s/([CHARLIST])/\\$1/g;



# double

$var =~ s/([CHARLIST])/$1$1/g;

$string =~ s/%/%%/g;

$string = q(Mom said, "Don't do that.");

$string =~ s/(['"])/\\$1/g;

$string = q(Mom said, "Don't do that.");

$string =~ s/(['"])/$1$1/g;

$string =~ s/^\s+//;

$string =~ s/\s+$//;

$string = trim($string);

@many   = trim(@many);



sub trim {

    my @out = @_;

    for (@out) {

        s/^\s+//;          # trim left

        s/\s+$//;          # trim right

    }

    return @out =  = 1 

              ? $out[0]   # only one to return

              : @out;     # or many

}

# print what's typed, but surrounded by > < symbols

while (<STDIN>) {

    chomp;

    print ">$_<\n";

}

use Text::ParseWords;

sub parse_csv0 {

    return quotewords("," => 0, $_[0]);

}

sub parse_csv1 {

    my $text = shift;      # record containing comma-separated values

    my @fields  = ( );



    while ($text =~ m{

        # Either some non-quote/non-comma text:

        ( [^"',] + )



         # ...or...

         | 



        # ...a double-quoted field: (with "" allowed inside)



        " # field's opening quote; don't save this

         (   now a field is either

          (?:     [^"]    # non-quotes or

              |

                  ""      # adjacent quote pairs

           ) *  # any number

         )

        " # field's closing quote; unsaved



    }gx)

    {

      if (defined $1) {

          $field = $1;

      } else {

          ($field = $2) =~ s/""/"/g;

      }

      push @fields, $field;

    }

    return @fields;

}

use Text::CSV;

sub parse_csv1 {

    my $line = shift;

    my $csv = Text::CSV->new( );              

    return $csv->parse($line) && $csv->fields( );           

}

tie @data, "Tie::CSV_File", "data.csv";



for ($i = 0; $i < @data; $i++) {

    printf "Row %d (Line %d) is %s\n", $i, $i+1, "@{$data[$i]}";

    for ($j = 0; $j < @{$data[$i]}; $j++) {

        print "Column $j is <$data[$i][$j]>\n";

    } 

}

use constant AVOGADRO => 6.02252e23;



printf "You need %g of those for guac\n", AVOGADRO;

*AVOGADRO = \6.02252e23;

print "You need $AVOGADRO of those for guac\n";

package Tie::Constvar;

use Carp;

sub TIESCALAR {

    my ($class, $initval) = @_;

    my $var = $initval;

    return bless \$var => $class;

}

sub FETCH {

    my $selfref = shift;

    return $$selfref;

}

sub STORE {

    confess "Meddle not with the constants of the universe";

}

sub AVOGADRO( ) { 6.02252e23 }

use subs qw(AVOGADRO);

local *AVOGADRO = sub ( ) { 6.02252e23 };

use Text::Soundex;

$CODE  = soundex($STRING);

@CODES = soundex(@LIST);

use Text::Metaphone;

$phoned_words = Metaphone('Schwern');

use Text::Soundex;

use User::pwent;



print "Lookup user: ";

chomp($user =<STDIN>);

exit unless defined $user;

$name_code = soundex($user);



while ($uent = getpwent( )) {

    ($firstname, $lastname) = $uent->gecos =~ /(\w+)[^,]*\b(\w+)/;



    if ($name_code eq soundex($uent->name) ||

        $name_code eq soundex($lastname)   ||

        $name_code eq soundex($firstname)  )

    {

        printf "%s: %s %s\n", $uent->name, $firstname, $lastname;

    }

}

if ($string =~ /PATTERN/) {

    # is a number

} else {

    # is not

}

if ($string =~ m{^$RE{num}{real}$}) {

    # is a real number

} else {

    # is not

}

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+))?$/;

# round off to two places

$rounded = sprintf("%.2f", $unrounded);

for $n ( 0.0000001, 10.1, 10.00001, 100000.1 ) {

    printf "%12.4e %12.4f %12.4g\n", $n, $n, $n;

}

1.0000e-07       0.0000        1e-07

1.0100e+01      10.1000         10.1

1.0000e+01      10.0000           10

1.0000e+05  100000.1000        1e+05

# equal(NUM1, NUM2, PRECISION) : returns true if NUM1 and NUM2 are

# equal to PRECISION number of decimal places

sub equal {

    my ($A, $B, $dp) = @_;

    return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);

  }

for ($num = $i = 0; $i < 10; $i++) { $num += 0.1 }

if ($num != 1) {

    printf "Strange, $num is not 1; it's %.45f\n", $num;

}

               Strange, 1 is not 1; it's 0.999999999999999888977697537484345957636833191

            

foreach ($X .. $Y) {

    # $_ is set to every integer from X to Y, inclusive

}



foreach $i ($X .. $Y) {

    # $i is set to every integer from X to Y, inclusive

}



for ($i = $X; $i <= $Y; $i++) {

    # $i is set to every integer from X to Y, inclusive

}



for ($i = $X; $i <= $Y; $i += 7) {

    # $i is set to every integer from X to Y, stepsize = 7

}

foreach my $i ($X .. $Y)       { ... }

for (my $i=$X; $i <= $Y; $i++) { ... }

print "Infancy is: ";

foreach (0 .. 2) {

    print "$_ ";

}

print "\n";



print "Toddling is: ";

foreach $i (3 .. 4) {

    print "$i ";

}

print "\n";



print "Childhood is: ";

for ($i = 5; $i <= 12; $i++) {

    print "$i ";

}

print "\n";

use Roman;

$roman = roman($arabic);                        # convert to roman numerals

$arabic = arabic($roman) if isroman($roman);    # convert from roman numerals

use Roman;

$roman_fifteen = roman(15);                         # "xv"

print "Roman for fifteen is $roman_fifteen\n";

$arabic_fifteen = arabic($roman_fifteen);

print "Converted back, $roman_fifteen is $arabic_fifteen\n";



Roman for fifteen is xv

               Converted back, xv is 15

            

use Time::localtime;

use Roman;

printf "The year is now %s\n", Roman(1900 + localtime->year);



The year is now MMIII

            

use charnames ":full";

print "2003 is", "\N{ROMAN NUMERAL ONE THOUSAND}" x 2, "\N{ROMAN NUMERAL THREE}\n";

$random = int( rand( $Y-$X+1 ) ) + $X;

$random = int( rand(51)) + 25;

print "$random\n";

$elt = $array[ rand @array ];

$elt = $array[ int( rand(0+@array) ) ];

@chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ % ^ & *) );

$password = join("", @chars[ map { rand @chars } ( 1 .. 8 ) ]);

srand EXPR;   # use a constant here for repeated sequences

srand( 42 );  # pick any fixed starting point

use Math::TrulyRandom;

$random = truly_random_value( );



use Math::Random;

$random = random_uniform( );

sub gaussian_rand {

    my ($u1, $u2);  # uniformly distributed random numbers

    my $w;          # variance, then a weight

    my ($g1, $g2);  # gaussian-distributed numbers



    do {

        $u1 = 2 * rand( ) - 1;

        $u2 = 2 * rand( ) - 1;

        $w = $u1*$u1 + $u2*$u2;

    } while ($w >= 1 || $w =  = 0);



    $w = sqrt( (-2 * log($w))  / $w );

    $g2 = $u1 * $w;

    $g1 = $u2 * $w;

    # return both if wanted, else just one

    return wantarray ? ($g1, $g2) : $g1;

}

# weight_to_dist: takes a hash mapping key to weight and returns

# a hash mapping key to probability

sub weight_to_dist {

    my %weights = @_;

    my %dist    = ( );

    my $total   = 0;

    my ($key, $weight);

    local $_;



    foreach (values %weights) {

        $total += $_;

    }



    while ( ($key, $weight) = each %weights ) {

        $dist{$key} = $weight/$total;

    }



    return %dist;

}



# weighted_rand: takes a hash mapping key to probability, and

# returns the corresponding element

sub weighted_rand {

    my %dist = @_;

    my ($key, $weight);



    while (1) {                     # to avoid floating point inaccuracies

        my $rand = rand;

        while ( ($key, $weight) = each %dist ) {

            return $key if ($rand -= $weight) < 0;

        }

    }

}

use constant PI => (4 * atan2 (1, 1));



sub deg2rad {

    my $degrees = shift;

    return ($degrees / 180) * PI;

}



sub rad2deg {

    my $radians = shift;

    return ($radians / PI) * 180;

}

use Math::Trig;



$radians = deg2rad($degrees);

$degrees = rad2deg($radians);

# deg2rad and rad2deg defined either as above or from Math::Trig

sub degree_sine {

    my $degrees = shift;

    my $radians = deg2rad($degrees);

    my $result = sin($radians);



    return $result;

}

sub tan {

    my $theta = shift;



    return sin($theta)/cos($theta);

}

use POSIX;



$y = acos(3.7);

use Math::Trig;



$y = acos(3.7);

eval {

    $y = tan($pi/2);

} or return undef;

$log_e = log(VALUE);

use POSIX qw(log10);

$log_10 = log10(VALUE);

sub log_base {

    my ($base, $value) = @_;

    return log($value)/log($base);

}

# log_base as defined earlier

$answer = log_base(10, 10_000);

print "log10(10,000) = $answer\n";

log10(10,000) = 4

            

use Math::Complex;

printf "log2(1024) = %lf\n", logn(1024, 2); # watch out for argument order!

log2(1024) = 10.000000

            

use PDL;

# $a and $b are both pdl objects

$c = $a x $b;

sub mmult {

    my ($m1,$m2) = @_;

    my ($m1rows,$m1cols) = matdim($m1);

    my ($m2rows,$m2cols) = matdim($m2);



    unless ($m1cols =  = $m2rows) {  # raise exception

        die "IndexError: matrices don't match: $m1cols != $m2rows";

    }



    my $result = [  ];

    my ($i, $j, $k);



    for $i (range($m1rows)) {

        for $j (range($m2cols)) {

            for $k (range($m1cols)) {

                $result->[$i][$j] += $m1->[$i][$k] * $m2->[$k][$j];

            }

        }

    }

    return $result;

}



sub range { 0 .. ($_[0] - 1) }



sub veclen {

    my $ary_ref = $_[0];

    my $type = ref $ary_ref;

    if ($type ne "ARRAY") { die "$type is bad array ref for $ary_ref" }

    return scalar(@$ary_ref);

}



sub matdim {

    my $matrix = $_[0];

    my $rows = veclen($matrix);

    my $cols = veclen($matrix->[0]);

    return ($rows, $cols);

}

use PDL;



$a = pdl [

    [ 3, 2, 3 ],

    [ 5, 9, 8 ],

];



$b = pdl [

    [ 4, 7 ],

    [ 9, 3 ],

    [ 8, 1 ],

];



$c = $a x $b;  # x overload

# $c = $a * $b manually

$c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );

$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );

# $c = $a * $b using Math::Complex

use Math::Complex;

$c = $a * $b;

$a_real = 3; $a_imaginary = 5;              # 3 + 5i;

$b_real = 2; $b_imaginary = -2;             # 2 - 2i;

$c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );

$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );

print "c = ${c_real}+${c_imaginary}i\n";



c = 16+4i

            

use Math::Complex;

$a = Math::Complex->new(3,5);               # or Math::Complex->new(3,5);

$b = Math::Complex->new(2,-2);

$c = $a * $b;

print "c = $c\n";



c = 16+4i

            

use Math::Complex;

$c = cplx(3,5) * cplx(2,-2);                # easier on the eye

$d = 3 + 4*i;                               # 3 + 4i

printf "sqrt($d) = %s\n", sqrt($d);



sqrt(3+4i) = 2+i

            

$number = hex($hexadecimal);         # hexadecimal only ("2e" becomes 47)

$number = oct($hexadecimal);         # "0x2e" becomes 47

$number = oct($octal);               # "057"  becomes 47

$number = oct($binary);              # "0b101110" becomes 47

print "Gimme an integer in decimal, binary, octal, or hex: ";

$num = <STDIN>;

chomp $num;

exit unless defined $num;

$num = oct($num) if $num =~ /^0/; # catches 077 0b10 0x20

printf "%d %#x %#o %#b\n", ($num) x 4;

sub commify {

    my $text = reverse $_[0];

    $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;

    return scalar reverse $text;

}

# more reasonable web counter :-)

use Math::TrulyRandom;

$hits = truly_random_value( );       # negative hits!

$output = "Your web page received $hits accesses last month.\n";

print commify($output);

Your web page received -1,740,525,205 accesses last month

            

printf "It took %d hour%s\n", $time, $time =  = 1 ? "" : "s";



printf "%d hour%s %s enough.\n", $time, 

        $time =  = 1 ? ""   : "s",

        $time =  = 1 ? "is" : "are";

printf "It took %d centur%s", $time, $time =  = 1 ? "y" : "ies";

sub noun_plural {

    local $_ = shift;

    # order really matters here!

    s/ss$/sses/                             ||

    s/([psc]h)$/${1}es/                     ||

    s/z$/zes/                               ||

    s/ff$/ffs/                              ||

    s/f$/ves/                               ||

    s/ey$/eys/                              ||

    s/y$/ies/                               ||

    s/ix$/ices/                             ||

    s/([sx])$/$1es/                         ||

    s/$/s/                                  ||

                die "can't get here";

    return $_;

}

*verb_singular = \&noun_plural;   # make function alias

($DAY, $MONTH, $YEAR) = (localtime)[3,4,5];

use Time::localtime;

$tm = localtime;

($DAY, $MONTH, $YEAR) = ($tm->mday, $tm->mon, $tm->year);

($day, $month, $year) = (localtime)[3,4,5];

printf("The current date is %04d %02d %02d\n", $year+1900, $month+1, $day);

The current date is 2003 03 06

            

($day, $month, $year) = (localtime)[3..5];

use Time::localtime;

$tm = localtime;

printf("The current date is %04d-%02d-%02d\n", $tm->year+1900, 

    ($tm->mon)+1, $tm->mday);

The current date is 2003-03-06

            

printf("The current date is %04d-%02d-%02d\n",

       sub {($_[5]+1900, $_[4]+1, $_[3])}->(localtime));

use POSIX qw(strftime);

print strftime "%Y-%m-%d\n", localtime;

use Time::Local;

$TIME = timelocal($sec, $min, $hours, $mday, $mon, $year);

$TIME = timegm($sec, $min, $hours, $mday, $mon, $year);

# $hours, $minutes, and $seconds represent a time today,

# in the current time zone

use Time::Local;

$time = timelocal($seconds, $minutes, $hours, (localtime)[3,4,5]);

# $day is day in month (1-31)

# $month is month in year (1-12)

# $year is four-digit year e.g., 1967

# $hours, $minutes and $seconds represent UTC (GMT) time 

use Time::Local;

$time = timegm($seconds, $minutes, $hours, $day, $month-1, $year-1900);

($seconds, $minutes, $hours, $day_of_month, $month, $year,

    $wday, $yday, $isdst) = localtime($time);

use Time::localtime;        # or Time::gmtime

$tm = localtime($TIME);     # or gmtime($TIME)

$seconds = $tm->sec;

# ...

($seconds, $minutes, $hours, $day_of_month, $month, $year,

    $wday, $yday, $isdst) = localtime($time);

printf("Dateline: %02d:%02d:%02d-%04d/%02d/%02d\n",

    $hours, $minutes, $seconds, $year+1900, $month+1,

    $day_of_month);

use Time::localtime;

$tm = localtime($time);

printf("Dateline: %02d:%02d:%02d-%04d/%02d/%02d\n",

    $tm->hour, $tm->min, $tm->sec, $tm->year+1900,

    $tm->mon+1, $tm->mday);

$when = $now + $difference;

$then = $now - $difference;

use Date::Calc qw(Add_Delta_Days);

($y2, $m2, $d2) = Add_Delta_Days($y, $m, $d, $offset);

use Date::Calc qw(Add_Delta_DHMS);

($year2, $month2, $day2, $h2, $m2, $s2) = 

    Add_Delta_DHMS( $year, $month, $day, $hour, $minute, $second,

                $days_offset, $hour_offset, $minute_offset, $second_offset );

$birthtime = 96176750;                  # 18/Jan/1973, 3:45:50 am

$interval = 5 +                         # 5 seconds

            17 * 60 +                   # 17 minutes

            2  * 60 * 60 +              # 2 hours

            55 * 60 * 60 * 24;          # and 55 days

$then = $birthtime + $interval;

print "Then is ", scalar(localtime($then)), "\n";

Then is Wed Mar 14 06:02:55 1973

            

use Date::Calc qw(Add_Delta_DHMS);

($year, $month, $day, $hh, $mm, $ss) = Add_Delta_DHMS(

    1973, 1, 18, 3, 45, 50, # 18/Jan/1973, 3:45:50 am

             55, 2, 17, 5); # 55 days, 2 hrs, 17 min, 5 sec

print "To be precise: $hh:$mm:$ss, $month/$day/$year\n";

$seconds = $recent - $earlier;

use Date::Calc qw(Delta_Days);

$days = Delta_Days( $year1, $month1, $day1, $year2, $month2, $day2);

use Date::Calc qw(Delta_DHMS);

($days, $hours, $minutes, $seconds) =

  Delta_DHMS( $year1, $month1, $day1, $hour1, $minute1, $seconds1,  # earlier

              $year2, $month2, $day2, $hour2, $minute2, $seconds2); # later

$bree = 361535725;          # 16 Jun 1981, 4:35:25

$nat  =  96201950;          # 18 Jan 1973, 3:45:50



$difference = $bree - $nat;

print "There were $difference seconds between Nat and Bree\n";

There were 265333775 seconds between Nat and Bree



$seconds    =  $difference % 60;

$difference = ($difference - $seconds) / 60;

$minutes    =  $difference % 60;

$difference = ($difference - $minutes) / 60;

$hours      =  $difference % 24;

$difference = ($difference - $hours)   / 24;

$days       =  $difference % 7;

$weeks      = ($difference - $days)    /  7;



print "($weeks weeks, $days days, $hours:$minutes:$seconds)\n";

(438 weeks, 4 days, 23:49:35)

            

($MONTHDAY, $WEEKDAY, $YEARDAY) = (localtime $DATE)[3,6,7];

$WEEKNUM = int($YEARDAY / 7) + 1;

use Date::Calc qw(Day_of_Week Week_Number Day_of_Year);

# you have $year, $month, and $day

# $day is day of month, by definition.

$wday = Day_of_Week($year, $month, $day);

$wnum = Week_Number($year, $month, $day);

$dnum = Day_of_Year($year, $month, $day);

use Date::Calc qw(Day_of_Week Week_Number Day_of_Week_to_Text);



$year  = 1981;

$month = 6;         # (June)

$day   = 16;



$wday = Day_of_Week($year, $month, $day);

print "$month/$day/$year was a ", Day_of_Week_to_Text($wday), "\n";

## see comment above



$wnum = Week_Number($year, $month, $day);

print "in the $wnum week.\n";

6/16/1981 was a Tuesday

               in week number 25

            

use Time::Local;

# $date is "2003-02-13" (YYYY-MM-DD form).

($yyyy, $mm, $dd) = ($date =~ /(\d+)-(\d+)-(\d+)/);

# calculate epoch seconds at midnight on that day in this timezone

$epoch_seconds = timelocal(0, 0, 0, $dd, $mm-1, $yyyy);

use Date::Manip qw(ParseDate UnixDate);

$date = ParseDate($STRING);

if (!$date) {

    # bad date

} else {

    @VALUES = UnixDate($date, @FORMATS);

}

$STRING = localtime($EPOCH_SECONDS);

use POSIX qw(strftime);

$STRING = strftime($FORMAT, $SECONDS, $MINUTES, $HOUR,

                   $DAY_OF_MONTH, $MONTH, $YEAR, $WEEKDAY,

                   $YEARDAY, $DST);

use Date::Manip qw(UnixDate);

$STRING = UnixDate($DATE, $FORMAT);

               Wed July 16 23:58:36 2003

            

use Time::Local;

$time = timelocal(50, 45, 3, 18, 0, 73);

print "Scalar localtime gives: ", scalar(localtime($time)), "\n";

Scalar localtime gives: Thu Jan 18 03:45:50 1973

            

use Time::HiRes qw(gettimeofday);

$t0 = gettimeofday( );    

## do your operation here

$t1 = gettimeofday( );

$elapsed = $t1 - $t0;

# $elapsed is a floating point value, representing number

# of seconds between $t0 and $t1

use Time::HiRes qw(gettimeofday);

print "Press return when ready: ";

$before = gettimeofday( );

$line = <STDIN>;

$elapsed = gettimeofday( ) - $before;

print "You took $elapsed seconds.\n";



Press return when ready

               You took 0.228149 seconds

            

select(undef, undef, undef, $time_to_sleep);

use Time::HiRes qw(sleep);

sleep($time_to_sleep);

while (<>) {

    select(undef, undef, undef, 0.25);

    print;

}

use Time::HiRes qw(sleep);

while (<>) {

    sleep(0.25);

    print;

}

@a = ("quick", "brown", "fox");

@a = qw(Meddle not in the affairs of wizards.);

@lines = (<< "END_OF_HERE_DOC" =~ /^\s*(.+)/gm);

    I sit beside the fire and think

    of all that I have seen,

    of meadow-flowers and butterflies 

    and summers that have been;

END_OF_HERE_DOC

@bigarray = ( );

open(FH, "<", "myinfo")   or die "Couldn't open myinfo: $!";

while (<FH>) {

    chomp;

    push(@bigarray, $_);

}

close(FH);

@banner = ('Costs', 'only', '$4.95');

@banner = qw(Costs only $4.95);

@banner = split(' ', 'Costs only $4.95');

sub commify_series {

    (@_ =  = 0) ? ''                                      :

    (@_ =  = 1) ? $_[0]                                   :

    (@_ =  = 2) ? join(" and ", @_)                       :

                join(", ", @_[0 .. ($#_-1)], "and $_[-1]");

}

@array = ("red", "yellow", "green");

print "I have ", @array, " marbles.\n";

print "I have @array marbles.\n";

I have redyellowgreen marbles

               I have red yellow green marbles

            

  #!/usr/bin/perl -w

  # commify_series - show proper comma insertion in list output

  

  # @lists is an array of (references to anonymous) arrays

  @lists = (

      [ 'just one thing' ],

      [ qw(Mutt Jeff) ],

      [ qw(Peter Paul Mary) ],

      [ 'To our parents', 'Mother Theresa', 'God' ],

      [ 'pastrami', 'ham and cheese', 'peanut butter and jelly', 'tuna' ],

      [ 'recycle tired, old phrases', 'ponder big, happy thoughts' ],

      [ 'recycle tired, old phrases', 

        'ponder big, happy thoughts', 

        'sleep and dream peacefully' ],

      );

  

  foreach $aref (@lists) {

      print "The list is: " . commify_series(@$aref) . ".\n";

  } 

  # demo for single list

  @list = qw(one two three);

  print "The last list is: " . commify_series(@list) . ".\n";

  

  sub commify_series {

      my $sepchar = grep(/,/ => @_) ? ";" : ",";

      (@_ =  = 0) ? ''                                      :

      (@_ =  = 1) ? $_[0]                                   :

      (@_ =  = 2) ? join(" and ", @_)                       :

                  join("$sepchar ", @_[0 .. ($#_-1)], "and $_[-1]");

  }

# grow or shrink @ARRAY

$#ARRAY = $NEW_LAST_ELEMENT_INDEX_NUMBER;

$ARRAY[$NEW_LAST_ELEMENT_INDEX_NUMBER] = $VALUE;

sub what_about_that_array {

    print "The array now has ", scalar(@people), " elements.\n";

    print "The index of the last element is $#people.\n";

    print "Element #3 is `$people[3]'.\n";

}



@people = qw(Crosby Stills Nash Young);

what_about_that_array( );

               The array now has 4 elements

               The index of the last element is 3

               Element #3 is `Young'

            

$#foo = 5;

@bar = ( (undef) x 5 ) ;



printf "foo element 3 is%s defined\n",

        defined $foo[3] ? "" : "n't";

printf "foo element 3 does%s exist\n",

        exists $foo[3] ? "" : "n't";

printf "bar element 3 is%s defined\n",

        defined $bar[3] ? "" : "n't";

printf "bar element 3 does%s exist\n",

        exists $bar[3] ? "" : "n't";



foo element 3 isn't defined

               foo element 3 doesn't exist

               bar element 3 isn't defined

               bar element 3 does exist

            

$real_array[ 1_000_000 ] = 1;       # costs 4+ megabytes

$fake_array{ 1_000_000 } = 1;       # costs 28 bytes

foreach $item (LIST) {

    # do something with $item

}

foreach $user (@bad_users) {

        complain($user);

}

foreach $var (sort keys %ENV) {

    print "$var=$ENV{$var}\n";

}

foreach $user (@all_users) {

    $disk_space = get_usage($user);     # find out how much disk space in use

    if ($disk_space > $MAX_QUOTA) {     # if it's more than we want ...

        complain($user);                # ... then object vociferously

    }

}

# iterate over elements of array in $ARRAYREF

foreach $item (@$ARRAYREF) {

    # do something with $item

}



for ($i = 0; $i <= $#$ARRAYREF; $i++) {

    # do something with $ARRAYREF->[$i]

}

@fruits = ( "Apple", "Blackberry" );

$fruit_ref = \@fruits;

foreach $fruit (@$fruit_ref) {

    print "$fruit tastes good in a pie.\n";

}

Apple tastes good in a pie

               Blackberry tastes good in a pie

            

for ($i=0; $i <= $#$fruit_ref; $i++) {

    print "$fruit_ref->[$i] tastes good in a pie.\n";

}

$namelist{felines} = \@rogue_cats;

foreach $cat ( @{ $namelist{felines} } ) {

    print "$cat purrs hypnotically..\n";

}

print "--More--\nYou are controlled.\n";

for ($i=0; $i <= $#{ $namelist{felines} }; $i++) {

    print "$namelist{felines}[$i] purrs hypnotically.\n";

}

foreach $item (@A) {

    push(@aonly, $item) unless $seen{$item};

    $seen{$item} = 1;                       # mark as seen

}

@a = (1, 3, 5, 6, 7, 8);

@b = (2, 3, 5, 7, 9);



@union = @isect = @diff = ( );

%union = %isect = ( );

%count = ( );

foreach $e (@a) { $union{$e} = 1 }



foreach $e (@b) {

    if ( $union{$e} ) { $isect{$e} = 1 }

    $union{$e} = 1;

}

@union = keys %union;

@isect = keys %isect;

foreach $e (@a, @b) { $union{$e}++ && $isect{$e}++ }



@union = keys %union;

@isect = keys %isect;

foreach $e (@a, @b) { $count{$e}++ }



@union = keys %count;

foreach $e (keys %count) {

    if ($count{$e} =  = 2) {

        push @isect, $e;

    } else {

        push @diff, $e;

    }

}

@isect = @diff = @union = ( );



foreach $e (@a, @b) { $count{$e}++ }



@union = keys %count;

foreach $e (keys %count) {

    push @{ $count{$e} =  = 2 ? \@isect : \@diff }, $e;

}

# push

push(@ARRAY1, @ARRAY2);

@ARRAY1 = (@ARRAY1, @ARRAY2);

@members = ("Time", "Flies");

@initiates = ("An", "Arrow");

push(@members, @initiates);

# @members is now ("Time", "Flies", "An", "Arrow")

splice(@members, 2, 0, "Like", @initiates);

print "@members\n";

splice(@members, 0, 1, "Fruit");

splice(@members, -2, 2, "A", "Banana");

print "@members\n";

               Time Flies Like An Arrow

               Fruit Flies Like A Banana

            

# reverse @ARRAY into @REVERSED

@REVERSED = reverse @ARRAY;

foreach $element (reverse @ARRAY) {

    # do something with $element

}

for ($i = $#ARRAY; $i >= 0; $i--) {

    # do something with $ARRAY[$i]

}

# two-step: sort then reverse

@ascending = sort { $a cmp $b } @users;

@descending = reverse @ascending;



# one-step: sort with reverse comparison

@descending = sort { $b cmp $a } @users;

# remove $N elements from front of @ARRAY (shift $N)

@FRONT = splice(@ARRAY, 0, $N);



# remove $N elements from the end of the array (pop $N)

@END = splice(@ARRAY, -$N);

push(@a, $x, $y)

splice(@a, @a, 0, $x, $y)

pop(@a)

splice(@a, -1)

shift(@a)

splice(@a, 0, 1)

unshift(@a, $x, $y)

splice(@a, 0, 0, $x, $y)

$a[$x] = $y

splice(@a, $x, 1, $y)

(@a, @a = ( ))

splice(@a)

sub shift2 (\@) {

    return splice(@{$_[0]}, 0, 2);

}



sub pop2 (\@) {

    return splice(@{$_[0]}, -2);

}

my ($match, $found, $item);

foreach $item (@array) {

    if (CRITERION) {

        $match = $item;  # must save

        $found = 1;

        last;

    }

}

if ($found) {

    ## do something with $match

} else {

    ## unfound

}

my ($i, $match_idx);

for ($i = 0; $i < @array; $i++) {

    if (CRITERION) {

        $match_idx = $i;    # save the index

        last;

    }

}



if (defined $match_idx) {

    ## found in $array[$match_idx]

} else {

    ## unfound

}

use List::Util qw(first);

$match = first { CRITERION } @list

@MATCHING = grep { TEST ($_) } @LIST;

@matching = ( );

foreach (@list) {

    push(@matching, $_) if TEST ($_);

}

@bigs = grep { $_ > 1_000_000 } @nums;

@pigs = grep { $users{$_} > 1e7 } keys %users;

@matching = grep { /^gnat / } `who`;

@engineers = grep { $_->position( ) eq "Engineer" } @employees;

@secondary_assistance = grep { $_->income >= 26_000 &&

                               $_->income <  30_000 }

                        @applicants;

@sorted = sort { $a <=> $b } @unsorted;

# @pids is an unsorted array of process IDs

foreach my $pid (sort { $a <=> $b } @pids) {

    print "$pid\n";

}

print "Select a process ID to kill:\n";

chomp ($pid = <>);

die "Exiting ... \n" unless $pid && $pid =~ /^\d+$/;

kill('TERM',$pid);

sleep 2;

kill('KILL',$pid);

@descending = sort { $b <=> $a } @unsorted;

@ordered = sort { compare( ) } @unordered;

@precomputed = map { [compute( ),$_] } @unordered;

@ordered_precomputed = sort { $a->[0] <=> $b->[0] } @precomputed;

@ordered = map { $_->[1] } @ordered_precomputed;

@ordered = map { $_->[1] }

           sort { $a->[0] <=> $b->[0] }

           map { [compute( ), $_] }

           @unordered;

@ordered = sort { $a->name cmp $b->name } @employees;

foreach $employee (sort { $a->name cmp $b->name } @employees) {

    print $employee->name, " earns \$", $employee->salary, "\n";

}

@sorted_employees = sort { $a->name cmp $b->name } @employees;

foreach $employee (@sorted_employees) {

    print $employee->name, " earns \$", $employee->salary, "\n";

}

# load %bonus

foreach $employee (@sorted_employees) {

    if ( $bonus{ $employee->ssn } ) {

      print $employee->name, " got a bonus!\n";

    }

}

unshift(@circular, pop(@circular));  # the last shall be first

push(@circular, shift(@circular));   # and vice versa

sub grab_and_rotate ( \@ ) {

    my $listref = shift;

    my $element = $listref->[0];

    push(@$listref, shift @$listref);

    return $element;

}



@processes = ( 1, 2, 3, 4, 5 );

while (1) {

    $process = grab_and_rotate(@processes);

    print "Handling process $process\n";

    sleep 1;

}

use List::Util qw(shuffle);

@array = shuffle(@array);

sub naive_shuffle {                             # DON'T DO THIS

    for (my $i = 0; $i < @_; $i++) {

        my $j = int rand @_;                    # pick random element

        ($_[$i], $_[$j]) = ($_[$j], $_[$i]);    # swap 'em

    }

}

$value = $array[ int(rand(@array)) ];

$HASH{$KEY} = $VALUE;

# %food_color defined per the introduction

$food_color{Raspberry} = "pink";

print "Known foods:\n";

foreach $food (keys %food_color) {

    print "$food\n";

}



Known foods

               Banana

               Apple

               Raspberry

               Carrot

               Lemon

            

# does %HASH have a value for $KEY ?

if (exists($HASH{$KEY})) {

    # it exists

} else {

    # it doesn't

}

# %food_color per the introduction

foreach $name ("Banana", "Martini") {

    if (exists $food_color{$name}) {

        print "$name is a food.\n";

    } else {

        print "$name is a drink.\n";

    }

}



Banana is a food

               Martini is a drink

            

%age = ( );

$age{"Toddler"}  = 3;

$age{"Unborn"}   = 0;

$age{"Phantasm"} = undef;



foreach $thing ("Toddler", "Unborn", "Phantasm", "Relic") {

    print "$thing: ";

    print "Exists "  if exists  $age{$thing};

    print "Defined " if defined $age{$thing};

    print "True "    if         $age{$thing};

    print "\n";

}



Toddler: Exists Defined True

               Unborn: Exists Defined

               Phantasm: Exists

               Relic

            

use Hash::Util qw{ lock_keys  unlock_keys

                   lock_value unlock_value

                   lock_hash  unlock_hash  };

lock_keys(%hash);                # restrict to current keys

lock_keys(%hash, @klist);        # restrict to keys from @klist

lock_value(%hash, $key);

lock_hash(%hash);

# remove $KEY and its value from %HASH

delete($HASH{$KEY});

# %food_color as per Introduction

sub print_foods {

    my @foods = keys %food_color;

    my $food;



    print "Keys: @foods\n";

    print "Values: ";



    foreach $food (@foods) {

        my $color = $food_color{$food};



        if (defined $color) {

            print "$color ";

        } else {

            print "(undef) ";

        }

    }

    print "\n";

}



print "Initially:\n";

print_foods( );



print "\nWith Banana undef\n";

undef $food_color{"Banana"};

print_foods( );



print "\nWith Banana deleted\n";

delete $food_color{"Banana"};

print_foods( );



Initially

               Keys: Banana Apple Carrot Lemon

               Values: yellow red orange yellow



               With Banana undef

               Keys: Banana Apple Carrot Lemon

               Values: (undef) red orange yellow



               With Banana deleted

               Keys: Apple Carrot Lemon

               Values: red orange yellow

            

while(($key, $value) = each(%HASH)) {

    # do something with $key and $value

}

foreach $key (keys %HASH) {

    $value = $HASH{$key};

    # do something with $key and $value

}

# %food_color per the introduction

while(($food, $color) = each(%food_color)) {

    print "$food is $color.\n";

}

Banana is yellow

               Apple is red

               Carrot is orange

               Lemon is yellow



foreach $food (keys %food_color) {

    my $color = $food_color{$food};

    print "$food is $color.\n";

}

Banana is yellow

               Apple is red

               Carrot is orange

               Lemon is yellow

            

print "$food is $food_color{$food}.\n"

while ( ($k,$v) = each %hash ) {

    print "$k => $v\n";

}

print map { "$_ => $hash{$_}\n" } keys %hash;

print "@{[ %hash ]}\n";

{

    my @temp = %hash;

    print "@temp";

}

foreach $k (sort keys %hash) {

    print "$k => $hash{$k}\n";

}

use Tie::IxHash;

tie %HASH, "Tie::IxHash";

# manipulate %HASH

@keys = keys %HASH;         # @keys is in insertion order

# initialize

use Tie::IxHash;



tie %food_color, "Tie::IxHash";

$food_color{"Banana"} = "Yellow";

$food_color{"Apple"}  = "Green";

$food_color{"Lemon"}  = "Yellow";



print "In insertion order, the foods are:\n";

foreach $food (keys %food_color) {

    print "  $food\n";

}



print "Still in insertion order, the foods' colors are:\n";

while (( $food, $color ) = each %food_color ) {

    print "$food is colored $color.\n";

}



In insertion order, the foods are

               Banana

               Apple

               Lemon

               Still in insertion order, the foods' colors are

               Banana is colored Yellow

               Apple is colored Green

               Lemon is colored Yellow

            

%ttys = ( );



open(WHO, "who|")                   or die "can't open who: $!";

while (<WHO>) {

    ($user, $tty) = split;

    push( @{$ttys{$user}}, $tty );

}



foreach $user (sort keys %ttys) {

    print "$user: @{$ttys{$user}}\n";

}

foreach $user (sort keys %ttys) {

    print "$user: ", scalar( @{$ttys{$user}} ), " ttys.\n";

    foreach $tty (sort @{$ttys{$user}}) {

        @stat = stat("/dev/$tty");

        $user = @stat ? ( getpwuid($stat[4]) )[0] : "(not available)";

        print "\t$tty (owned by $user)\n";

    }

}

# %LOOKUP maps keys to values

%REVERSE = reverse %LOOKUP;

%surname = ( "Mickey" => "Mantle", "Babe" => "Ruth" );

%first_name = reverse %surname;

print $first_name{"Mantle"}, "\n";

Mickey

            

("Mickey", "Mantle", "Babe", "Ruth")

("Ruth", "Babe", "Mantle", "Mickey")

("Ruth" => "Babe", "Mantle" => "Mickey")

  #!/usr/bin/perl -w

  # foodfind - find match for food or color

  $given = shift @ARGV or die "usage: foodfind food_or_color\n";

  %color = (

             "Apple"  => "red",

             "Banana" => "yellow",

             "Lemon"  => "yellow",

             "Carrot" => "orange"

           );

  %food = reverse %color;

  if (exists $color{$given}) {

      print "$given is a food with color $color{$given}.\n";

  }

  if (exists $food{$given}) {

      print "$food{$given} is a food with color $given.\n";

  }

# %hash is the hash to sort

@keys = sort { criterion( ) } (keys %hash);

foreach $key (@keys) {

    $value = $hash{$key};

    # do something with $key, $value

}

foreach $food (sort keys %food_color) {

    print "$food is $food_color{$food}.\n";

}

foreach $food (sort { $food_color{$a} cmp $food_color{$b} }

                keys %food_color)

{

    print "$food is $food_color{$food}.\n";

}

@foods = sort {

          length($food_color{$a}) <=> length($food_color{$b})

         } keys %food_color;

foreach $food (@foods) {

    print "$food is $food_color{$food}.\n";

}

%merged = (%A, %B);

%merged = ( );

while ( ($k,$v) = each(%A) ) {

    $merged{$k} = $v;

}

while ( ($k,$v) = each(%B) ) {

    $merged{$k} = $v;

}

# %food_color as per the introduction

%drink_color = ( Galliano  => "yellow",

                 "Mai Tai" => "blue" );



%ingested_color = (%drink_color, %food_color);

# %food_color per the introduction, then

%drink_color = ( Galliano  => "yellow",

                 "Mai Tai" => "blue" );



%substance_color = ( );

while (($k, $v) = each %food_color) {

    $substance_color{$k} = $v;

}

while (($k, $v) = each %drink_color) {

    $substance_color{$k} = $v;

}

# %food_color per the introduction



# %citrus_color is a hash mapping citrus food name to its color.

%citrus_color = ( Lemon  => "yellow",

                  Orange => "orange",

                  Lime   => "green" );



# build up a list of non-citrus foods

@non_citrus = ( );



foreach (keys %food_color) {

    push (@non_citrus, $_) unless $citrus_color{$_};

}

use Tie::RefHash;

tie %hash, "Tie::RefHash";

# you may now use references as the keys to %hash

               Class::Somewhere=HASH(0x72048)

               ARRAY(0x72048)

            

use Tie::RefHash;

use IO::File;



tie %name, "Tie::RefHash";

foreach $filename ("/etc/termcap", "/vmunix", "/bin/cat") {

    $fh = IO::File->new("< $filename") or next;

    $name{$fh} = $filename;

}

print "open files: ", join(", ", values %name), "\n";

foreach $file (keys %name) {

    seek($file, 0, 2);      # seek to the end

    printf("%s is %d bytes long.\n", $name{$file}, tell($file));

}

# presize %hash to $num

keys(%hash) = $num;

# will have 512 users in %users

keys(%users) = 512;

keys(%users) = 1000;

%count = ( );

foreach $element (@ARRAY) {

    $count{$element}++;

}

%father = ( 'Cain'      => 'Adam',

            'Abel'      => 'Adam',

            'Seth'      => 'Adam',

            'Enoch'     => 'Cain',

            'Irad'      => 'Enoch',

            'Mehujael'  => 'Irad',

            'Methusael' => 'Mehujael',

            'Lamech'    => 'Methusael',

            'Jabal'     => 'Lamech',

            'Jubal'     => 'Lamech',

            'Tubalcain' => 'Lamech',

            'Enos'      => 'Seth' );

while (<>) {

    chomp;

    do {

        print "$_ ";        # print the current name

        $_ = $father{$_};   # set $_ to $_'s father

    } while defined;        # until we run out of fathers

    print "\n";

}

while ( ($k,$v) = each %father ) {

    push( @{ $children{$v} }, $k );

}



$" = ', ';                  # separate output with commas

while (<>) {

    chomp;

    if ($children{$_}) {

        @children = @{$children{$_}};

    } else {

        @children = "nobody";

    }

    print "$_ begat @children.\n";

}

$dst = $src;

$dst =~ s/this/that/;

($dst = $src) =~ s/this/that/;

# strip to basename

($progname = $0)        =~ s!^.*/!!;



# Make All Words Title-Cased

($capword  = $word)     =~ s/(\w+)/\u\L$1/g;



# /usr/man/man3/foo.1 changes to /usr/man/cat3/foo.1

($catpage  = $manpage)  =~ s/man(?=\d)/cat/;

@bindirs = qw( /usr/bin /bin /usr/local/bin );

for (@libdirs = @bindirs) { s/bin/lib/ }

print "@libdirs\n";

/usr/lib /lib /usr/local/lib

            

($a =  $b) =~ s/x/y/g;      # 1: copy $b and then change $a

 $a = ($b  =~ s/x/y/g);     # 2: change $b, count goes in $a

 $a =  $b  =~ s/x/y/g;      # 3: same as 2

if ($var =~ /^[A-Za-z]+$/) {

    # it is purely alphabetic

}

if ($var =~ /^\p{Alphabetic}+$/) {   # or just /^\pL+$/

    print "var is purely alphabetic\n";

}

if ($var =~ /^[^\W\d_]+$/) {

    print "var is purely alphabetic\n";

}

if ($var =~ /^[[:alpha:]]+$/) {

    print "var is purely alphabetic\n";

}

use locale;

use POSIX 'locale_h';



# the following locale string might be different on your system

unless (setlocale(LC_ALL, "fr_CA.ISO8859-1")) {

    die "couldn't set locale to French Canadian\n";

}



while (<DATA>) {

    chomp;

    if (/^[^\W\d_]+$/) {

        print "$_: alphabetic\n";

    } else {

        print "$_: line noise\n";

    }

}



_ _END_ _

silly

façade

coöperate

niño

Renée

Molière

hæmoglobin

naïve

tschüß

random!stuff#here

/\S+/               # as many non-whitespace characters as possible

/[A-Za-z'-]+/       # as many letters, apostrophes, and hyphens

/\b([A-Za-z]+)\b/            # usually best

/\s([A-Za-z]+)\s/            # fails at ends or w/ punctuation

               One fish two fish red fish blue fish

            

$WANT = 3;

$count = 0;

while (/(\w+)\s+fish\b/gi) {

    if (++$count =  = $WANT) {

        print "The third fish is a $1 one.\n";

        # Warning: don't `last' out of this loop

    }

}

The third fish is a red one.

            

/(?:\w+\s+fish\s+){2}(\w+)\s+fish/i;

# simple way with while loop

$count = 0;

while ($string =~ /PAT/g) {

    $count++;               # or whatever you'd like to do here

}



# same thing with trailing while

$count = 0;

$count++ while $string =~ /PAT/g;



# or with for loop

for ($count = 0; $string =~ /PAT/g; $count++) { }



# Similar, but this time count overlapping matches

$count++ while $string =~ /(?=PAT)/g;

$pond  = 'One fish two fish red fish blue fish';



# using a temporary

@colors = ($pond =~ /(\w+)\s+fish\b/gi);      # get all matches

$color  = $colors[2];                         # then the one we want



# or without a temporary array

$color = ( $pond =~ /(\w+)\s+fish\b/gi )[2];  # just grab element 3



print "The third fish in the pond is $color.\n";

undef $/;

@chunks = split(/pattern/, <FILEHANDLE>);

# .Ch, .Se and .Ss divide chunks of STDIN

{

    local $/ = undef;

    @chunks = split(/^\.(Ch|Se|Ss)$/m, <>);

}

print "I read ", scalar(@chunks), " chunks.\n";

while (<>) {

    if (/BEGIN PATTERN/ .. /END PATTERN/) {

        # line falls between BEGIN and END in the

        # text, inclusive.

    }

}



while (<>) {

    if (FIRST_LINE_NUM .. LAST_LINE_NUM) {

        # operate only between first and last line, inclusive.

    }

}

while (<>) {

    if (/BEGIN PATTERN/ ... /END PATTERN/) {

        # line is between BEGIN and END on different lines

    }

}



while (<>) {

    if (FIRST_LINE_NUM ... LAST_LINE_NUM) {

        # operate only between first and last line, not inclusive

    }

}

sub glob2pat {

    my $globstr = shift;

    my %patmap = (

        '*' => '.*',

        '?' => '.',

        '[' => '[',

        ']' => ']',

    );

    $globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;

    return '^' . $globstr . '$';

}

while ($line = <>) {

    if ($line =~ /$pattern/o) {

        # do something

    }

}

@pats = map { qr/$_/ } @strings;

while ($line = <>) {

    for $pat (@pats) {

        if ($line =~ /$pat/) {

            # do something;

        }

    }

}

do {

    print "Pattern? ";

    chomp($pat = <>);

    eval { "" =~ /$pat/ };

    warn "INVALID PATTERN $@" if $@;

} while $@;

sub is_valid_pattern {

    my $pat = shift;

    eval { "" =~ /$pat/ };

    return $@ ? 0 : 1;

}

sub is_valid_pattern {

    my $pat = shift;

    return eval { "" =~ /$pat/; 1 } || 0;

}

use locale;

use String::Approx qw(amatch);



if (amatch("PATTERN", @list)) {

    # matched

}



@matches = amatch("PATTERN", @list);

use String::Approx qw(amatch);

open(DICT, "/usr/dict/words")               or die "Can't open dict: $!";

while(<DICT>) {

    print if amatch("balast");

}



ballast

               balustrade

               blast

               blastula

               sandblast

            

while (/(\d+)/g) {

    print "Found number $1\n";

}

$n = "   49 here";

$n =~ s/\G /0/g;

print $n;

00049 here

            

while (/\G,?(\d+)/g) {

    print "Found number $1\n";

}

$_ = "The year 1752 lost 10 days on the 3rd of September";



while (/(\d+)/gc) {

    print "Found number $1\n";

}

# the /c above left pos at end of final match



if (/\G(\S+)/g) {

    print "Found $1 right after the last number.\n";

}



Found number 1752

               

$/ = '';                      # paragrep mode

while (<>) {

    while ( m{

                \b            # start at a word boundary (begin letters)

                (\S+)         # find chunk of non-whitespace

                \b            # until another word boundary (end letters)

                (

                    \s+       # separated by some whitespace

                    \1        # and that very same chunk again

                    \b        # until another word boundary

                ) +           # one or more sets of those

             }xig

         )

    {

        print "dup word '$1' at paragraph $.\n";

    }

}

my $np;

$np = qr{

           \(

           (?:

              (?> [^( )]+ )    # Non-capture group w/o backtracking

            |

              (??{ $np })     # Group with matching parens

           )*

           \)

        }x;

if ($word =~ /^(\w+)\w?(??{reverse $1})$/ ) {

    print "$word is a palindrome.\n";

}

$text = "myfunfun(1,(2*(3+4)),5)";

$funpat = qr/\w+$np/;   # $np as above

$text =~ /^$funpat$/;   # Matches!

use Regexp::Common;

$text = "myfunfun(1,(2*(3+4)),5)";

if ($text =~ /(\w+\s*$RE{balanced}{-parens=>'( )'})/o) {

  print "Got function call: $1\n";

}

chomp($pattern = <CONFIG_FH>);

if ( $data =~ /$pattern/ ) { ..... }

/ALPHA|BETA/

/(?:ALPHA)|(?:BETA)/  # works no matter what in both

/^(?=.*ALPHA)BETA/s

/ALPHA.*BETA|BETA.*ALPHA/s

/^(?:(?!PAT).)*$/s

/(?=^(?:(?!BAD).)*$)GOOD/s

    if (!($string =~ /pattern/)) { something( ) }   # ugly

    if (  $string !~ /pattern/)  { something( ) }   # preferred

unless (  $string =~ /pattern/)  { something( ) }   # sometimes clearer

Dear someuser@host.com,



Please confirm the mail address you gave us on Sun Jun 29

10:29:01 MDT 2003 by replying to this message.  Include the

string "Rumpelstiltskin" in that reply, but spelled in reverse;

that is, start with "Nik...".  Once this is done, your confirmed

address will be entered into our records.

1 while $addr =~ s/\([^( )]*\)//g;

chomp($answer = <>);

if    ("SEND"  =~ /^\Q$answer/i) { print "Action is send\n"  }

elsif ("STOP"  =~ /^\Q$answer/i) { print "Action is stop\n"  }

elsif ("ABORT" =~ /^\Q$answer/i) { print "Action is abort\n" }

elsif ("LIST"  =~ /^\Q$answer/i) { print "Action is list\n"  }

elsif ("EDIT"  =~ /^\Q$answer/i) { print "Action is edit\n"  }

use Text::Abbrev;

$href = abbrev qw(send abort list edit);

for (print "Action: "; <>; print "Action: ") {

    chomp;

    my $action = $href->{ lc($_) };

    print "Action is $action\n";

}

open(SOURCE, "< $path")

    or die "Couldn't open $path for reading: $!\n";



open(SINK, "> $path")

    or die "Couldn't open $path for writing: $!\n";

open(SOURCE, "<", $path)

    or die "Couldn't open $path for reading: $!\n";



open(SINK, ">", $path)

    or die "Couldn't open $path for writing: $!\n";

use Fcntl;



sysopen(SOURCE, $path, O_RDONLY)

    or die "Couldn't open $path for reading: $!\n";



sysopen(SINK, $path, O_WRONLY, 0600)

    or die "Couldn't open $path for writing: $!\n";

open(my $fh, "<", $path)

    or die "Couldn't open $path for reading: $!\n";

open(HANDLE, "<", $filename)          or die "cannot open $filename : $!\n";

sysopen(HANDLE, $filename, O_RDONLY)   or die "cannot open $filename: $!\n";

$filename = shift @ARGV;

open(INPUT, $filename)               or die "Couldn't open $filename : $!\n";

open(OUTPUT, ">$filename")

    or die "Couldn't open $filename for writing: $!\n";

open(OUTPUT, ">", $filename)

    or die "Couldn't open $filename for writing: $!\n";

use Fcntl;                          # for file constants



sysopen(OUTPUT, $filename, O_WRONLY|O_TRUNC)

    or die "Can't open $filename for writing: $!\n";

open(FH, glob("~joebob/somefile")) || die "Couldn't open file: $!";

$filename =~ s{ ^ ~ ( [^/]* ) }

              { $1

                    ? (getpwnam($1))[7]

                    : ( $ENV{HOME} || $ENV{LOGDIR}

                         || (getpwuid($<))[7]

                       )

}ex;

    ~              # current user's home directory

    ~/blah         # file blah in current user's home directory

    ~user          # a particular user's home directory

    ~user/blah     # file blah in a particular user's home directory

open(MAILRC, "<", "~/.mailrc")           # WRONG: tilde is a shell thing

    or die "can't open ~/.mailrc: $!";



open(MAILRC, "<", glob("~/.mailrc"))     # so expand tilde first

    or die "can't open ~/.mailrc: $!";

open($path, "<", $path)

    or die "Couldn't open $path for reading : $!\n";

               Argument "3\n" isn't numeric in multiply at tallyweb line 16, <LOG> chunk 17

            

               Argument "3\n" isn't numeric in multiply at tallyweb

               line 16, </usr/local/data/mylog3.dat> chunk 17

            

open(my $fh, "<", $filename)      or die "$0: can't open $filename: $!";

$variable = *FILEHANDLE;        # save in variable

subroutine(*FILEHANDLE);        # or pass directly



sub subroutine {

    my $fh = shift;

    print $fh "Hello, filehandle!\n";

}

{

    open(my $fh, "< /etc/motd") or die;

    local $/;          # slurp mode

    $text = <$fh>;

}

use Symbol qw(qualify_to_ref);



sub my_eof (*) {

  my $handle = shift;

  $handle = qualify_to_ref($handle, caller( ));

  # use $handle

}

my_eof(HANDLE);

open(my $fh, "<", $filename) or die;

my_eof($fh);

use FileCache;

cacheout ($path);         # each time you use a filehandle

print $path "output";

foreach $filehandle (@FILEHANDLES) {

    print $filehandle $stuff_to_print;

}

open(MANY, "| tee file1 file2 file3 > /dev/null")   or die $!;

print MANY "data\n"                                 or die $!;

close(MANY)                                         or die $!;

use IO::Tee;

$tee = IO::Tee->new(@FILEHANDLES);

print $tee $stuff_to_print;

for $fh (*FH1, *FH2, *FH3)      { print $fh "whatever\n" }

open (FH, "| tee file1 file2 file3 >/dev/null");

print FH "whatever\n";

# make STDOUT go to three files, plus original STDOUT

open (STDOUT, "| tee file1 file2 file3") or die "Teeing off: $!\n";

print "whatever\n"                       or die "Writing: $!\n";

close(STDOUT)                            or die "Closing: $!\n";

open(FH, "<&=", $FDNUM)       # open FH to the descriptor itself

open(FH, "<&",  $FDNUM);      # open FH to a copy of the descriptor

use IO::Handle;

$fh = IO::Handle->new_from_fd($FDNUM, "r");

use IO::Handle;



$fh = new IO::Handle;

$fh->fdopen($FDNUM, "r");            # open fd 3 for reading

$fd = $ENV{MHCONTEXTFD};

open(MHCONTEXT, "<&=", $fd)   or die "couldn't fdopen $fd: $!";

# after processing

close(MHCONTEXT)              or die "couldn't close context file: $!";

*ALIAS = *ORIGINAL;

open(OUTCOPY, ">&STDOUT")        or die "Couldn't dup STDOUT: $!";

open(INCOPY,  "<&STDIN")         or die "Couldn't dup STDIN : $!";

open(OUTALIAS, ">&=STDOUT")      or die "Couldn't alias STDOUT: $!";

open(INALIAS,  "<&=STDIN")       or die "Couldn't alias STDIN : $!";

open(BYNUMBER, ">&=5")           or die "Couldn't alias file descriptor 5: $!";

open(my $copy, "<&",  $original) or die "Couldn't alias original: $!";

open(my $copy, "<&=", $original) or die "Couldn't alias original: $!";

use File::Temp qw/ tempdir /;

$fh = tempfile( );  # just the handle

use File::Temp qw/ tempdir /;

# or specify a directory

$dir = tempdir( CLEANUP => 1 );

($fh, $filename) = tempfile( DIR => $dir );



$template = "myprogtempXXXXXX"; # trailing Xs are changed

($fh, $filename) = tempfile( $template, DIR => $dir);

($fh, $filename) = tempfile( $template, SUFFIX => ".data");

use File::Temp qw(tempfile);



# just the handle

$fh = tempfile( );



# handle and filename

($fh, $filename) = tempfile( );

while ( <DATA>) {

    # process the line

}

_ _DATA_ _

# your data goes here

while (<main::DATA>) {

    # process the line

}

_ _END_ _

# your data goes here

use Inline::Files;



while (<SETUP>) {

  # ...

}



while (<EXECUTION>) {

  # ...

}



_ _SETUP_ _

everything for the SETUP filehandle goes here

_ _EXECUTION_ _

everything for the EXECUTION filehandle goes here

use Inline::Files;



#

#  All your code for the file goes here first, then...

#



_ _ALPHA_ _

This is the data in the first virtual file, ALPHA.



_ _BETA_ _

This is the data in the next virtual file, BETA.



_ _OMEGA_ _

This is the data in yet another virtual file, OMEGA.



_ _ALPHA_ _

This is more data in the second part of virtual file, ALPHA.

while (<OMEGA>) {

   print "omega data: $_";

}



while (<ALPHA>) {

   print "alpha data: $_";

}

omega data: This is the data in yet another virtual file, OMEGA.

omega data:

alpha data: This is the data in the first virtual file, ALPHA.

alpha data:

alpha data: This is more data in the second part of virtual file, ALPHA.

alpha data:

while (<>) {

    # do something with the line

}

while (<>) {

    # ...

 }

unshift(@ARGV, "-") unless @ARGV;

while ($ARGV = shift @ARGV) {

    unless (open(ARGV, $ARGV)) {

        warn "Can't open $ARGV: $!\n";

        next;

    }

    while (defined($_ = <ARGV>)) {

        # ...

    }

}

open(OLD, "<", $old)        or die "can't open $old: $!";

open(NEW, ">", $new)        or die "can't open $new: $!";

while (<OLD>) {

    # change $_, then...

    print NEW $_            or die "can't write $new: $!";

}

close(OLD)                  or die "can't close $old: $!";

close(NEW)                  or die "can't close $new: $!";

rename($old, "$old.orig")   or die "can't rename $old to $old.orig: $!";

rename($new, $old)          or die "can't rename $new to $old: $!";

while (<OLD>) {

    if ($. =  = 20) {

        print NEW "Extra line 1\n";

        print NEW "Extra line 2\n";

    }

    print NEW $_;

}

while (<OLD>) {

    next if 20 .. 30;

    print NEW $_;

}

% perl -i.orig -p -e 'FILTER COMMAND' file1 file2 file3 ...

#!/usr/bin/perl -i.orig -p

# filter commands go here

while (<>) {

    if ($ARGV ne $oldargv) {           # are we at the next file?

        rename($ARGV, $ARGV . ".orig");

        open(ARGVOUT, ">", $ARGV);     # plus error check

        select(ARGVOUT);

        $oldargv = $ARGV;

    }

    s/DATE/localtime/e;

}

continue{

    print;

}

select (STDOUT);                      # restore default output

% perl -pi.orig -e 's/DATE/localtime/e'

Dear Sir/Madam/Ravenous Beast,

    As of DATE, our records show your account

is overdue.  Please settle by the end of the month.

Yours in cheerful usury,

    --A. Moneylender

Dear Sir/Madam/Ravenous Beast,

    As of Sat Apr 25 12:28:33 1998, our records show your account

is overdue.  Please settle by the end of the month.

Yours in cheerful usury,

    --A. Moneylender

open(FH, "+<", $FILE)               or die "Opening: $!";

@ARRAY = <FH>;

# change ARRAY here

seek(FH,0,0)                        or die "Seeking: $!";

print FH @ARRAY                     or die "Printing: $!";

truncate(FH,tell(FH))               or die "Truncating: $!";

close(FH)                           or die "Closing: $!";

open(F, "+<", $infile)      or die "can't read $infile: $!";

$out = "";

while (<F>) {

    s/DATE/localtime/eg;

    $out .= $_;

}

seek(F, 0, 0)               or die "can't seek to start of $infile: $!";

print F $out                or die "can't print to $infile: $!";

truncate(F, tell(F))        or die "can't truncate $infile: $!";

close(F)                    or die "can't close $infile: $!";

use Fcntl qw(:flock);               # for the LOCK_* constants

open(FH, "+<", $path)               or die "can't open $path: $!";

flock(FH, LOCK_EX)                  or die "can't flock $path: $!";

# update file, then...

close(FH)                           or die "can't close $path: $!";

$old_fh = select(OUTPUT_HANDLE);

$| = 1;

select($old_fh);

use IO::Handle;

OUTPUT_HANDLE->autoflush(1);

use IO::Handle;

$fh->autoflush(1);

use Fcntl;

sysopen(MODEM, "/dev/cua0", O_NONBLOCK|O_RDWR)

    or die "Can't open modem: $!\n";

use IO::Handle;

MODEM->blocking(0);  # assume MODEM already opened

use Fcntl;



$flags = "";

fcntl(HANDLE, F_GETFL, $flags)

    or die "Couldn't get flags for HANDLE : $!\n";

$flags |= O_NONBLOCK;

fcntl(HANDLE, F_SETFL, $flags)

    or die "Couldn't set flags for HANDLE: $!\n";

use Errno;



$rv = syswrite(HANDLE, $buffer, length $buffer);

if (!defined($rv) && $!{EAGAIN}) {

    # would block

} elsif ($rv != length $buffer) {

    # incomplete write

} else {

    # successfully wrote

}



$rv = sysread(HANDLE, $buffer, $BUFSIZ);

if (!defined($rv) && $!{EAGAIN}) {

    # would block

} else {

    # successfully read $rv bytes from HANDLE

}

$size = pack("L", 0);

ioctl(FH, $FIONREAD, $size)     or die "Couldn't call ioctl: $!\n";

$size = unpack("L", $size);



# $size bytes can be read

require "sys/ioctl.ph";



$size = pack("L", 0);

ioctl(FH, FIONREAD( ), $size)    or die "Couldn't call ioctl: $!\n";

$size = unpack("L", $size);

% grep FIONREAD /usr/include/*/*

/usr/include/asm/ioctls.h:#define FIONREAD      0x541B

            

use Inline C;



$FIONREAD = get_FIONREAD( );

# ...



_ _END_ _

_ _C_ _

#include <sys/ioctl.h>



int get_FIONREAD( ) {

  return FIONREAD;

}

% cat > fionread.c

#include <sys/ioctl.h>

main( ) {

    printf("%#08x\n", FIONREAD);

}

^D

% cc -o fionread fionread.c

% ./fionread

0x4004667f

            

$FIONREAD = 0x4004667f;         # XXX: opsys dependent



$size = pack("L", 0);

ioctl(FH, $FIONREAD, $size)     or die "Couldn't call ioctl: $!\n";

$size = unpack("L", $size);

$rin = "";

# repeat next line for all filehandles to poll

vec($rin, fileno(FH1), 1) = 1;

vec($rin, fileno(FH2), 1) = 1;

vec($rin, fileno(FH3), 1) = 1;



$nfound = select($rout=$rin, undef, undef, 0);

if ($nfound) {

  # input waiting on one or more of those 3 filehandles

  if (vec($rout,fileno(FH1),1)) {

      # do something with FH1

  }

  if (vec($rout,fileno(FH2),1)) {

      # do something with FH2

  }

  if (vec($rout,fileno(FH3),1)) {

      # do something with FH3

  }

}

use IO::Select;



$select = IO::Select->new( );

# repeat next line for all filehandles to poll

$select->add(*FILEHANDLE);

if (@ready = $select->can_read(0)) {

    # input waiting on the filehandles in @ready

}

$line = sysreadline(SOME_HANDLE);

$line = sysreadline(SOME_HANDLE, TIMEOUT);

use IO::Handle;

use IO::Select;

use Symbol qw(qualify_to_ref);



sub sysreadline(*;$) {

    my($handle, $timeout) = @_;

    $handle = qualify_to_ref($handle, caller( ));

    my $infinitely_patient = (@_ =  = 1 || $timeout < 0);

    my $start_time = time( );

    my $selector = IO::Select->new( );

    $selector->add($handle);

    my $line = "";

SLEEP:

    until (at_eol($line)) {

        unless ($infinitely_patient) {

            return $line if time( ) > ($start_time + $timeout);

        }

        # sleep only 1 second before checking again

        next SLEEP unless $selector->can_read(1.0);

INPUT_READY:

        while ($selector->can_read(0.0)) {

            my $was_blocking = $handle->blocking(0);

CHAR:       while (sysread($handle, my $nextbyte, 1)) {

                $line .= $nextbyte;

                last CHAR if $nextbyte eq "\n";

            }

            $handle->blocking($was_blocking);

            # if incomplete line, keep trying

            next SLEEP unless at_eol($line);

            last INPUT_READY;

        }

    }

    return $line;

}

sub at_eol($) { $_[0] =~ /\n\z/ }

while (defined($line = <FH>) ) {

    chomp $line;

    if ($line =~ s/\\$//) {

        $line .= <FH>;

        redo unless eof(FH);

    }

    # process full record in $line here

}

DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \

        $(TEXINFOS) $(INFOS) $(MANS) $(DATA)

DEP_DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \

        $(TEXINFOS) $(INFO_DEPS) $(MANS) $(DATA) \

        $(EXTRA_DIST)

if ($line =~ s/\\\s*$//) { 

    # as before

}

$count = `wc -l < $file`;

die "wc failed: $?" if $?;

chomp($count);

open(FILE, "<", $file) or die "can't open $file: $!";

$count++ while <FILE>;

# $count now holds the number of lines read

$count += tr/\n/\n/ while sysread(FILE, $_, 2 ** 20);

open(FILE, "<", $file) or die "can't open $file: $!";

$count++ while <FILE>;

# $count now holds the number of lines read

open(FILE, "<", $file) or die "can't open $file: $!";

for ($count=0; <FILE>; $count++) { }

1 while <FILE>;

$count = $.;

$/ = "";            # enable paragraph mode for all reads

open(FILE, "<", $file) or die "can't open $file: $!";

1 while <FILE>;

$para_count = $.;

while (<>) {

    for $chunk (split) {

        # do something with $chunk

    }

}

while (<>) {

    while ( /(\w[\w'-]*)/g ) {

        # do something with $1

    }

}

# Make a word frequency count

%seen = ( );

while (<>) {

    while ( /(\w[\w'-]*)/g ) {

        $seen{lc $1}++;

    }

}



# output hash in a descending numeric sort of its values

foreach $word ( sort { $seen{$b} <=> $seen{$a} } keys %seen) {

    printf "%5d %s\n", $seen{$word}, $word;

}

# Line frequency count

%seen = ( );

while (<>) {

    $seen{lc $_}++;

}

foreach $line ( sort { $seen{$b} <=> $seen{$a} } keys %seen ) {

    printf "%5d %s", $seen{$line}, $line;

}

@lines = <FILE>;

while ($line = pop @lines) {

    # do something with $line

}

@lines = reverse <FILE>;

foreach $line (@lines) {

    # do something with $line

}

use Tie::File;

tie(@lines, "Tie::File", $FILENAME, mode => 0)

    or die "Can't tie $FILENAME: $!";

$max_lines = $#lines;

for ($i = $max_lines; $i; $i--) {

    # do something with $lines[$i], eg line number them:

    printf "%5d  %s\n", $i+1, $lines[$i],

}

for ($i = $#lines; $i != -1; $i--) {

    $line = $lines[$i];

}

# this enclosing block keeps local $/ temporary

{           

    local $/ = "";

    @paragraphs = reverse <FILE>;

}



foreach $paragraph (@paragraphs) {

    # do something

}

for (;;) {

    while (<FH>) { .... }

    sleep $SOMETIME;

    seek(FH, 0, 1);

}

use IO::Handle;



for (;;) {

    while (<FH>) { .... }

    sleep $SOMETIME;

    FH->clearerr( );

}

$naptime = 1;



use IO::Handle;

open (LOGFILE, "/tmp/logfile") or die "can't open /tmp/logfile: $!";

for (;;) {

    while (<LOGFILE>) { print }     # or appropriate processing

    sleep $naptime;

    LOGFILE->clearerr( );            # clear stdio error flag

}

for (;;) {

    for ($curpos = tell(LOGFILE); <LOGFILE>; $curpos = tell(LOGFILE)) {

        # process $_ here

    }

    sleep $naptime;

    seek(LOGFILE, $curpos, 0);  # seek to where we had been

}

srand;

rand($.) < 1 && ($line = $_) while <>;

# $line is the random line

$/ = "%%\n";

@ARGV = ("/usr/share/games/fortunes") unless @ARGV;

srand;

rand($.) < 1 && ($adage = $_) while <>;

print $adage;

Here's a more rigorous explanation of how the algorithm works. The function call rand ($.) picks a random number between 0 and the current line number. Therefore, you have a one in N chance, that is, , of keeping the Nth line. Therefore you've a 100% chance of keeping the first line, a 50% chance of keeping the second, a 33% chance of keeping the third, and so on. The question is whether this is fair for all N, where N is any positive integer.

Obviously, a file with one line (N=1) is fair: you always keep the first line because = 100%, making it fair for files of 1 line. For a file with two lines, N=2. You always keep the first line; then when reaching the second line, you have a 50% chance of keeping it. Thus, both lines have an equal chance of being selected, which shows that N=2 is fair. For a file with three lines, N=3. You have a one-third chance, 33%, of keeping that third line. That leaves a two-thirds chance of retaining one of the first two out of the three lines. But we've already shown that for those first two lines there's a 50-50 chance of selecting either one. 50 percent of two-thirds is one-third. Thus, you have a one-third chance of selecting each of the three lines of the file.

use List::Util qw(shuffle);



while (<INPUT>) {

    push(@lines, $_);

}

@lines = shuffle(@lines);

foreach (@reordered) {

    print OUTPUT $_;

}

# looking for line number $DESIRED_LINE_NUMBER

$. = 0;

do { $LINE = <HANDLE> } until $. =  = $DESIRED_LINE_NUMBER || eof;

@lines = <HANDLE>;

$LINE = $lines[$DESIRED_LINE_NUMBER];

use Tie::File;

use Fcntl;



tie(@lines, Tie::File, $FILE, mode => O_RDWR)

  or die "Cannot tie file $FILE: $!\n";

$line = $lines[$sought - 1];

use DB_File;

use Fcntl;



$tie = tie(@lines, DB_File, $FILE, O_RDWR, 0666, $DB_RECNO) or die 

    "Cannot open file $FILE: $!\n";

# extract it

$line = $lines[$sought - 1];

# given $RECORD with field separated by a pattern,

# extract a list of fields

@FIELDS = split(/PATTERN/, $RECORD);

split(/([+-])/, "3+5-2");

(3, "+", 5, "-", 2)

@fields = split(/:/, $RECORD);

@fields = split(/\s+/, $RECORD);

@fields = split(" ", $RECORD);

use Tie::File;



tie @lines, Tie::File, $file        or die "can't update $file: $!";

delete $lines[-1];

open (FH, "+<", $file)              or die "can't update $file: $!";

while (<FH>) {

    $addr = tell(FH) unless eof(FH);

}

truncate(FH, $addr)                 or die "can't truncate $file: $!";

binmode(HANDLE);

binmode(HANDLE, ":raw");

open(FH, "< :raw", $filename);       # binary mode

use open IN => ":raw";      # binary files

$ADDRESS = $RECSIZE * $RECNO;

seek(FH, $ADDRESS, 0) or die "seek:$!";

read(FH, $BUFFER, $RECSIZE);

$ADDRESS = $RECSIZE * ($RECNO-1);

use Fcntl;                          # for SEEK_SET and SEEK_CUR



$ADDRESS = $RECSIZE * $RECNO;

seek(FH, $ADDRESS, SEEK_SET)        or die "Seeking: $!";

read(FH, $BUFFER, $RECSIZE) =  = $RECSIZE

                                    or die "Reading: $!";

@FIELDS = unpack($FORMAT, $BUFFER);

# update fields, then

$BUFFER = pack($FORMAT, @FIELDS);

seek(FH, -$RECSIZE, SEEK_CUR)       or die "Seeking: $!";

print FH $BUFFER;

close FH                            or die "Closing: $!";

binmode(FH);                        # binary mode

$old_rs = $/;                       # save old $/

$/ = "\0";                          # ASCII 0: NUL

seek(FH, $addr, SEEK_SET)           or die "Seek error: $!\n";

$string = <FH>;                     # read string

chomp $string;                      # remove NUL

$/ = $old_rs;                       # restore old $/

{

    local $/ = "\0";

    # ...

}                           # $/ is automatically restored

# $RECORDSIZE is the length of a record, in bytes.

# $TEMPLATE is the unpack template for the record

# FILE is the file to read from

# @FIELDS is an array, one element per field



until ( eof(FILE) ) {

    read(FILE, $record, $RECORDSIZE) =  = $RECORDSIZE

        or die "short read\n";

    @FIELDS = unpack($TEMPLATE, $record);

}

#define UT_LINESIZE           12

#define UT_NAMESIZE           8

#define UT_HOSTSIZE           16



struct utmp {                       /* here are the pack template codes */

    short ut_type;                  /* s for short, must be padded      */

    pid_t ut_pid;                   /* i for integer                    */

    char ut_line[UT_LINESIZE];      /* A12 for 12-char string           */

    char ut_id[2];                  /* A2, but need x2 for alignment    */

    time_t ut_time;                 /* l for long                       */

    char ut_user[UT_NAMESIZE];      /* A8 for 8-char string             */

    char ut_host[UT_HOSTSIZE];      /* A16 for 16-char string           */

    long ut_addr;                   /* l for long                       */

};

while (<CONFIG>) {

    chomp;                  # no newline

    s/#.*//;                # no comments

    s/^\s+//;               # no leading white

    s/\s+$//;               # no trailing white

    next unless length;     # anything left?

    my ($var, $value) = split(/\s*=\s*/, $_, 2);

    $User_Preferences{$var} = $value;

}

do "$ENV{HOME}/.progrc";

# set class C net

NETMASK = 255.255.255.0

MTU     = 296



DEVICE  = cua1

RATE    = 115200

MODE    = adaptive

no strict "refs";

$$var = $value;

# set class C net

$NETMASK = "255.255.255.0";

$MTU     = 0x128;

# Brent, please turn on the modem

$DEVICE  = "cua1";

$RATE    = 115_200;

$MODE    = "adaptive";

( $dev, $ino, $mode, $nlink, 

  $uid, $gid, $rdev, $size, 

  $atime, $mtime, $ctime, 

  $blksize, $blocks )       = stat($filename)

        or die "no $filename: $!";



$mode &= 07777;             # discard file type info

use File::stat;



$info = stat($filename)     or die "no $filename: $!";

if ($info->uid =  = 0) {

    print "Superuser owns $filename\n";

} 

if ($info->atime > $info->mtime) {

    print "$filename has been read since it was written.\n";

}

use File::stat;



sub is_safe {

    my $path = shift;

    my $info = stat($path);

    return unless $info;



    # owner neither superuser nor me 

    # the real uid is in stored in the $< variable

    if (($info->uid != 0) && ($info->uid != $<)) {

        return 0;

    }



    # check whether group or other can write file.

    # use 066 to detect either reading or writing

    if ($info->mode & 022) {   # someone else can write this

        return 0 unless -d _;  # non-directories aren't safe

            # but directories with the sticky bit (01000) are

        return 0 unless $info->mode & 01000;        

    }

    return 1;

}

use Tie::File;

use Fcntl;



tie @data, Tie::File, $FILENAME or die "Can't tie to $filename : $!\n";

# use array operations on @data to work with the file

use Fcntl;

tie(@data, Tie::File, $filename, mode => O_RDONLY)

  or die "Can't open $filename for reading: $!\n";

foreach (@data) {

  s/Perl Cookbook/Perl Cookbook (2nd edition)/g;

}

(tied @data)->defer;                     # defer updates

foreach (@data) {

  s/Perl Cookbook/Perl Cookbook (2nd edition)/g;

}

(tied @data)->flush;

use open IO => ":raw:utf8";

use open "IN" => ":bytes", "OUT" => ":utf8";

use open "IN" => ":encoding(Greek)",     # reading Greek

         "OUT" => ":utf8",               # writing 8-bit data in Unicode UTF-8,

         ":std";                         # STDIN is Greek,

open(my $ifh, "<:encoding(ENCODING_NAME)", $filename);

open(my $ofh, ">:encoding(ENCODING_NAME)", $filename);

binmode(IFH, ":encoding(cp1252)")

    || die "can't binmode to cp1252 encoding: $!";

open(MSMESS, "< :crlf :encoding(cp1252)", $inputfile)

    || die "can't open $inputfile: $!";

xterm -n unicode -u8 -fn -misc-fixed-medium-r-normal--20-200-75-75-c-100-iso10646-1

use File::Compare;



if (compare($FILENAME_1, $FILENAME_2) =  = 0) {

  # they're equal

}



if (compare(*FH1, *FH2) =  = 0) {

  # they're equal

}



if (compare($fh1, $fh2) =  = 0) {

  # they're equal

}

# ensure all filehandles in @fh hold the same data

foreach $fh (@fh[1..$#fh]) {

  if (compare($fh[0], $fh)) {

    # $fh differs

  }

}

use Text::Diff;



$diff = diff(*FH1, *FH2);

$diff = diff($FILENAME_1, $FILENAME_2, { STYLE => "Context" });

open($fh, "+<", \$string);   # read and write contents of $string

open($fh, "<",  \$string);   # read only

open($fh, ">",  \$string);   # write only, discard original contents

open($fh, "+>", \$string);   # read and write, discard original contents

open($fh, "+<", \$string);   # read and write, preserve original contents

($READTIME, $WRITETIME) = (stat($filename))[8,9];



utime($NEWREADTIME, $NEWWRITETIME, $filename);

$SECONDS_PER_DAY = 60 * 60 * 24;

($atime, $mtime) = (stat($file))[8,9];

$atime -= 7 * $SECONDS_PER_DAY;

$mtime -= 7 * $SECONDS_PER_DAY;



utime($atime, $mtime, $file)

    or die "couldn't backdate $file by a week w/ utime: $!";

$mtime = (stat $file)[9];

utime(time, $mtime, $file);

use File::stat;

utime(time, stat($file)->mtime, $file);

  #!/usr/bin/perl -w

  # uvi - vi a file without changing its access times

  

  $file = shift or die "usage: uvi filename\n";

  ($atime, $mtime) = (stat($file))[8,9];

  system($ENV{EDITOR} || "vi", $file);

  utime($atime, $mtime, $file)

      or die "couldn't restore $file to orig times: $!";

unlink($FILENAME)                 or die "Can't delete $FILENAME: $!\n";

unlink(@FILENAMES) =  = @FILENAMES    or die "Couldn't unlink all of @FILENAMES: $!\n";

unlink($file) or die "Can't unlink $file: $!";

unless (($count = unlink(@filelist)) =  = @filelist) {

    warn "could only delete $count of "

            . (@filelist) . " files";

}

use File::Copy;

copy($oldfile, $newfile);

open(IN,  "<", $oldfile)                    or die "can't open $oldfile: $!";

open(OUT, ">", $newfile)                    or die "can't open $newfile: $!";



$blksize = (stat IN)[11] || 16384;          # preferred block size?

while (1) {

    $len = sysread IN, $buf, $blksize);

    if (!defined $len) {

        next if $! =~ /^Interrupted/;       # ^Z and fg on EINTR

        die "System read error: $!\n";

    }

    last unless $len;



    $offset = 0;

    while ($len) {          # Handle partial writes.

        defined($written = syswrite OUT, $buf, $len, $offset)

            or die "System write error: $!\n";

        $len    -= $written;

        $offset += $written;

    };

}



close(IN);

close(OUT);

system("cp $oldfile $newfile");       # unix

system("copy $oldfile $newfile");     # dos, vms

use File::Copy;



copy("datafile.dat", "datafile.bak")

    or die "copy failed: $!";



move("datafile.dat", "datafile.new")

    or die "move failed: $!";

%seen = ( );



sub do_my_thing {

    my $filename = shift;

    my ($dev, $ino) = stat $filename;



    unless ($seen{$dev, $ino}++) {

        # do something with $filename because we haven't

        # seen it before

    }

}

foreach $filename (@files) {

    ($dev, $ino) = stat $filename;

    push( @{ $seen{$dev,$ino} }, $filename);

}



foreach $devino (sort keys %seen) {

    ($dev, $ino) = split(/$;/o, $devino);

    if (@{$seen{$devino}} > 1) {

        # @{$seen{$devino}} is a list of filenames for the same file

    }

}

opendir(DIR, $dirname) or die "can't opendir $dirname: $!";

while (defined($file = readdir(DIR))) {

    # do something with "$dirname/$file"

}

closedir(DIR);

$dir = "/usr/local/bin";

print "Text files in $dir are:\n";

opendir(BIN, $dir) or die "Can't open $dir: $!";

while( $file = readdir BIN) {

    print "$file\n" if -T "$dir/$file";

}

closedir(BIN);

while ( defined ($file = readdir BIN) ) {

    next if $file =~ /^\.\.?$/;     # skip . and ..

    # ...

}

@list = <*.c>;

@list = glob("*.c");

opendir(DIR, $path);

@files = grep { /\.c$/ } readdir(DIR);

closedir(DIR);

@files = grep { /\.[ch]$/i } readdir(DH);

opendir(DH, $dir)        or die "Couldn't open $dir for reading: $!";



@files = ( );

while( defined ($file = readdir(DH)) ) {

    next unless /\.[ch]$/i;



    my $filename = "$dir/$file";

    push(@files, $filename) if -T $filename;

}

use File::Find;

sub process_file {

    # do whatever;

}

find(\&process_file, @DIRLIST);

@ARGV = qw(.) unless @ARGV;

use File::Find;

find sub { print $File::Find::name, -d && "/", "\n" }, @ARGV;

use File::Find;

@ARGV = (".") unless @ARGV;

my $sum = 0;

find sub { $sum += -s }, @ARGV;

print "@ARGV contains $sum bytes\n";

foreach $file (@NAMES) {

    my $newname = $file;

    # change $newname

    rename($file, $newname) or  

        warn "Couldn't rename $file to $newname: $!\n";

}

  #!/usr/bin/perl -w

  # rename - Larry's filename fixer

  $op = shift or die "Usage: rename expr [files]\n";

  chomp(@ARGV = <STDIN>) unless @ARGV;

  for (@ARGV) {

      $was = $_;

      eval $op;

      die $@ if $@;

      rename($was,$_) unless $was eq $_;

  }

% rename 's/\.orig$//'  *.orig

% rename "tr/A-Z/a-z/ unless /^Make/"  *

% rename '$_ .= ".bad"'  *.f

% rename 'print "$_: "; s/foo/bar/ if <STDIN> =~ /^y/i'  *

% find /tmp -name "*~" -print | rename 's/^(.+)~$/.#$1/'

use File::Basename;



$base = basename($path);

$dir  = dirname($path);

($base, $dir, $ext) = fileparse($path);

$path = "/usr/lib/libc.a";

$file = basename($path);    

$dir  = dirname($path);     



print "dir is $dir, file is $file\n";

# dir is /usr/lib, file is libc.a

$path = "/usr/lib/libc.a";

($name,$dir,$ext) = fileparse($path,'\..*');



print "dir is $dir, name is $name, extension is $ext\n";

# dir is /usr/lib/, name is libc, extension is .a

fileparse_set_fstype("MacOS");

$path = "Hard%20Drive:System%20Folder:README.txt";

($name,$dir,$ext) = fileparse($path,'\..*');



print "dir is $dir, name is $name, extension is $ext\n";

# dir is Hard%20Drive:System%20Folder, name is README, extension is .txt

use Stat::lsMode;



$lsmode = file_mode($pathname);

use File::chmod;



chmod("g=rw,o=-w", @files);    # group can read/write, others can't write

chmod("-rwxr-xr--", @files);   # ls-style permissions

use Stat::lsMode;

print file_mode("/etc"), "\n";

print format_mode((stat "/etc")[2]), "\n";

drwxr-xr-x

               r-xr-xr-x

            

use File::chmod;

chmod("rwxr-xr-x", @files);

sub hypotenuse {

    return sqrt( ($_[0] ** 2) + ($_[1] ** 2) );

}



$diag = hypotenuse(3,4);  # $diag is 5

sub hypotenuse {

    my ($side1, $side2) = @_;

    return sqrt( ($side1 ** 2) + ($side2 ** 2) );

}

print hypotenuse(3, 4), "\n";               # prints 5



@a = (3, 4);

print hypotenuse(@a), "\n";                 # prints 5

sub somefunc {

    my $variable;                 # $variable is invisible outside somefunc( )

    my ($another, @an_array, %a_hash);     # declaring many variables at once



    # ...

}

{

    my $variable;

    sub mysub {

        # ... accessing $variable

    }

}

INIT {

    my $variable = 1;                       # initial value

    sub othersub {                          

      # ... accessing $variable

    }

}

{

    my $counter;

    sub next_counter { return ++$counter }

}

INIT {

    my $counter = 42;

    sub next_counter { return ++$counter }

    sub prev_counter { return --$counter }

}

$this_function = (caller(0))[3];

($package, $filename, $line, $subr, $has_args, $wantarray 

#   0         1         2       3       4          5

 $evaltext, $is_require, $hints, $bitmask

#   6         7            8       9

)= caller($i);

array_diff( \@array1, \@array2 );

@a = (1, 2);

@b = (5, 8);

@c = add_vecpair( \@a, \@b );

print "@c\n";

6 10



sub add_vecpair {                      # assumes both vectors the same length

    my ($x, $y) = @_;                  # copy in the array references

    my @result;



    for (my $i=0; $i < @$x; $i++) {

      $result[$i] = $x->[$i] + $y->[$i];

    }



    return @result;

}

unless (@_ =  = 2 && ref($x) eq 'ARRAY' && ref($y) eq 'ARRAY') {

    die "usage: add_vecpair ARRAYREF1 ARRAYREF2";

}

if (wantarray( )) {

    # list context

}

elsif (defined wantarray( )) {

    # scalar context

}

else {

    # void context

}

if (wantarray( )) {

    print "In list context\n";

    return @many_things;

} elsif (defined wantarray( )) {

    print "In scalar context\n";

    return $one_thing;

} else {

    print "In void context\n";

    return;  # nothing

}



mysub( );                    # void context



$a = mysub( );               # scalar context

if (mysub( )) {  }           # scalar context



@a = mysub( );               # list context

print mysub( );              # list context

thefunc(INCREMENT => "20s", START => "+5m", FINISH => "+30m");

thefunc(START => "+5m", FINISH => "+30m");

thefunc(FINISH => "+30m");

thefunc(START => "+5m", INCREMENT => "15s");

sub thefunc {

    my %args = ( 

        INCREMENT   => '10s', 

        FINISH      => 0, 

        START       => 0, 

        @_,         # argument pair list goes here

    );

    if ($args{INCREMENT}  =~ /m$/ ) { ... }

}

($a, undef, $c) = func( );

($a, $c) = (func( ))[0,2];

($dev,$ino,$DUMMY,$DUMMY,$uid) = stat($filename);

($dev,$ino,undef,undef,$uid)   = stat($filename);

($dev,$ino,$uid,$gid)   = (stat($filename))[0,1,4,5];

( ) = some_function( );

$count = ( ) = some_function( );

if (( ) = some_function( ))  { .... }

($array_ref, $hash_ref) = somefunc( );



sub somefunc {

    my @array;

    my %hash;



    # ...



    return ( \@array, \%hash );

}

sub fn { 

    .....

    return (\%a, \%b, \%c); # or                           

    return \(%a,  %b,  %c); # same thing

}

(%h0, %h1, %h2)  = fn( );    # WRONG!

@array_of_hashes = fn( );    # eg: $array_of_hashes[2]{"keystring"}

($r0, $r1, $r2)  = fn( );    # eg: $r2->{"keystring"}

return;

sub empty_retval {

    return ( wantarray ? ( ) : undef );

}

if (@a = yourfunc( )) { ... }

unless ($a = sfunc( )) { die "sfunc failed" }

unless (@a = afunc( )) { die "afunc failed" }

unless (%a = hfunc( )) { die "hfunc failed" }

ioctl(....) or die "can't ioctl: $!";

die "some message";         # raise exception

eval { func( ) };

if ($@) {

    warn "func raised an exception: $@";

}

eval { $val = func( ) };

warn "func blew up: $@" if $@;

our $age = 18;          # declare and set global variable

if (CONDITION) {

    local $age = 23;

    func( );         # sees temporary value of 23

} # Perl restores the old value at block exit

undef &grow;                       # silence -w complaints of redefinition

*grow = \&expand;           

grow( );                          # calls expand( )



{

    local *grow = \&shrink;        # only until this block exists

    grow( );                      # calls shrink( )

}

*one::var = \%two::Table;   # make %one::var alias for %two::Table

*one::big = \&two::small;   # make &one::big alias for &two::small

local *fred = \&barney;     # temporarily alias &fred to &barney

sub AUTOLOAD {

    my $color = our $AUTOLOAD;

    $color =~ s/.*:://;

    return "<FONT COLOR='$color'>@_</FONT>";

} 

#note: sub chartreuse isn't defined.

print chartreuse("stuff");

{

    local *yellow = \&violet;  

    local (*red, *green) = (\&green, \&red);

    print_stuff( );

}

sub outer {

    my $x = $_[0] + 35;

    sub inner { return $x * 19 }   # WRONG

    return $x + inner( );

}

sub outer {

    my $x = $_[0] + 35;

    local *inner = sub { return $x * 19 };

    return $x + inner( );

}

use Switch;

switch ($value) {

    case 17         { print "number 17"       }

    case "snipe"    { print "a snipe"         }

    case /[a-f]+/i  { print "pattern matched" }

    case [1..10,42] { print "in the list"     }

    case (@array)   { print "in the array"    }

    case (%hash)    { print "in the hash"     }

    else            { print "no case applies" }

}

$aref               = \@array;

$anon_array         = [1, 3, 5, 7, 9];

$anon_copy          = [ @array ];

@$implicit_creation = (2, 4, 6, 8, 10);

push(@$anon_array, 11);

$two = $implicit_creation->[0];

$last_idx  = $#$aref;

$num_items = @$aref;

$last_idx  = $#{ $aref };

$num_items = scalar @{ $aref };

# check whether $someref contains a simple array reference

if (ref($someref) ne "ARRAY") {

    die "Expected an array reference, not $someref\n";

}



print "@{$array_ref}\n";        # print original data



@order = sort @{ $array_ref };  # sort it



push @{ $array_ref }, $item;    # append new element to orig array

sub array_ref {

    my @array;

    return \@array;

}



$aref1 = array_ref( );

$aref2 = array_ref( );

push(@{ $hash{"KEYNAME"} }, "new value");

foreach $string (keys %hash) {

    print "$string: @{$hash{$string}}\n";

}

$hash{"a key"} = [ 3, 4, 5 ];       # anonymous array

@values = @{ $hash{"a key"} };

push @{ $hash{"a key"} }, $value;

@residents = @{ $phone2name{$number} };

@residents = exists( $phone2name{$number} )

                       ? @{ $phone2name{$number} }

                       : ( );

$href = \%hash;

$anon_hash = { "key1" => "value1", "key2" => "value2", ... };

$anon_hash_copy = { %hash };

%hash  = %$href;

$value = $href->{$key};

@slice = @$href{$key1, $key2, $key3};  # note: no arrow!

@keys  = keys %$href;

if (ref($someref) ne "HASH") {

    die "Expected a hash reference, not $someref\n";

}

foreach $href ( \%ENV, \%INC ) {       # OR: for $href ( \(%ENV,%INC) ) {

    foreach $key ( keys %$href ) {

        print "$key => $href->{$key}\n";

    }

}

@values = @$hash_ref{"key1", "key2", "key3"};



for $val (@$hash_ref{"key1", "key2", "key3"}) {

    $val += 7;   # add 7 to each value in hash slice

}

$cref = \&func;

$cref = sub { ... };

@returned = $cref->(@arguments);

@returned = &$cref(@arguments);

$funcname = "thefunc";

&$funcname( );

my %commands = (

    "happy" => \&joy,

    "sad"   => \&sullen,

    "done"  => sub { die "See ya!" },

    "mad"   => \&angry,

);



print "How are you? ";

chomp($string = <STDIN>);

if ($commands{$string}) {

    $commands{$string}->( );

} else {

    print "No such command: $string\n";

}

$scalar_ref = \$scalar;       # get reference to named scalar

undef $anon_scalar_ref;

$$anon_scalar_ref = 15;

$anon_scalar_ref = \15;

print ${ $scalar_ref };       # dereference it

${ $scalar_ref } .= "string"; # alter referent's value

sub new_anon_scalar {

    my $temp;

    return \$temp;

}

$sref = new_anon_scalar( );

$$sref = 3;

print "Three = $$sref\n";

@array_of_srefs = ( new_anon_scalar( ), new_anon_scalar( ) );

${ $array[0] } = 6.02e23;

${ $array[1] } = "avocado";

print "\@array contains: ", join(", ", map { $$_ } @array ), "\n";

$var        = `uptime`;     # $var holds text

$vref       = \$var;        # $vref "points to" $var

if ($$vref =~ /load/) {  }    # look at $var, indirectly

chomp $$vref;               # alter $var, indirectly

@array_of_scalar_refs = ( \$a, \$b );

@array_of_scalar_refs = \( $a, $b );

${ $array_of_scalar_refs[1] } = 12;         # $b = 12

($a, $b, $c, $d) = (1 .. 4);        # initialize

@array =  (\$a, \$b, \$c, \$d);     # refs to each scalar

@array = \( $a,  $b,  $c,  $d);     # same thing!

@array = map { \my $anon } 0 .. 3;  # allocate 4 anon scalar refs



${ $array[2] } += 9;                # $c now 12



${ $array[ $#array ] } *= 5;        # $d now 20

${ $array[-1] }        *= 5;        # same; $d now 100



$tmp   = $array[-1];                # using temporary

$$tmp *= 5;                         # $d now 500

use Math::Trig qw(pi);              # load the constant pi

foreach $sref (@array) {            # prepare to change $a,$b,$c,$d

    ($$sref **= 3) *= (4/3 * pi);   # replace with spherical volumes

}

$c1 = mkcounter(20);

$c2 = mkcounter(77);



printf "next c1: %d\n", $c1->{NEXT}->( );  # 21

printf "next c2: %d\n", $c2->{NEXT}->( );  # 78

printf "next c1: %d\n", $c1->{NEXT}->( );  # 22

printf "last c1: %d\n", $c1->{PREV}->( );  # 21

printf "old  c2: %d\n", $c2->{RESET}->( ); # 77

sub mkcounter {

    my $count  = shift;

    my $start  = $count;

    my $bundle = {

        "NEXT"   => sub { return ++$count  },

        "PREV"   => sub { return --$count  },

        "GET"    => sub { return $count    },

        "SET"    => sub { $count = shift   },

        "BUMP"   => sub { $count += shift  },

        "RESET"  => sub { $count = $start  },

    };

    $bundle->{"LAST"} = $bundle->{"PREV"};

    return $bundle;

}

$mref = sub { $obj->meth(@_) };

# later...

$mref->("args", "go", "here");

$sref = \$obj->meth;

$cref = $obj->can("meth");

$record = {

    NAME   => "Jason",

    EMPNO  => 132,

    TITLE  => "deputy peon",

    AGE    => 23,

    SALARY => 37_000,

    PALS   => [ "Norbert", "Rhys", "Phineas"],

};



printf "I am %s, and my pals are %s.\n",

    $record->{NAME},

    join(", ", @{$record->{PALS}});

# store record

$byname{ $record->{NAME} } = $record;



# later on, look up by name

if ($rp = $byname{"Aron"}) {        # false if missing

    printf "Aron is employee %d.\n", $rp->{EMPNO};

}



# give jason a new pal

push @{$byname{"Jason"}->{PALS}}, "Theodore";

printf "Jason now has %d pals\n", scalar @{$byname{"Jason"}->{PALS}};

# Go through all records

while (($name, $record) = each %byname) {

    printf "%s is employee number %d\n", $name, $record->{EMPNO};

}

FieldName: Value

foreach $record (@Array_of_Records) {

    for $key (sort keys %$record) {

        print "$key: $record->{$key}\n";

    }

    print "\n";

}

$/ = "";                # paragraph read mode

while (<>) {

    my @fields = split /^([^:]+):\s*/m;

    shift @fields;      # for leading null field

    push(@Array_of_Records, { map /(.*)/, @fields });

}

DB<1> $reference = [ { "foo" => "bar" }, 3, sub { print "hello, world\n" } ];

DB<2> x $reference

  

               0  ARRAY(0x1d033c)

               0  HASH(0x7b390)

               foo' = 'bar

               1  3

               2  CODE(0x21e3e4)

               -> &main::_ _ANON_ _[(eval 15)[/usr/local/...perl5db.pl:17]:2]

               in (eval 15)[/usr/local/.../perl5db.pl:17]:2-2

            

use Data::Dumper;

print Dumper($reference);

use Dumpvalue;

Dumpvalue->new->dumpValue($reference);

DB<3> x @INC

  

               0  ARRAY(0x807d0a8)

               0  '/home/tchrist/perllib

               1  '/usr/lib/perl5/i686-linux/5.00403

               2  '/usr/lib/perl5

               3  '/usr/lib/perl5/site_perl/i686-linux

               4  '/usr/lib/perl5/site_perl

               5  '.

            

use Dumpvalue;

Dumpvalue->new->dumpvars("main", "INC");



@INC = (

               

use Storable;



$r2 = dclone($r1);

@original = ( \@a, \@b, \@c );

@surface = @original;

@deep = map { [ @$_ ] } @original;

use Storable qw(dclone);

$r2 = dclone($r1);

%newhash = %{ dclone(\%oldhash) };

use Storable;

store(\%hash, "filename");



# later on...

$href = retrieve("filename");        # by ref

%hash = %{ retrieve("filename") };   # direct to hash

use Storable qw(nstore);

nstore(\%hash, "filename");

# later ...

$href = retrieve("filename");

use Storable qw(nstore_fd);

use Fcntl qw(:DEFAULT :flock);

sysopen(DF, "/tmp/datafile", O_RDWR|O_CREAT, 0666)

        or die "can't open /tmp/datafile: $!";

flock(DF, LOCK_EX)                   or die "can't lock /tmp/datafile: $!";

nstore_fd(\%hash, *DF)

    or die "can't store hash\n";

truncate(DF, tell(DF));

close(DF);

use MLDBM qw(DB_File);

use Fcntl;



tie(%hash, "MLDBM", "testfile.db", O_CREAT|O_RDWR, 0666)

    or die "can't open tie to testfile.db: $!";



# ... act on %hash



untie %hash;

use MLDBM qw(DB_File);

use Fcntl;

tie(%hash, "MLDBM", "testfile.db", O_CREAT|O_RDWR, 0666)

    or die "can't open tie to testfile.db: $!";

# this doesn't work!

$hash{"some key"}[4] = "fred";



# RIGHT

$aref = $hash{"some key"};

$aref->[4] = "fred";

$hash{"some key"} = $aref;

{

    my ($a, $b); 

    ($a, $b) = \($b, $a);   # same as (\$b, \$a);

}

use Devel::Peek;

$a = 42;

$b = \$a;

Dump $a;

SV = IV(0xd7cc4) at 0xd72b8

  REFCNT = 2

  FLAGS = (IOK,pIOK)

  IV = 42