Perl Notes

From Federal Burro of Information
Jump to navigationJump to search

Other scripts

What modules are installed?

So many ways of doing it.

ExtUtils::Installed

#!/usr/bin/perl

use ExtUtils::Installed;
my $instmod = ExtUtils::Installed->new();
foreach my $module ($instmod->modules()) {
my $version = $instmod->version($module) || "???";
       print "$module -- $version\n";
}

rpm

rpm -qa | grep ^perl

obviously only good for rpm based systems ( or system that use rpm). Also won't show modules install via CPAN.

perllocal.pod

perldoc -otext /home/david/lib/perl5/i386-linux-thread-multi/perllocal.pod  | grep Module

There may be more than one perl install on you computer. (locate perllocal.pod )

pmall

pmall from the pmtools package can do it for you.

http://search.cpan.org/~mlfisher/pmtools/pmall

Data::Dumper

One of the hackiest best debuging devy type modules .. dump a varaible no matter what type of variable it is. 

perldoc Data::Dumper

Od in perl

/dump.pl (useful if you have perl on windows but not coreutils)

CDB_File

We use cdbs all over the frikken place. But we are so smrt, we don't install the cdbdump command line tools or the perl module CDB_File all over the place. D'uh!

want to get to a cdb via perl? 

my $catref = tie %h, 'CDB_File', '/tmp/mydata.cdb' or die "tie failed: $!\n";
foreach my $server ( @{$catref->multi_get($ARGV[0])} ) {
 if ( $server =~ /[\d]{1,3}.[\d]{1,3}.[\d]{1,3}.[\d]{1,3}/ ) {
  print "server: $server is an ip\n";
 } esle {
  print "server: $server is name\n";
 }
}

As an aside, we also don't use cdbs the way they were designed in most cases. We have big hashes with keys that have the data we are looking for, rather than values that have the data we are looking for. Often we have duplicate keys, hence the crazy multi_get usage above.

non-root module install

       cd ~/src/Statistics-Descriptive-2.6
       perl Makefile.PL PREFIX=~
       make
       make test
       make install

How do I tell perl to use my own module library? 

       use lib "/tmp";

What is in my @INC? 

       % perl -e 'print join "\n", @INC'
       /usr/lib/perl5/5.00503/i386-linux
       /usr/lib/perl5/5.00503
       /usr/lib/perl5/site_perl/5.005/i386-linux
       /usr/lib/perl5/site_perl/5.005

Where does perl get it's @INC from ?

I think that @INC is compiled into libperl.so 

[user@server]$ strings /usr/bin/perl | grep lib
/lib/ld-linux.so.2
libperl.so
libnsl.so.1
libdl.so.2
libm.so.6
libpthread.so.0
libc.so.6
__libc_start_main
libcrypt.so.1
libutil.so.1
/usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE
Usage: DynaLoader::dl_unload_file(libref)
Usage: DynaLoader::dl_find_symbol(libhandle, symbolname)
[user@server]$ file /usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE
/usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE: directory
[user@server]$ locate libperl.so
/usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE/libperl.so
[user@server]$ strings /usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE/libperl.so | grep lib
libnsl.so.1
libdl.so.2
libm.so.6
libpthread.so.0
libc.so.6
libcrypt.so.1
libutil.so.1
/usr/lib/perl5/5.8.0
/usr/lib/perl5/site_perl
/usr/lib/perl5/vendor_perl
print "\nCharacteristics of this binary (from libperl): \n",
/usr/lib/perl5/5.8.0/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.0
/usr/lib/perl5/vendor_perl/5.8.0/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.0
/lib/
[user@server]$

Which module is perl using?

% perl -e 'use strict; print map {"$_ => $INC{$_}\n"} keys %INC'
  strict.pm => /usr/lib/perl5/5.00503/strict.pm

Casting

Don't be fooled into thinking that types don't matter in perl. Check this out:

I have a tables with id and name as coloumns. draggged it out of sql to a hash %priorities, where $priorities{$id} = $name;

We use CGI to make building html and forms easier. popup_menu needs a reference to an array of values and a reference to a hash of names (why not just take a hash, geesh). So in the code we see typically: 

$q = new CGI

%myhash  = make_hash();
@myarray = make_array(%myhash);

print "Form Fields",$q->popup_menu(-name=>"myfield",
                                -values=>\@myarray,
                                -labels=>\%myhash,
                                );

seems like one too many data structures to me... lets try and extract keys from hash as array inline: 

print "Priority ",$q->popup_menu(-name=>"priority",
                                -values=>keys(%priorities),
                                -labels=>\%priorities);

Doesn't work.. need a ref to an array, try again: 

print "Priority ",$q->popup_menu(-name=>"priority",
                                -values=>{keys(%priorities)},
                                -labels=>\%priorities);

