From: Subject: Date: Fri, 21 Feb 2003 13:31:49 +0100 MIME-Version: 1.0 Content-Type: text/html; charset="windows-1250" Content-Transfer-Encoding: quoted-printable Content-Location: http://www.sct.gu.edu.au/~anthony/info/perl/general.hints X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2800.1106
--------------------------------------------------------------=
-----------------
Perl Style Summery...

Following the Perl style guide, identifiers in all capitals are reserved =
for
those with special meaning to Perl itself.  Functions and local =
variables
are all lowercase. The module's persistent variables (either file =
lexicals
or package globals) are capitalized. Identifiers with multiple words =
have
each of these separated by an underscore to make it easier to read. =
Please
don't use mixed capitals without underscores  - you wouldn't like =
reading
this book without spaces, either.

-------------------------------------------------------------------------=
------
Versions

perl -V              # all %Config defines
perl -V:archname     # the architucture to use for installation
perl '-V:install.*'  # the installation directories

perl -MTk -e 'print $Tk::VERSION,"\n"'
perl -MCGI -le 'print $CGI::VERSION'

NOTE: -l turns on  end of line auto handler (chomp input, add \n to =
output)

pmdesc -v -w -s     # print all perl modules and version numbers
                    #  perl cookbook  recipe 12.19  example 12-3

Debugger
  perl -d:ptkdb myscript.pl

Download Module from CPAN
   perl -MCPAN -e 'install MIME::Base64'

-------------------------------------------------------------------------=
------
Argument handling

# This method allows you to have options in the forms...
#      Multi-switch options:        -dvr
#      Option arguments either:     -nNAME  OR   -n NAME
#      Optional option argument:    -i.bak  OR   -i
#      tar-like option args:        -fbs filename blocks skip
#      Sort like numerical ranges:  -k20,30
#
# Developed from the Perl Camel Book v3,  page 122
# Programmers Note:
#    Within the inner option block...
#       "next" is equivelent to a "next OPTION"
#       "last" is equivelent to a "last OPTION"
#       "redo" means look for another multi-switch option (inner block)
#
use FindBin;
my $prog =3D $FindBin::Script;
#(my $prog =3D $0) =3D~ s/^.*\///;

sub Usage {
  die "$prog: ", @_, join("\n",
    "Usage: $prog [-c] [account...]",
    "       $prog [-v] -g",
    ), "\n";
}

ARGUMENT:  # Multi-switch option handling
while( @ARGV && $ARGV[0] =3D~ s/^-(?=3D.)// ) {
  $_ =3D shift; {
    m/^$/  && do { next };     # next argument
    m/^-$/ && do { last };     # End of options
    m/^\?/ && do { Usage };    # Usage Help

    s/^d// && do { $debug++;   redo };    # \
    s/^r// && do { $report++;  redo };    #  >  multi-switch =
options
    s/^v// && do { $verbose++; redo };    # /

    s/^n// && do { $name  =3D $_ || shift;  next };   # "-nARG" =
OR "-n ARG"
    s/^l// && do { $level =3D length() ? $_ : shift; next }; # =
"-l0"  OR  "-l 0"
    s/^i// && do { $back  =3D $_ || ".bak"; next };   # "-i.sfx" =
OR just "-i"

    s/^f// && do { $file   =3D shift;  redo };     # tar-like =
option arguments
    s/^b// && do { $blocks =3D shift;  redo };     # Eg:
    s/^s// && do { $skip   =3D shift;  redo };     #   -fbs =
filename blocks skip

    s/^k(\d+)// && do { $start =3D $1;  redo };   # Sort like =
numerical ranges
    s/^,(\d+)// && do { $end   =3D $1;  redo };   # EG:     =
-k10,20

    Usage( "Unknown Option \"-$_\"\n" );
  } continue { next ARGUMENT }; last ARGUMENT;
}
while( <> ) {
  ...
}

-------------------------------------------------------------------------=
------
Alturnative argument handling  (old method)

This is the older method of handling command line swicthes.
ALl options must be separate command line arguments...
EG:    tar -x -v -f filename    OR   tar -x -v -ffilename

# The `and' below is to prevent a undefined variable warning.
# It is also lower precidence so parentheses are not needed for =
assignment.
while( $_ =3D $ARGV[0] and ($_, $arg) =3D /^-(.)(.*)/ ) {
  $arg =3D '' unless defined $arg;   # Ensure $arg is defined
  shift;
  /-/ && do {                          last };  # End of options
  /c/ && do { $pass =3D 1;               next };  # Flag Option
  /n/ && do { $user =3D  $arg || shift;  next };  # Option =
Argument
  /T/ && do {                                   # Special option
    $arg =3D $arg || shift;
    'opt' eq $arg && do { $option  =3D 1; next };
    &Usage( "Bad Special -T Option `", $arg, "'\n" );
  }
  /Z/ && do {                                # List of Special =
Options
    for $arg ( split(/;/, $arg || shift) ) {
      ($_,$value) =3D split(/=3D/, $arg, 2);
      $value =3D ''  unless defined $value;
      /^binary$/   && do { $literal   =3D 1; next };
      /^log$/      && do { $log_file  =3D $value; next };
      # &Usage( "Bad Special -Z Option `", $arg, "'\n" );
    }
  };

  # Any unknown options -- generalised could get it wrong!
  # shift unless $arg || ARGV[0] =3D~ /^-/;

  &Usage( "UnknownBad Option \"-$_$arg\"\n" );
}
undef($arg);