This is sort of what I need, I get

  • 1 one
  • 3 three
  • 5 five

in my list of option. What happened to 2 4 6? Turns out the {} surrounding my keys "cast" the array from keys to a HASH!!! Ooops.

Once more with gusto: 

print "Priority ",$q->popup_menu(-name=>"priority",
                                -values=>[keys(%priorities)],
                                -labels=>\%priorities);

and I get back my "full" list of options:

  • 6 six
  • 4 four
  • 1 one
  • 2 two
  • 3 three
  • 5 five

however I'm not satified; the array is not sorted... so some more "inline" work: 

print "Priority ",$q->popup_menu(-name=>"priority",
                                -values=>[sort { $a <=> $b } keys %priorities],
                                -labels=>\%priorities);

Score!

Theredoc

from http://my.safaribooksonline.com/0596001738/perlbp-CHP-4-SECT-10?portal=oreilly 

   use Readonly;
   Readonly my $USAGE => <<'END_USAGE';
   Usage: qdump file [-full] [-o] [-beans]
   Options:
       -full  : produce a full dump
       -o     : dump in octal
       -beans : source is Java
   END_USAGE

and later... 

if ($usage_error) {
 warn $USAGE;
}

WHILE <> v <STDIN>

  1. <> will take arguments and STDIN
  2. <STDIN> is just be STDIN

Templating

a la sed 

cat header.cfg.template | perl -e 'while(<STDIN>){~s/\@\@funcationalunit\@\@/$ARGV[0]/g;~s/\@\@class\@\@/$ARGV[1]/g;print}' 3 job

note that the -p and -n from http://search.cpan.org/dist/perl/pod/perlrun.pod don't help as <> would be the file name passed as an option rather than STDIN.

or in less typing: 

$template =~ s/\@\@port\@\@/$port/g;

See /Perl Templating Example

Find replace in many files

perl -pi -e 's/about news\.$/about selling advertising space\./' file*

from: http://www.debian-administration.org/articles/298

serial number in zones files: 

perl -pi -e 's/2011042300/2011042301/' *

cgi options via command line

var/www/cgi-bin/mycgi.cgi jsoncallback=blah interval=300 s=uk

ParserDetails.ini

during some putzting around I got this meesage: 

could not find ParserDetails.ini in /usr/lib/perl5/site_perl/5.8.0/XML/SAX

I fixed it like this: 

touch /usr/lib/perl5/site_perl/5.8.0/XML/SAX/ParserDetails.ini
perl -MXML::SAX -e "XML::SAX->add_parser(q(XML::SAX::PurePerl))->save_parsers()"

as per : http://perl-xml.sourceforge.net/faq/

this gives: 

[XML::SAX::PurePerl]
http://xml.org/sax/features/namespaces = 1

I note that on rpmbuilder the file looks like this: 

[XML::SAX::PurePerl]
http://xml.org/sax/features/namespaces = 1

[XML::SAX::Expat]
http://xml.org/sax/features/namespaces = 1
http://xml.org/sax/features/external-general-entities = 1
http://xml.org/sax/features/external-parameter-entities = 1

It looks like this file is generated on install of XML perl libs. rpm -qf shows "not owned by any package."

More investigation needed?

stat, getting file information aka fstat

$strCreated = (stat("$strLockDir/$strLockFile"))[10];

dump that stat array with names:

SOMETHING IS WRONG WITH THIS use /usr/bin/stat instead. 

#!/usr/bin/perl -w

use strict;
use Data::Dumper;

my @keys = qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize block);

my @values  = stat('.');

print "Keys: ".$#keys."\n";
print "Values: ".$#values."\n";

my %stat_hash;

map {  $stat_hash{$keys[$_]} = $values[$_] } 0..$#values;

foreach ( keys ( %stat_hash ) ) {
    print $_."\t=>\t".$stat_hash{$_}."\n";
    if ( /time/ ) { print $_."\t=>\t".localtime($stat_hash{$_})."\n"; }
}

URPM

ripped from usr/lib/perl5/site_perl/5.8.0/ML/Package/Modules/Special.pm 

use URPM;

BEGIN {
$db || ($db = URPM::DB::open());
}