-------------------------------------------------------------------------=
------
Indented Here Document

    (my $prog =3D $0) =3D~ s/^.*\///;
    sub Usage {
      die @_, herefile("
        | Usage: $prog [-options] file...
        |   -d   Output extra debugging information
        ");
    }

    print herefile( <<'EOF' );
        | yes the indent to the left is removed,
        | and any type of indentation can be used.
    EOF

    # Remove the indent of a here file...
    sub herefile {
      my $string =3D shift;
      $string =3D~ s/^\s*//;        # remove start spaces
      $string =3D~ s/^\s*\| ?//gm;  # remove line starts
      $string =3D~ s/\s*$/\n/g;     # remove end spaces
      return $string;
    }

-------------------------------------------------------------------------=
------
One liners

   # make a backup of all the listed files
   perl -p -i.bak -e '' <file list>

-------------------------------------------------------------------------=
------
Pod Documenting

#!/usr/bin/perl
=3Dhead1 NAME

program - A program with pod documention

=3Dhead1 SYNOPSIS

  program [options] file...
  Options: -f      flag
           -a arg  option with agument

=3Dhead1 DESCRIPTION

Program documention in the body of the document.

=3Dhead1 AUTHOR

  Anthony Thyssen  3 December 2002  anthony@cit.gu.edu.au

=3Dcut

sub Usage {
  eval {
    use Pod::Usage;
    pod2usage("@_");
  };
  exit 10;
}

-------------------------------------------------------------------------=
------
Legal tricks
   # tricky splits
   ($num)  =3D /(\d+)/;
   ($a, $b, $c) =3D /(\w+) (\w+) (\w+)/;
   ($before, $a, $b, $c, $after) =3D split(/(\w+) (\w+) (\w+)/, $_, 2);

   # Auto flush STDOUT and STDERR
   select((select(STDOUT), $| =3D 1)[$[]);
   select((select(STDERR), $| =3D 1)[$[]);

   # Assigned if variable is not true
   $option ||=3D "default_value";

   # Assign from cache if posible, otherwise look it up!
   $uid =3D $user{$user} ||=3D getpwnam($user);

   # Copy and Modify an Array  (which is better?)
   for( @new =3D @old ) { s/bad/good/g };
   map { s/bad/good/g } ( @new =3D @old );

   # Constant Variables (read only)
   $PI =3D 3;            # This will Fail!
   $PI++;              # eg this would work when it shouldn't
   *PI =3D \3.1415927;
   print "PI =3D $PI\n";

   # Proper constants (no "$" needed) (EG: as operators)
   sub PI() { 3.1415927 };               # approximation
   use constant PI =3D> 4 * atan2(1,1);    # calculated ONCE only

   Patch netscape for strong encryption
     #!/usr/bin/perl -0777pi
     s/TS:.*?\0/$_=3D$&;y,a-z, ,;s,    $,true,gm;s, 512,2048,;$_/es

   RE grep matching.
      @words =3D gw(alt1 alt2 alt3);
      $" =3D '|';            # get array word seperator to generate alts
      if ( $word ~=3D /^(@words)$/ ) {
         ...
      }

Notes
   /./  will NOT match "\n", but  /[\000-\377]/  will,  as will /./s.
   /^/  matchs start of string, but  /^/m  will match after "\n".
   /\A/ only matchs start of string  /\Z/ only matches end of string

   ?re?   Matches true ONCE ONLY for life of program or until reset() =
called.
          EG: match first time only in a loop.


Big NO NO -- Using local in looping block.

     for ( 1 .. 100 ) {          solution     local(@array)
        local(@array);             =3D=3D=3D>       for ( 1 .. 100 ) =
{
        ...                                      undef @array;
        ...                                      ...
     }                                        }

   The above will cause you to have 100 @arrays before the end of the =
loop.

   Alturnative use "my" instead of local.

-------------------------------------------------------------------------=
------
Regular Expressions....

Debuging, and seeing exactly what perl is doing...
see "Programming Perl v3" p213 (using embeded prints) and p195 for RE =
debuging

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

  Compress multiple blank lines to one blank line (its not easy!)
    perl -ne 'if (/\S/) { print; $i=3D0 } else {print unless $i; $i=3D1; =
}'

  Remove C Comments (using minimal RE expandsion - perl v5)
    $program =3D~ s{ /\* .*? \*/ }[]gsx;

  Remove surounding spaces in one RE
    s/^\s*(.*?)\s*$/$1/;

  do % escapes (aka printf)
    s/%(.)/$percent{$1}/g;         # simple escapes
    s/%(.)/$percent{$1}||$&/ge;    # `' but leave things alone if no =
escape

  replace all control chars with printed representations (not meta =
chars)
   s/([\0-\37\177])/ sprintf("^%c",ord($1)^64) /eg;

  Preserve capitalization in a substitution...
    replace substring $x with an equal length substring $y,
    but preserving the case of $x   (Hint, it uses bit patterns!)
      $string =3D~ s/($x)/"\L$y"^"\L$1"^$1/ie;

  Remove nested brakets (inside out) (p155 Perl5 Camel Book)
    1 while s/\([^()]*\)//g;

  Is number ($n) prime   -- This has not been tested  (big number =3D =
long test)
    print "PRIME" if (1 x $n) !~ /^(11+)\1+$/;

  Canonicalize whitespace (recomended method)
    for($string) {    # alias $string into $_
      s/^\s+//;
      s/\s+$//;
      s/\s+/ /g;
    }
  OR using split-join as one liner
    $string =3D join(' ', split(' ', $string));

  Convert a array of lines into an array of words
    @words =3D split(' ', join(' ', @lines));

Multi-line string Regular Expresions..
   NOTE: [\0-\xff] will match ANY character in a string.
   However a '.' will only match anything which is NOT a newline =
character.
   The '\A' and '\z' always match the real start/end of the string.
   NOTE: that '\Z' may match before a final newline character in the =
string
   The '$' normally matches as '\Z'.  EG: end of string or a final =
newline.

   These modifers modify this behaviour....
    /s     make '.' also match new lines (EG: ALL characters or =
[\0-\xff] )
    /m     make '^' and '$' match near newline characters,
              not just near the end of string

WARNING:
  Perl can execute code in regular expresions (often multiple times!)
  EG:    /....(?{..perl code..})..../;

-------------------------------------------------------------------------=
------
Misteries of the "comma" operator

  # NOTE Parentheses play a very important role
  # Also the ',' is of lower precedance (less important) than '=3D'
  $scalar =3D 'a', 'b', 'c';      # scalar;  $scalar =3D 'a'
  $scalar =3D ('a', 'b', 'c');    # scalar;  $scalar =3D 'c'
  ($scalar) =3D ('a', 'b', 'c');  # list;    $scalar =3D 'a'
  @array =3D 'a', 'b', 'c';       # scalar;  @array =3D ('a')
  @array =3D ('a', 'b', 'c');     # list;    @array =3D ('a', 'b', 'c')

-------------------------------------------------------------------------=
------
Scalar/List Contex in functions

    sub A {
      return ('a', 'b', 'c');
    }

    sub B {
      my @array =3D ('a', 'b', 'c');
      return @array;
    }

    sub C {
      my @array =3D ('a', 'b', 'c');
      return @array[0..$#array];
    }

    $a   =3D A();    # $a   =3D ('a', 'b', 'c') =3D> $a =3D 'c'  # =
Note comma operator
    ($b) =3D A();    # ($b) =3D ('a', 'b', 'c') =3D> $b =3D 'a'
    $c   =3D B();    # $c   =3D @array          =3D> $c =3D  3
    ($d) =3D B();    # ($d) =3D @array          =3D> $d =3D 'a'
    $e   =3D C();    # $e =3D 'c'      # C() behaves like A()!!!
    ($f) =3D C();    # $f =3D 'a'

-------------------------------------------------------------------------=
------
Setting signals

# to allow normal exit and thus proper use of END and DESTORY blocks.
use sigtrap(die normal-signals)

OR...

sub set_signal {
  my($func) =3D @_;
  $SIG{'INT'}  =3D $func;
  $SIG{'QUIT'} =3D $func;
  $SIG{'HUP'}  =3D $func;
  $SIG{'TERM'} =3D $func;
}

sub Interputed {
  print STDERR "Interupted, doing cleanup\n";
  system("rm -f ".mail_dir."/*$new");
  exit 10;
}

set_signal( \&Interupted );

OR...

#
# Interupt handler
#
# We don't want to be left with a truncated data file in the acctdb. Any
# interupt during that period is also recorded so we can abort when it =
is
# safe to do so.
#
my $interupted =3D 0;
sub interupt { $interupted =3D 1; } # We were interupted?

sub set_sig_handler {             # turn handler on/off
  my( $turn_on ) =3D @_;

  die "INTERUPT CAUGHT DURING CRITICAL PERIOD -- EXITING NOW\n"
    if $interupted;

  $SIG{'HUP'} =3D $SIG{'QUIT'} =3D
     $SIG{'INT'} =3D $SIG{'TERM'} =3D
         $turn_on ? 'interupt' : 'DEFAULT';
}

set_sig_handler(1);
# ... critical section ...
set_sig_handler(0);

-------------------------------------------------------------------------=
------
Automatic SU

  if ( $> =3D=3D 0 ) {
    print "$prog : You must be user $db_user \n" ;
    print "-- performing automatic su \n" ;
    { exec 'su', '-',$db_user,'-c',
                  "'".join("' '","$db_home/bin/$prog",@ARGV)."'";   }
    print STDERR "Unable to su to $db_user -- exiting \n";
    exit 0 ;
  }elsif (  (getpwnam($db_user))[2] !=3D $> ) { # im not duty  -- BAD
    print STDERR "You must be $db_user to run this script \n" ;
    exit 0 ;
  }

-------------------------------------------------------------------------=
------
Auto Background (perl 5)

  exit 0 if fork;         # basic background
  use POSIX qw(setsid);
  setsid();               # disassociate from terminal etc.


Extra Discussion...
Should he also run setgid(), and then either close filehandles 1-3 =
(stdin,
stdout, stderr)?

But we are not trying to turn the whole thing into a 'daemon' - we are
just trying to "background" it so that shell returns a prompt.
As such the 'setsid' is just a way to avoid having shell's SIGSTOP
etc. get in the way.

Truely disassociated GUI apps are very rare - most will die horribly
when window manager exits when user logs out.

-------------------------------------------------------------------------=
------
Date and Time conversion in perl

time --> date string
    #require "ctime.pl";   # perl 4 method (newline in ctime())
    use Time::localtime;

    $time =3D 999523563;
    $date =3D &ctime($time);
    $date =3D~ s/\s*\b[A-Z]{3}\b\s*/ /;  # remove timezone and any =
linefeed
    print $date, "\n";

time --> formated date
    $time =3D 999523563;
    @d =3D localtime($time);  # time as a 9 element array
    $d[4] ++;      # adjust month
    $d[5] +=3D 1900; # adjust year to 4 digits
    $date =3D sprintf( "%04d-%02d-%02d %02d:%02d:%02d", reverse @d[0..5] =
);


date --> time
    #repuire "timelocal.pl";  # perl 4
    use Time::Local;

    @d =3D ( 18, 9, 1998 );           # date =3D 18 September 1998
    $d[1] --;                       # adjust month to 0-11
    $d[2] -=3D 1900 if $d[2] > 1900;  # adjust year  2001 -> 101
    $time =3D timelocal( 0,0,0, @d ); # midnight on that day

time delta --> human readable string
    my($days,$hours,$mins,$secs);
    $secs =3D time - $^T;    # Time since the program started

    $days  =3D int ($secs/86400);  $secs %=3D 86400;
    $hours =3D int ($secs/3600);   $secs %=3D 3600;
    $mins  =3D int ($secs/60);     $secs %=3D 60;
    print "Program has been running for... ",
          $days  > 0 ? "$days days $hours:$mins" :
          $hours > 0 ? "$hours hrs $mins mins" :
          $mins  > 0 ? "$mins mins $secs secs" :
                       "only $secs seconds" ,
          "\n";

-------------------------------------------------------------------------=
------
Main Loop Count Down

# --- by data read from file ---

$PROGRESS =3D 1;

print STDERR "Main Processing Loop...\n" if PROGRESS;

# size of data for a processing count.
my $start_time =3D time;
my( $progress, $r ) =3D ('',''); # clear progress and reset line
my( $data_size, $read_size, $last_time );
if( $PROGRESS ) {
  $r =3D (' 'x79)."\r";  # clear the process line
  $data_size =3D -s $data;
  $read_size =3D 0;
  $last_time =3D 0;
}

open(DATA, "$data") || die("Unable to read \"$data\" : $!\n");

while( <DATA> ) {
  if( $PROGRESS ) {  # this should really be done in a continue block
    $read_size +=3D length;
    if ( $last_time !=3D time ) { # update once a second
      $last_time =3D time;
      my $run_time    =3D $last_time - $start_time;
      my $total_time  =3D $run_time * $data_size / $read_size;
      my $finish_time =3D $total_time - $run_time;
      $progress =3D
           sprintf( "%5.1f%% - %d:%02d:%02d since start".
                           " - %d:%02d:%02d left".
                           " - %d:%02d:%02d total".  "\r",
              100*$read_size/$data_size,
              $run_time    /3600, $run_time    /60%60, $run_time    %60,
              $finish_time /3600, $finish_time /60%60, $finish_time %60,
              $total_time  /3600, $total_time  /60%60, $total_time  %60,
            );
      print $r,$progress;
    }
  }
  #...
  print "${r}report some info\n";
  print $progress  if $PROGRESS;
  #...
}
print $r if $PROGRESS;
if( $PROGRESS ) {
  my $run_time =3D time - $start_time;
  printf "${r}Processed %d users in %d:%02d:%02d\n",
          $., $run_time /3600, $run_time /60%60, $run_time %60;
}

--- by number of iterations left ---

$PROGRESS =3D 1;

print STDERR "Main Processing Loop...\n" if PROGRESS;

my $start_time =3D time;
my( $progress, $r ) =3D ('',''); # clear progress and reset line
my( $loop_total, $loop_num, $last_time );
if( $PROGRESS ) {
  $r =3D (' 'x79)."\r";  # clear the process line
  $loop_total =3D @data;
  $loop_num   =3D 0;
  $last_time  =3D 0;
}

foreach ( @data ) {
  #...
  print "${r}report some info\n";
  print $progress  if $PROGRESS;
  #...
}
continue {
  if( $PROGRESS ) {
    $loop_num++;
    if ( $last_time !=3D time ) { # update once a second
      $last_time =3D time;
      my $run_time    =3D $last_time - $start_time;
      my $finish_time =3D $run_time * ($loop_total/$loop_num - 1);
      my $total_time  =3D $run_time + $finish_time;
      $progress =3D
           sprintf( "%5.1f%% - %d:%02d:%02d since start".
                           " - %d:%02d:%02d left".
                           " - %d:%02d:%02d total".  "\r",
              100*$loop_num/$loop_total,
              $run_time    /3600, $run_time    /60%60, $run_time    %60,
              $finish_time /3600, $finish_time /60%60, $finish_time %60,
              $total_time  /3600, $total_time  /60%60, $total_time  %60,
             );
       print $r,$progress;
    }
  }
}
if ( $PROGRESS ) {
  my $run_time =3D time - $start_time;
  printf "${r}Processed %d users in %d:%02d:%02d\n",
          $loop_total, $run_time /3600, $run_time /60%60, $run_time %60;
}

-------------------------------------------------------------------------=
------
sort methods and techniques

Case insenitive sorting
  sub case_insensitive  { "\U$a" cmp "\U$b"; }

Numerically
  sub numeric { $a <=3D> $b; }

Sort Associated array by value not key
  sub byvalue { $value{$a} <=3D> $value{$b} }
  foreach key ( sort byvalue keys %value ) {
    BODY;
  }

Sort by value then by by key
  sub val_key { $second{$a} <=3D> $second{$b} || $a  cmp $b }

Sort a hierarchal naming scheme -- Marc Horowitz <marc@MIT.EDU>
  IE: paths, newsgroups...
    sub depthfirst {
          $aa =3D $a."/~"; $aa =3D~ s|/|!|og;
          $bb =3D $b."/~"; $bb =3D~ s|/|!|og;
          $aa cmp $bb;
    }

Print associattive array by value (quickly)
  This will create a plain array with the value before the name
  then print the sort output. This is very fast.

    $mask =3D "%04d %s";
    for (@arr) { push (@idx, sprintf($mask, (/^\s+\((\d+)\)\s+(\S+)/))) =
}
    print @arr[ sort { $idx[$a] cmp $idx[$b]} 0 .. $#idx ];

  NOTE: in the above that you CAN sort without a function (directly)

Sorting by a computable field.
  The problem with sorting with a computable field is that you could
  end up computing the field at least 2 or more times in a sort =
function!
  The following using a map to extract and pre-compute the field, then
  sorts by that filed, and finally re-maps the original un-computed =
field.
  This is known as a ``Schwartzian Transform'' as it was popularised by
  Randel Schwartz.

  NOTE you start at the bottom line and work your way up.

    @sorted_fields =3D map  { $_->[1] }
                     sort { $a->[0] <=3D> $b->[0] }
                     map  { [ /(\d+)/, $_ ] }
                     @fields;
  Another example with password file...
    print map  { $_->[0] }            # print the original line
          sort { $a->[1] <=3D> $b->[1]  # my gid first
              || $a->[2] <=3D> $b->[2]  # then uid
              || $a->[3] cmp $b->[3]  # and by login  (should not =
be needed)
          }
          map  { [ $_, (split /:/)[3,2,0] ] }  # array: line then split =
fields
          `cat /etc/passwd`;                   # read password file

-------------------------------------------------------------------------=
------
Micro sleep.

  One method is to use the select() timeout
     select(undef,undef,undef,.01);

  You could also set an alarm... (see perl/functions/alarm.pl)


-------------------------------------------------------------------------=
------
Spliting a string with quotes...

EG: spiling a comma delimited file with quoted fields.
Example:
   SAR001,"","Cimetrix, Inc","Bob Smith","CAM","\"",N,8,,"Error, Core =
Dumped"

undef @fields;
push( @fields, defined($1) ? $1 : $3)
   while  m/"([^"\\]*(\\.[^"\\]*)*)"|([^,]+)/g;

WARNING the above does not seem to work under perl 5 -- Anthony

For space separated words such as for a shell command
EG:     cp -p "my file" "yourfile"
you can look at...
  perl4:  shellwords.pl library,
  perl5:  Text::ParseWords module

    perl -de 1
        use Text::ParseWords
        $line =3D 'cp -p "my file" "your file"'
        @words =3D shellwords $line
        X words
        @words =3D (
          0  'cp'
          1  '-p'
          2  'my file'
          3  'your file'
        )

Perl 4 Alturnatives...

Method 1:
    # delimit ','  with quoted strings and variable allowed
    $_ =3D 'f1,f 2,"f3","f,4",5,$time,f7';
    while (/,|"|$/go) {
      ($within =3D ($within ? 0 : 1), next) if '"' eq $&;
      next if $within;
      substr($_, 0, length($`)+1) =3D "";
      push(@fields, $`);
    }
    print join("    ", @fields),"\n";

  output
  f1    f 2    "f3"    "f,4"    5    $time    f7

Method 2:
  Just remove the delimiter ',' from within quotes
    s/("[^"]*")/do{$a =3D $1; $a =3D~ tr#,#c#; $a;}/ge;
  now you can split the line as you would normally

-------------------------------------------------------------------------=
------
Random selections from an array (shuffle)

  # create array of numbers to shuffle
  my($i, @number );
  for( $i=3D1; $i<=3D$NUMBER; $i++ ) {
    push(@number, $i);
  }
  print "number list =3D ", join(",", @number), "\n";


  # create the randomized array by removing elements from number list
  srand($$^time);           # randomize random number generator (if =
desired)
  while( @number > 0 ) {    # while we have a number to be picked
    push(@randomized, splice(@number, rand(@number), 1) ); # random pick
  }
  print "random list =3D ", join(",", @randomized), "\n";


  # shuffle array in place... (Perl Cookbook Recipe 4.17)
  # NOTE: requires a real array argument due to prototyping
  sub fisher_yates_shuffle(\@) {
    my $array =3D shift;
    my $i;
    for ($i =3D @$array; --$i; ) {
      my $j =3D int rand ($i+1);
      next if $i =3D=3D $j;
      @$array[$i,$j] =3D @$array[$j,$i];
    }
  }

  fisher_yates_shuffle @array;

-------------------------------------------------------------------------=
------
Incrementing a string using your own rules

Perl's auto-increment of strings is limited to specific strings
This method defins your own.

   inc($)   increase a single character  EG:  3 -> 4
   roll($)  roll a string a chars        EG:  9999 -> 0000

   while( <> ) {
     s/(.*)([0..8])([9]*)$/ $1 . inc($2) . roll($3) /e;
     print "$_\n";
   }

The first (.*) makes the RE work faster by ignoring start chars
WARNING:   99999  will not increment but  099999   will

-------------------------------------------------------------------------=
------
Format handling

   You can turn off page breaks the same way it does internally when it
notices the lack of a top-of-form format.  Just set $- to a huge number.
HOWEVER this will result in the top of form NEVER being printed.

Correct way is to let the first write happen then assign $- so it
can never reach zero again.

   select(FILEHANDLE);
   foreach i ( @array ) {
     ....;
     write;     # write top-of-form and the other lines
     $- =3D 99;   # form always has 99 lines left - never end page
   }

-------------------------------------------------------------------------=
------
tr and variables problem

  The tr command will not accept variables, the following is a
hack to allow this. This does not solve the delimiter problem however.

   eval "\$string =3D~ tr/$chars/$replacement_chars/";

-------------------------------------------------------------------------=
------
convert a bit vector into a list of intergers

$low =3D -1;
$high =3D -1;
$range_cnt =3D 0;
$printed =3D 0;
for $i (0..($bitmap_size-1)) {
    if (vec($bitmap_ptr, $i, 1) =3D=3D 1) {
        if ($low+$range_cnt =3D=3D $i) {
            $range_cnt++;
        } elsif ($range_cnt > 2) {
            print "..", ($low+$range_cnt-1), ", $i";
            $range_cnt =3D 1;
            $low =3D $i;
        } elsif ($range_cnt =3D=3D 2) {
            print ", " if $printed;
            print $low+1, ", $i";
            $printed =3D 1;
            $low =3D $i;
            $range_cnt =3D 1;
        } else {
            print ", " if $printed;
            print "$i";
            $printed =3D 1;
            $low =3D $i;
            $range_cnt =3D 1;
        }
        $high =3D $i;
    }
}
if ($high !=3D $low) {
    if ($range_cnt > 2) {
        print "..";
    } elsif ($range_cnt =3D=3D 2) {
         print ", " if $printed;
    }
    print "$high";
}
print "\n";
                        dgross@rchland.vnet.ibm.com (Dave Gross)

-------------------------------------------------------------------------=
------
Indirect function calls -- function ptrs

    sub foo() {
      print "foo( ", join(", ", @_), " )\n";
    }

    $function =3D "foo";             # function expression
    &$function( "arg1", "arg2" );  # indirect call

NOTE in version 4  $function can NOT be replaced with an expression
     though it can in version 5

-------------------------------------------------------------------------=
------
System call return checks

  Beware the $! is not reset by the call to system.  To be on the safe
side you should do:

    $! =3D 0;
    system('foo');
    die "$0: foo: $!\n" if $!;

Note that this only works if 'foo' is run without using /bin/sh.  If
/bin/sh is used to run the command then sh prints a message to stderr,
$! will not be set, and $? >> 8 is set to one.

-------------------------------------------------------------------------=
------
Set System Limits in perl...

=3D=3D=3D=3D=3D=3D=3D8<--------
require 'syscall.ph';
require 'sys/resource.ph'; # note h2ph doesn't always win on this one
                           # -- hand editing may be necessary

# Arrange so no core files are generated
$coresize =3D pack("i2",0,0);
syscall(&SYS_setrlimit, &RLIMIT_CORE, $coresize);

# Make stack size large
$stacksize =3D pack("i2",1024*1024*4,1024*1024*4);
syscall(&SYS_setrlimit, &RLIMIT_STACK, $stacksize);
=3D=3D=3D=3D=3D=3D=3D8<--------

-------------------------------------------------------------------------=
------
User Accounts and perl...

The following is dependant on the nsswitch and Solaris systems...

getpwent() and shadow password as root
  The  getpwent() function will return the users password  to root IF
     * users password in located in "/etc/passwd"  -- fat chance
     * user is listed in the /etc/shadow file and perl version is =
>5.005_57
     * it was called on the NIS+ server && user is in the NIS+ =
password file
       and you are authorized to see that password.

  Only in these cases will the  getpwent()  perl function return the =
users
  encrypted login password.  This is a real pain. Especially as perl =
does not
  have access to the system librarys shadow database getsd* functions.

getpwnam(user)
  The  getpwnam(user)  will never return the users password, but will =
let you
  know if this user is actually a valid login user of this machine. EG:
  user is in /etc/passwd or the appropriate netgroups access to the NIS+

Login Group restrictions...
  A user which can not login due to some login groups restrictions
  (EG: NetGroups under NIS,  or a LDAP authenticated login group)
  will NOT be listed by ANY of the getpw* functions.

  In other words a user which was disabled due to group access, may not =
be
  listed, dependant on the nsswitch settings (EG: "compact" setting
  or LDAP authenticated search restrictions)

  The alturnative is to always list all potential users (via nss), even =
if
  they are NOT in the right login group for this machine. Then if =
nessary,
  reject those with denied login by group access manually yourself.

  This however mean that unless your perl script is "pam" smart, it can =
NOT
  determine if a user still present in the password database, but is =
denied
  login access (via group), should have their home cleaned up and =
deleted
  without some other external indication of the users "final deletion".


-------------------------------------------------------------------------=
------
Randomise  srand()

Randomising the srand function can be very difficult.

The seed may not change quickly, or never change in a programs life =
time,
same have only have a limited number of start seeds (0 to 60,000 for =
process
ids).  And combineing them may still be limited.

Quick (limited) choices...
  * Current time (won't change within same `tick'           time()
  * Using the process id of the current process             $$
  * Time and process id                                     time() ^ $$
  * Using the process id of a sub-shell (always different)  `echo \$\$`


# randomise on gziped process list    ( from apatche 1.3.3 dbmmanage)
# WARNING process list generation could be slow! A major problem is that =
the
# ps options vary from machine to machine which results in the need for
# option checking making it even slower.  Also output does not change =
much
# as some parts giz archive start is a constant.
#
  sub randomise {
    my $psf;
    for (qw(-xlwwa -le)) {
        `ps $_ 2>/dev/null`;
        $psf =3D $_, last unless $?;
    }
    srand (unpack("%L*", `ps $psf | gzip -f`));
  }

# Use the `cksum' on the same source.
# this is faster but may not be availble on all systems.
#
  sub randomise {
    my $psf;
    for (qw(-xlwwa -le)) {
        `ps $_ 2>/dev/null`;   # test option
        $psf =3D $_, last unless $?;
    }
    srand ( `ps $psf | cksum` );
  }

NOTE perl5.005 automatically randomises the random number generator

-------------------------------------------------------------------------=
------
Password Encryption In perl
Specifically the `salt' key encryption

generally you would do something like...

Initialization...

  @salt_set =3D ('a'..'z', 'A'..'Z', '0'..'9', '.', '/');
  $salt_size =3D scalar @salt_set;  # should be 64 characters!


Method 1...

  # From Example in Perl 4 Camel Book
  # The salt for today is seleted by the traditional method
  sub gen_salt {
    my($passwd) =3D @_;
    my($perturb1,$perturb2,$week);

    # perturb the salt with start of input passwd
    ($perturb1,$perturb2) =3D unpack("C2", $passwd);
    $week =3D time() / (60*60*24*7) + $perturb1 + $perturb2;

    return(    $salt_set[ $week  % $salt_size ]
             . $salt_set[ time() % $salt_size ] );
  }

  crypt( $passwd, gen_salt($passwd) );


Method 2...
  # Extracted from dbmmanage in Apatche 1.3.3 distribution
  # randomise the salt for all strings.

  sub gen_salt {
    join('', map($salt_set[rand $salt_size], 1..2) );
  }

  crypt( $passwd, gen_salt() );


Other Techniques...

Generate a random password from $logname

  # 8 character randomised passwd
  # method: encrypt the logname then grab LAST 8 chars
  $passwd =3D substr(  crypt( $logname, gen_salt() ),  -8, 8 );

  # Substitute characters which could be misinterperted
  # EG: characters O0Q all look simular, and dot may be missed
  $passwd =3D~ tr|0OQ./+1Il^#;|XYZabc234rst|;


-------------------------------------------------------------------------=
------
Vgrind entry for perl programs
        PERL|perl|Perl:\
            :pb=3D^\d?(sub|package)\d\p\d:\
            :bb=3D{:be=3D}:cb=3D#:ce=3D$:sb=3D":se=3D\e":lb=3D':\
            :le=3D\e':tl:\
            :id=3D_:\
            :kw=3D\
            if for foreach unless until while continue else elsif \
            do eval require \
            die exit \
            defined delete reset \
            goto last redo next dump \
            local undef return  \
            write format  \
            sub package

NOTE: things like $#, $', s#/foo##, and $foo'bar confuse vgrind

-------------------------------------------------------------------------=
------
Suid Vulnerability (v5.002)

Suid Perlscripts using  suidperl  or  sperl  are insecure due to a race
condition on some systems. The program does not relinquish its root
privileges properly.

Patch available or get and install 5.003 or a C wrapper can be used.
  ftp://coombs.anu.edu.au/pub/perl/src/fixsperl-0

-------------------------------------------------------------------------=
------