$db->traverse(
sub {
   my ($rpm) = @_;
   print $rpm->name()
   print $rpm->version()
   # .. and so on.
}

IO::Socket::INET and timeout

how to deal with timeouts: 

eval {
	local $SIG{ALRM} = sub { die 'Timed Out'; };
	alarm 3;
	my $sock = IO::Socket::INET->new(
		PeerAddr => inet_ntoa( gethostbyname($host) ),
		PeerPort => 'whois',
		Proto => 'tcp',
		## timeout => ,
	);
	$sock->autoflush;
	print $sock "$qry\015\012";
	undef $/; $data = <$sock>; $/ = "\n";
	alarm 0;
};
alarm 0; # race condition protection
return "Error: timeout." if ( $@ && $@ =~ /Timed Out/ );
return "Error: Eval corrupted: $@" if $@;

taken from : http://www.webmasterworld.com/forum13/3140.htm

IO::Socket::INET client server

spent some time pooring over recipes until I had glued enough recipes together to get what I wanted: good singnalling, error catching, resource usage , performance.

/IO::Socket::INET client server

Last $length elements in array

print @file[-$length .. -1];

also see Stupid_Shell_Tricks#Awk

Why perls is fun

WHY ???!

Tac in perl

useful for sorting things at that organized "backwards" , like mrtg targets. 

sub tac ($) {
        my @arr = split "" , shift;
        my $str ='';
        while ( my $c = pop @arr ) {
                $str .= $c;
        }
        return $str;
}

Do not try this at home , nor with string larger than say , 4 characters.

POD Documention snippets

=head2 sub myfunc(fish integer)

=over 2

Does some stuff, and stuff

=back

=cut

sub myfunc($) {
 some code
}

using map to loop over array

map {loggrab($unit, $server, $_)} @$rLogs;

for each @$rLogs
 loggrab($unit, $server, $_);

WTF, how does this work?

Profiling

Call profiling

collect some stats with Devel::DProf:

example: 

cd /tmp
perl -T -d:DProf /usr/local/bin/network-test.pl

dropes a file in . ( /tmp) called tmon.out which has profiling data.

examine the file with dprofpp 

dprofpp -u

note: no memory data.

Memory Profiling

use perl -D (debug) option.

example: 

perl -T -Dm /usr/local/bin/network-test.pl

allocation and freeing data is sent to STDERR.

Todo: write a script to parse this output to report on number of allocations , max allocation, etc.

CVS keywords of note

(my $version) = '$Revision: 1.16 $' =~ /([\d\.]+)/;

inline C

C Notes/ulimit ?

commify

adding commas to big numbers:

Flexible ( slow): 

sub commify($;$$) {
    my $text = reverse shift;
    my $pos = shift || 3;
    my $string = shift || ",";
    $text =~ s/(\d{$pos})(?=\d)(?!\d*\.)/$1$string/g;
    return scalar reverse $text;
}

fast ( rigid): 

sub commify {
 local $_ = shift;
 1 while s/^(-?\d+)(\d)/$1,$2/;
 return $_;
}

Your basic Ginsu

#!/usr/bin/perl -w

use strict;

while (<>){
        my $domain;
        my $pref;
        my $cluster ;
        if ( /(.+)a string (\d+)\s(.+)/ ) {
                print "one; ".$1."\n";
                print "two; ".$2."\n";
                print "three; ".$3."\n";
        }
        print '@@'.$_.'@@';
        print $domain."|| ".$pref."|| ".$cluster."\n";
}

Double nested ginsu

while(<>) {
 ...
 $urlref->{$name}->{$value}++;
}

foreach my $key ( sort keys %$urlref ) {
    print "Key $key\n";
    # print Dumper($urlref->{$key});
    foreach ( sort {$urlref->{$key}->{$a} <=> $urlref->{$key}->{$b} } keys %{$urlref->{$key}} ) {
        print "\t".$_." ".$urlref->{$key}->{$_}."\n";
    }
}

Parse Email Header

        my $last;
        my $received =0;
        foreach ( split ( "\n" , $rawheader ) ) {
                s/\r//g;
                if ( /(.*):\s(.*)/ ) {
                        my $name = $1;
                        my $value = $2;
                        if ( $name ne 'Received' ) {
                                $header->{$uuid}->{$name} = $value;
                        } else {
                                $header->{$uuid}->{$name.$received} .= " ".$value;
                                $last  = $name.$received;
                                $received++;
                        }
                } elsif ( /^\s+(.*)$/ ) {
                        next if ( ! $last );
                        $header->{$uuid}->{$last} .= $1;
                }
        }

Rounding

There's more than one way to skin a cat: 

perldoc POSIZ
/floor
"Largest whole number not greater than x"

All Class

bartest.pl 

#!/usr/bin/perl

use FrothyMug;
use Data::Dumper;

$mymug = new FrothyMug;
print Dumper($mymug);

FrothyMug.pm 

#!/usr/bin/perl

package FrothyMug;

sub new {
   my $class = shift;
   my $self = {};
   bless $self, $class;
   return $self;
}
return 1;

Regexp grep

get the miliseconds digits near the end of the line from STDIN 

perl -n -e 'if ( /(\d+) ms$/ ) { print $1."\n"; }'


Fun with Histograms

histo.pl 


#!/usr/local/bin/perl -w

# first col count
# second col value

use strict;
use Data::Dumper;

my %data;
my $max = 0;
my $width = 100;

while (<>) {
        chomp;
        # print "Line: ".$_."\n";
        my @tmp = split ( " " , $_ );
        if ( $tmp[0] > $max ) { $max = $tmp[0]; }

        # print Dumper(@tmp);
        if ( $tmp[1] > -1 ) {
                $data { $tmp[1] } = $tmp[0];
        }
}

# sort the keys numerically
for my $sendercount( sort {$a <=> $b} keys %data ) {
        # print "$sendercount => ".$data{ $sendercount }." ".$data{ $sendercount }/$max*$width."\n";
        printf "%4d %6d %s\n", $sendercount, $data{ $sendercount }, "*" x int ( $data{ $sendercount }/$max*$width ) ;
}

simplehisto.pl 

#!/usr/bin/perl -w
# take a sinple coloumn and draws a horizontal ascii graph
use strict;
use Data::Dumper;

my %data;
my $max = 0;
my $width = 100;
#my $string = FALSE;

while (<>) {
        chomp;
        my @tmp = split ( " " , $_ );
        #if ( $tmp[0] > $max ) { $max = $tmp[0]; }
        if ( $tmp[0] > -1 ) { $data { $tmp[0] } ++; }
        #if ( $tmp[0] =~ /^-?\d/) { $string = TRUE; }
}

my @sorted = sort { $a <=> $b } keys %data;

foreach my $value ( @sorted ) {
        if ( $data{$value} > $max ) { $max = $data{$value} } ;
}
foreach my $value ( @sorted ) {
        printf "%4d %6d %4d %s\n", $value, $data{$value},  $data{ $value }/$max*$width, "*" x int ( $data{ $value }/$max*$width ) ;
}

From script to one line

Uncommon but Useful Perl Command Line Options for One-liners http://bit.ly/ravN5c 


#!/usr/bin/perl -w

use strict;

while (<>) {
        #data
        # DL Name,dl@domain.com,user,user@domain.com
        #comand
        # zmprov cdl needlepoint-list@domain.com displayName "displayname"
        my @stuff = split /,/;
        print "cdl ".$stuff[1]." displayName \"" . $stuff[0] . "\"\n";
}

gets turned into: 

cat dl.start | perl -a -F/,/ -n -e ' print "cdl ".$F[1]." displayName \"" . $F[0] . "\"\n";' | sort | uniq | zmprov

-a for auto split
-F to make split split on /X/
-n to loop with no print
-e for the code to insert

pulling ips from a file: 

yum install perl-Regexp-Common.noarch
perl -ane 'INIT  {use Regexp::Common qw /net/; } ' -e 'foreach(@F) { print $_ , "\n" if $_ =~ /$RE{net}{IPv4}/ }' /var/log/maillog | more

Net::SNMP Notes

To translate or not to translate, haven't mastered this yet

turn off all translation: 

$session->translate(Net::SNMP->TRANSLATE_NONE);

Conditional Operators

http://docstore.mik.ua/orelly/perl/prog3/ch03_16.htm 

if then else

(if this) ? (then this) : (else this) ;

Nagios Log aka log with a timestampe at the beginning

looks like this: 

[EPOCH] MESSAGE

use this to get human data: 

cat logfile | perl -a -n -F/\s/ -e 'print localtime(substr($F[0],1,10))." ".$_'

or: 

cat logfile | perl -pe 's/(\d+)/localtime($1)/e'

Nmap Parser

    my $np = new Nmap::Parser;
    my $nmap_path = "/usr/bin/nmap";
    my $nmap_args = "-P0 -A";
    $np->parsescan($nmap_path, $nmap_args, ($ip));
    my $session = $np->get_session();
    print "Session start: ".$session->start_str()."\n";
    print "Session End:  ".$session->time_str()."\n";
    my $host       = $np->get_host($ip);
    print "Host $ip status : ".$host->status()."\n";

    if ( $host->status() eq "up" ) {
        print "Host is up / checking OS\n";
        my $os         = $host->os_sig();
        if ( $os ) {
            print "Got OS\n";
            # print Dumper($os);
            print $os->all_name();
        } else {
            print "Failed to get os\n";
        }
        #if ( $os->name )     { print $os->name."\n"; }
        #if ( $os->osfamily ) { print $os->osfamily."\n"; }
    } else {
        print "Host $ip is not up (".$host->status().")\n";
    }

Save an env to a file for later sourcing

printenv -0 | perl -a -0 -n -e '( $name, $value) = split(/=/, $_, 2 ); printf("export %s='\%s'\\n", $name, $value)' > /vol/env/somefile.env
          ^ null RS    ^ split on null

Can handle multi-line env vars.

Retrieved from "https://wiki.quadratic.net/index.php?title=Perl_Notes&oldid=5507"