Perl Getopt

use Getopt::Long;

perlhowto.com

#!/usr/bin/perl -w use strict; use warnings; no warnings 'uninitialized'; use Data::Dump qw(dump); my $PROGNAME = 'getopts-test'; my ( @REPOS, $ACTION, $config_record, $global_build ); use Getopt::Long; my $min_argv_nmbr = 1; if ( $#ARGV < $min_argv_nmbr) { usage() } GetOptions( 'repo|r=s' => \@REPOS, 'action|a=s' => \$ACTION, 'source|s:s' => \$config_record, 'build-global' => \$global_build, 'help|?|h' => \&usage, '<>' => \&usage, ) or usage(); #+++++++++++++++++++++++++++++++++++++++++++++++# sub usage { # #+++++++++++++++++++++++++++++++++++++++++++++++# =head2 usage usage =cut print "\nusage: $PROGNAME --action|-a ACTION --repo|-r REPOSITORY [--source|-s SOURCE] [--help|-?]\n\n"; exit; } #END usage print "REPOS " . dump( @REPOS ) . "\n"; print "ACTION $ACTION\n"; print "config_record $config_record\n"; print "global_build $global_build\n";

Perl HTTP

get website w authorization

tnx 2 darkspell.com

use LWP::UserAgent; $ua = new LWP::UserAgent; $req = new HTTP::Request GET => 'http://www.foo.bar/secret/'; $req->authorization_basic('aas', 'mypassword'); print $ua->request($req)->as_string;

Perl FTP

Net::FTP - read file content

tnx 2 daxim

use Net::FTP (); $ftp = Net::FTP->new( $ftp_hostname, Debug => 0, Passive => 1, Timeout => 1200, Bytes_read => $package_size, BlockSize => $package_size, ) or do { $err = "$config_record: ftp connection error on $ftp_hostname, user $ftp_user"; print "$err\n"; return (-1); }; $ftp->login( $ftp_user, $ftp_password ) or do { $err = "$config_record: login error on $ftp_hostname, user $ftp_user"; print "$err\n"; return (-1); }; open $FILEHANDLER, '>', \$content; $ftp->get( $filename, $FILEHANDLER) or warn "get failed $filename ", $ftp->message; #chomp $content; close $FILEHANDLER; print "$content\n"; $ftp->quit() or do { my $err = "$config_record: ftp disconnection error"; print "$err\n"; return (-1); };

Net::FTP::Throttle

use Net::FTP::Throttle; my $err; my $package_size = 4096; my $megabits_per_second = 0.5; $ftp = Net::FTP::Throttle->new( $ftp_hostname, Debug => 1, Passive => 1, Timeout => 1200, Bytes_read => $package_size, BlockSize => $package_size, MegabitsPerSecond => $megabits_per_second, ) or do { $err = "$config_record: ftp connection error on $ftp_hostname, user $ftp_user"; print "$err\n"; return (-1); };

Perl IO

simple file slurping

# pbp 213 open $FILEHANDLER, '<', $file; $file_content = do { local $/; <$FILEHANDLER> }; close $FILEHANDLER; @file_content = split /\n/,$file_content;

end of file (EOF)

open $FILEHANDLER, '<', $file or die "$!"; while (<$FILEHANDLER>) { if ( eof($FILEHANDLER) ) { } } close $FILEHANDLER;

Perl XML

tidy xml

tnx 2 dzone.com tnx 2 stackoverflow.com

use XML::Twig; $file = 'yjbm00564-0101a.nxml'; $twig= new XML::Twig; $twig->set_indent(" "x1); $twig->parsefile( $file ); $twig->set_pretty_print( 'indented' ); $XML = $twig->sprint; print $XML;

Perl Hashes

add key/value

%hash = ( key1 => 'value1', key2 => 'value2', key3 => 'value3', );

number of hash entries

$number_of_hash_keys = scalar ( keys %hash ); $number_of_hash_keys = keys %hash;

merge hashes

%target = (%target, %source); %newHash = (%hash1, %hash2); %hash1 = %newHash; @hash1{keys %hash2} = values %hash2;

array of hash keys

@key_array = keys %hash;

array of hash values

@values_array = values %hash;

loops

while ( ( $key, $value ) = each( %hash ) ) { print "$key : $value\n"; } foreach $key ( keys %hash ) { $value = $hash{ $key }; print "$key : $value\n"; }

sorting

sorting by Key

foreach $key ( sort keys %hash ) { $value = $hash{ $key }; print "$key : $value\n"; }

numerically sorting by Key

foreach (sort { $a <=> $b } keys(%hash) ) { print "key: $_ value: $hash{$_}\n" }

Clear (or empty) a hash

for (keys %hash) { delete $hash{$_}; }

Clear (or empty) a hash reference

for (keys %$href) { delete $href->{$_}; }

Matching hash keys to a regular expression

tnx 2 stackoverflow.com

Use the http://search.cpan.org/~rjbs/perl-5.16.2/pod/perlsyn.pod#Smart_matching_in_detail smart match operator (available since Perl v5.10). %h = ( 'twelve' => 12, 'thirteen' => 13, 'fourteen' => 14 ); print "We have some teens\n" if /.*teen$/ ~~ %h;

check if a hash is empty

tnx 2 stackoverflow.com

if ( !%hash ) { print 'Empty'; } perl < 5.8.5 : if( !keys %hash ) { print 'Empty'; }

hash of arrays (HoA)

$HoA{teletubbies} = [ "tinky winky", "dipsy", "laa-laa", "po" ]; for $family ( keys %HoA ) { print "$family: @{ $HoA{$family} }\n"; }

hash of hashes (HoH)

<h2>example 1</h2> #!/usr/bin/perl use Data::Dump qw(dump); # build HoH $HoH{'a'}{'1'} = 'A'; $HoH{'b'}{'2'} = 'B'; $HoH{'c'}{'2'} = 'C1'; $HoH{'c'}{'3'} = 'C2'; $HoH{'d'}{'3'} = 'D'; $node_record{ $parent_id }{ $tax_id } = $division_id; print "print dump\n"; print dump(\%HoH) . "\n"; @key_array = keys %HoH; print dump(@key_array) . "\n"; # print keys only print "\nprint keys only\n"; while ( ( $k1, $inner_hash ) = each %HoH ) { foreach $k2 ( keys %$inner_hash ) { print "$k1, $k2 \n"; } } # print all vars print "\nprint all vars\n"; while ( ( $k1, $inner_hash ) = each %HoH ) { while ( ( $k2, $val ) = each %$inner_hash ) { print "$k1, $k2, $val \n"; } } # print vars of a special k1 only print "\nprint vars of a special k1 only\n"; $k1 = "c"; foreach $k2 ( keys %{ $HoH{ $k1 } } ) { print "$k1, $k2, $HoH{ $k1 }{ $k2 } \n"; } <h2>example 1</h2> #!/usr/bin/perl use Data::Dump qw(dump); our $db_tablename_names = 'names_all' if (!($db_tablename_names)); our $db_tablename_parents = 'parents' if (!($db_tablename_parents)); my $data_basedir = '/tmp'; my %kingdoms = ( common => { domain_id => "1000000006000", id => "240000000000", kingdom_tax_id => "1", db => "species_common", db_tablename_names => "$db_tablename_names", db_tablename_parents => "$db_tablename_parents", obo_file_name => "$data_basedir/common/species_common.obo", }, plants => { domain_id => "1000000006001", id => "241000000000", kingdom_tax_id => "33090", db => "species_plants", db_tablename_names => "$db_tablename_names", db_tablename_parents => "$db_tablename_parents", obo_file_name => "$data_basedir/kingdoms/plants.obo", }, fungi => { domain_id => "1000000006002", id => "244000000000", kingdom_tax_id => "4751", db => "species_fungi", db_tablename_names => "$db_tablename_names", db_tablename_parents => "$db_tablename_parents", obo_file_name => "$data_basedir/kingdoms/fungi.obo", }, animals => { domain_id => "1000000006003", id => "247000000000", kingdom_tax_id => "33208", db => "species_animals", db_tablename_names => "$db_tablename_names", db_tablename_parents => "$db_tablename_parents", obo_file_name => "$data_basedir/kingdoms/animals.obo", }, ); my $kingdom = 'plants'; $kingdom_ids{ $kingdoms{$kingdom}{kingdom_tax_id} } = undef; $db_tablename_names_kingdom = $kingdoms{$kingdom}{db_tablename_names}; $db_tablename_parents_kingdom = $kingdoms{$kingdom}{db_tablename_parents}; print "print dumps\n"; print "\nprint vars\n"; print dump(\%kingdoms) . "\n"; print dump(\%kingdom_ids) . "\n"; print dump($db_tablename_names_kingdom) . "\n"; print dump($db_tablename_parents_kingdom ) . "\n"; # print keys only print "\nprint keys only\n"; foreach $kingdom ( keys %kingdoms ) { print "$kingdom\n"; } # print all kingdom dbs print "\nprint all kingdom dbs\n"; foreach $kingdom ( keys %kingdoms ) { print "$kingdoms{$kingdom}{db}\n"; }

Perl Arrays

number of array elements

$number_of_elements = @array; print scalar(@array);

fast search in a array

@a = (2, 3, 5,); undef %is_a; for (@a) { $is_a{$_} = 1 }; $b =2; if ( $is_a{ $b } ) { print "$b is in a\n" } else { print "$b not found\n" }

hash from array

@hash{@array} = undef;

string from array

$string = join "\n", @array;

unique array

@array = keys %{{ map { $_ => 1 } @array }}; @names = sort keys %{{ map { lc($_) => 1 } @names }};

sort

ASCII sort

@array = sort( @array ); @sorted_words = sort { lc($a) cmp lc($b) } @words;

numeric sort

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

array of hashes (AoH)

for $i ( 0 .. $#AoH ) { print "$i is { "; for $role ( keys %{ $AoH[$i] } ) { print "$role=$AoH[$i]{$role} "; } print "}\n"; } push @AoH, { husband => "fred", wife => "wilma", daughter => "pebbles" };

array of arrays (AoA)

tnx 2 perlhowto.com

@AoA = ( [ "one", "two", "three" ], [ 4, 5, 6, 7 ], [ "alpha", "beta" ] ); foreach $row (0..@AoA-1) { foreach $column (0..@{$AoA[$row]}-1) { print "Element [$row][$column] = $AoA[$row][$column]\n"; } }

Perl modules

play with modules

String::Similarity

zypper in http://download.opensuse.org/repositories/devel:/languages:/perl:/CPAN-S/openSUSE_12.3/i586/perl-String-Similarity-1.04-4.1.i586.rpm

Text::Similarity

zypper in http://download.opensuse.org/repositories/devel:/languages:/perl:/CPAN-T/openSUSE_12.3/noarch/perl-Text-Similarity-0.09-3.1.noarch.rpm

Algorithm::HowSimilar

zypper in http://download.opensuse.org/repositories/devel:/languages:/perl:/CPAN-A/openSUSE_12.2/noarch/perl-Algorithm-HowSimilar-0.01-4.1.noarch.rpm Problem: nothing provides perl = 5.16.0 needed by perl-Algorithm-HowSimilar-0.01-4.1.noarch Solution 1: do not install perl-Algorithm-HowSimilar-0.01-4.1.noarch Solution 2: break perl-Algorithm-HowSimilar-0.01-4.1.noarch by ignoring some of its dependencies perl -v This is perl 5, version 16, subversion 2 (v5.16.2) built for i586-linux-thread-multi cpan[1]> install Algorithm::HowSimilar

String::Approx

zypper in perl-String-Approx

WordNet::Similarity on opensuse (12.3)

zypper in wordnet /etc/bash.bashrc.local : # WordNet env if [ -e /usr/share/wordnet-3.0 ]; then export WNHOME=/usr/share/wordnet-3.0 fi cpan cpan[1]> install ExtUtils::MakeMaker cpan[1]> install WordNet::Similarity test fails, so we try it on hand : cd /root/.cpan/build/WordNet-Similarity-2.05-FMhcCS/ make make test # Failed test at t/trace.t line 141. known bug maybe, see https://rt.cpan.org/Public/Bug/Display.html?id=86437 well, lets try mv t/trace.t t/trace.t.bck make test make install checkinstall 1 - Summary: [ WordNet-Similarity-2.05 on opensuse 12.3 with skipped t/trace.t test ] 2 - Name: [ WordNet-Similarity ] 3 - Version: [ 2.05 ] 4 - Release: [ 1 ] 5 - License: [ GPL ] 6 - Group: [ Applications/System ] 7 - Architecture: [ i386 ] 8 - Source location: [ WordNet-Similarity-2.05-FMhcCS ] 9 - Alternate source location: [ ] 10 - Requires: [ ] 11 - Provides: [ WordNet-Similarity-2.05 ] rpm -qpl /usr/src/packages/RPMS/i386/WordNet-Similarity-2.05-1.i386.rpm

fix XML::XPath::Node::Attribute

no warnings qw( syntax deprecated);

Perl Mail

Net::SMTP

# we need: Authen::SASL use Net::SMTP; my $smtp_server = ""; my $smtp_server_account = ""; my $smtp_server_passwd = ""; my $smtp_from = ""; my $smtp_to = ""; my $smtp_cc = ""; my $smtp_bcc = ""; my $smtp_subject = ""; my $smtp_message = ""; my $smtp = Net::SMTP->new($smtp_server, Debug => 0); $smtp->auth($smtp_server_account, $smtp_server_passwd); $smtp->mail($smtp_from); $smtp->to($smtp_to); $smtp->cc($smtp_cc); $smtp->bcc($smtp_bcc); $smtp->data(); $smtp->datasend("From: $smtp_from\n"); $smtp->datasend("To: $smtp_to\n"); $smtp->datasend("Subject: $smtp_subject\n"); $smtp->datasend("\n"); $smtp->datasend("$smtp_message"); $smtp->dataend(); $smtp->quit;

Mail::Sender

# we need: Net::SMTP, Authen::SASL use Mail::Sender; $Mail::Sender::NO_X_MAILER = 1; $Mail::Sender::NO_MESSAGE_ID = 1; $Mail::Sender::SITE_HEADERS='X-Mailer: NONAME'; my $smtp_server = ''; my $smtp_server_account = ''; my $smtp_server_passwd = ''; my $smtp_from = ''; my $smtp_to = ''; my $smtp_cc = 'adr1,adr2'; my $smtp_bcc = ''; my $smtp_subject = 'foo'; my $smtp_message = "bar\n"; my $smtp_attach = '<file>'; open my $DEBUG, "> /tmp/Mail_Sender_debug.txt" or die "Can't open the debug file: $!\n"; my $smtp = new Mail::Sender { smtp => $smtp_server, from => $smtp_from, auth => 'LOGIN', authid => $smtp_server_account, authpwd => $smtp_server_passwd, on_errors => undef, debug => $DEBUG, } or die "Can't create the Mail::Sender object: $Mail::Sender::Error\n"; if ( -e "$smtp_attach" ) { $smtp->MailFile( { to => $smtp_to, cc => $smtp_cc, bcc => $smtp_bcc, subject => $smtp_subject, msg => $smtp_message, file => $smtp_attach } ) or print $Mail::Sender::Error; } else { $smtp->MailMsg( { to => $smtp_to, cc => $smtp_cc, bcc => $smtp_bcc, subject => $smtp_subject, msg => $smtp_message, } ) or print $Mail::Sender::Error; } $smtp->Close;

IO::Socket::SSL->start_SSL failed

tnx 2 Ether

IO::Socket::SSL->start_SSL failed: SSL connect attempt failed with unknown error error:14090086:SSL routines:SSL3_GET_SERVER_CERTIFICATE:certificate verify failed
################################################# # begin bugfix IO::Socket::SSL # # hint: install Crypt::SSLeay; # #+#use IO::Socket::SSL qw(debug3); use IO::Socket::SSL; use Net::SSLeay; BEGIN { IO::Socket::SSL::set_ctx_defaults( verify_mode => Net::SSLeay->VERIFY_PEER(), ca_file => "/usr/share/doc/packages/perl-Crypt-SSLeay/certs/ca-bundle.crt", ); } # end bugfix IO::Socket::SSL # ################################################# use Mail::Sender;

Perl SQL handling

get an unique array of values

$sth = $DBH->prepare(" SELECT Id FROM $DB_TABLENAME ;"); $sth->execute; @ids = map {$_->[0]} @{$sth->fetchall_arrayref}; @ids = keys %{{ map { $_ => 1 } @ids }}; @ids = sort( @ids );

get 1 var from dbi select

$var = $sth->fetchrow_array();

using a mysql temporary table

tnx 2 pal-blog.de

$sth = $dbh->prepare_cached('..', { mysql_use_result => 1}); This way the mysql server will return each row to the client as it finds it. Works wonders on large result sets!

mysql insert or update

INSERT INTO table ( bla ) VALUES ( ? ) ON DUPLICATE KEY UPDATE bla=VALUES(bla)

bulk operations

LOAD DATA LOCAL INFILE

# set mysql_local_infile=1 my $DBdsn = "DBI:$dbType:database=$dbDatabase;host=$dbHostname;mysql_local_infile=1"; $dbh = DBI->connect( $DBdsn, $dbUser, $dbPwd, { PrintError => 0, RaiseError => 1 } ) or die("DATABASE ERROR: $!");

DBI

DBI

(I)
my $sel = $dbh1->prepare("select foo, bar from table1"); $sel->execute; my $ins = $dbh2->prepare("insert into table2 (foo, bar) values (?,?)"); my $fetch_tuple_sub = sub { $sel->fetchrow_arrayref }; my @tuple_status; $rc = $ins->execute_for_fetch($fetch_tuple_sub, \@tuple_status); my @errors = grep { ref $_ } @tuple_status;

(II)
$sth = $dbh->prepare("INSERT INTO staff (first_name, last_name, dept) VALUES(?, ?, ?)"); $sth->bind_param_array(1, [ 'John', 'Mary', 'Tim' ]); $sth->bind_param_array(2, [ 'Booth', 'Todd', 'Robinson' ]); $sth->bind_param_array(3, "SALES"); # scalar will be reused for each row $sth->execute_array( { ArrayTupleStatus => \my @tuple_status } );

how do i insert values from a hash into a database

tnx 2 stackoverflow

my %hash = ( 1 => 'A', 2 => 'B', 0 => 'C', ); my @keys = keys %hash; my @values = values %hash; my $sth = $dbh->prepare("INSERT INTO table1(id, value) VALUES (?,?);"); $sth->execute_array({},\@keys, \@values);

example I

$sth = $DBH->prepare_cached(" INSERT INTO $db_table (srcId,directory,filename,changed_on,stateId,sha256) VALUES ($CONFIG{$config_record}{'src_id'},?,?,?,?,?) ON DUPLICATE KEY UPDATE srcId=$CONFIG{$config_record}{'src_id'}, directory=VALUES(directory), filename=VALUES(filename), changed_on=VALUES(changed_on), stateId=VALUES(stateId), sha256=VALUES(sha256) "); $sth->bind_param_array(1, \@dirnames); $sth->bind_param_array(2, \@filenames); $sth->bind_param_array(3, \@change_times); $sth->bind_param_array(4, \@states); $sth->bind_param_array(5, \@full_filename_shas); $sth->execute_array( { ArrayTupleStatus => \@tuple_status } );

example II

$sth = $dbh->prepare_cached(" UPDATE $db_tablename SET syno_ocId = syno_ocId + ?, domainId = domainId + ? WHERE syno_ocId = ? ;"); $sth->bind_param_array(1, $subtrees{$range}{syno_ocid_addend}); $sth->bind_param_array(2, $subtrees{$range}{domain_id_addend}); $sth->bind_param_array(3, \@range_ids); $sth->execute_array( { ArrayTupleStatus => \@tuple_status } );

using "WHERE ... in" with counter

foreach $id ( @ids ) { $counter++; $subset_counter++; $id_subset .= $id . ','; if ( ( $subset_counter == 1000 ) or ( $counter == $number_of_ids ) ) { chop $id_subset; $sth = $DBH->prepare_cached(" UPDATE $DB_TABLENAME SET active = $AC_DEACTIVATED rem = 'deactivated division' WHERE srcId = $srcid AND srcExtId in ( $id_subset ) ;"); $sth->execute(); $subset_counter = 0; $id_subset = undef; } }

bulk insert with AoA

tnx 2 Giuseppe Maxia

my @values = ( ["A", "B", "D", "0"], ["E", "F", "G", "1"], ["H", "I", "J", "2"], ["K", "L", "M", "3"], ["N", "O", "P", "4"], ["Q", "R", "S", "5"], ["T", "U", "V", "6"], ["W", "X", "Y", "7"], ); my $query = "INSERT INTO mytable VALUES \n" . join(",\n", ( map { "(". join ( ", ", map {$dbh->quote($_)} @$_). ")" } @values)); print "$query;\n";

select from big table with LIMIT

$default_count_limiter = 10000000; $count_of_records = 123456789; $number_of_laps = int($count_of_records/$default_count_limiter); $limiter = 0; print "default_count_limiter $default_count_limiter, count_of_records $count_of_records, number_of_laps $number_of_laps\n"; # $sth = $DBH->prepare(" ... LIMIT ?, ? ;"); for ( $lap = 0; $lap <= $number_of_laps; $lap++ ) { if ( $lap != $number_of_laps ) { $count_limiter = $default_count_limiter; } else { $count_limiter = $count_of_records; } print "lap $lap, limiter $limiter, count_limiter $count_limiter\n"; # $sth->execute( ..., $limiter, $count_limiter ); $limiter = $limiter + $count_limiter; }

perl strings

count the separator characters in a string

<a href='http://perlmeme.org/faqs/manipulating_text/count_separators.html' class="ext" target="_blank" onfocus="this.blur()" title="">tnx 2 perlmeme.org</a><p> DB<1> $name = 'Abdomen, Acute'; DB<2> $num = $name =~ tr/,//; DB<3> x $num; 0 1 <a href='http://www.perlmonks.org/?node_id=63955' class="ext" target="_blank" onfocus="this.blur()" title="">tnx 2 perlmonks.org</a><p> DB<4> $cnt = @{[$name =~ /(,)/g]}; DB<5> x $cnt 0 1

Build a subdir structure based on hex

$subdir = sprintf("%02x", rand(0xff) ) . '/' . sprintf("%02x", rand(0xff) );

Perl - threads / forks

use forks

#!/usr/bin/perl -w use strict; use warnings; use Benchmark; use forks; use forks::shared deadlock => {detect=> 1, resolve => 1}; use Thread::Semaphore; # threads / forks no warnings 'threads'; my $max_parallel_jobs = 2; my $semaphore = Thread::Semaphore->new( $max_parallel_jobs ); #+++++++++++++++++++++++++++++++++++++++++++++++# sub thread_control { # #+++++++++++++++++++++++++++++++++++++++++++++++# =head2 thread_control thread control function =cut my $bench_start = Benchmark->new; #$LOGGER->info("S T A R T"); my ( $static_var, @vars, $var, @todo, $counter, $funcref, $thread, $tid, @threads, ); #+++++++++++++++++++++++++++++++++++++++++++# #dbConnect(); #$sth = $DBH->prepare(" #;"); #$sth->execute(); #+++++++++++++++++++++++++++++++++++++++++++# $static_var = 'foo'; @vars = ( 'A','B','C','D','E' ); #+++++++++++++++++++++++++++++++++++++++++++# #while ( ( $var ) = $sth->fetchrow_array() ) { #} #+++++++++++++++++++++++++++++++++++++++++++# foreach $var ( @vars ) { push( @todo, [ \&thread_run, $static_var, $var ] ); } #+++++++++++++++++++++++++++++++++++++++++++# #$sth->finish(); #dbDisconnect(); #+++++++++++++++++++++++++++++++++++++++++++# $counter = 0; while ( $#todo >= 0 ) { $counter++; $semaphore->down(); ( $funcref, $static_var, $var ) = @{ shift(@todo) }; $thread = threads->create( $funcref, $counter, $static_var, $var ); $tid = $thread->tid; push @threads, $thread; } foreach ( @threads ) { $_->join; } my $bench_end = Benchmark->new; my $bench_time = timediff( $bench_end, $bench_start ); #$LOGGER->info(timestr( $bench_time, 'noc' ), "\n"); #$LOGGER->info("END"); return; } #END thread_control #+++++++++++++++++++++++++++++++++++++++++++++++# sub thread_run { # #+++++++++++++++++++++++++++++++++++++++++++++++# =head2 thread_run runs a single thread controled by thread_control() =cut my ( $counter, $static_var, $var ) = @_; my $bench_start = Benchmark->new; #$LOGGER->info("S T A R T thread no. $counter"); #+++++++++++++++++++++++++++++++++++++++++++# # thraed -safe sql connecting #my $DBdsn = "DBI:$DB_TYPE:database=$DB_DATABASE;host=$DB_HOSTNAME"; #my $dbh = DBI->connect( $DBdsn, $DB_USER, $DB_PWD, # { PrintError => 1, RaiseError => 1 } ) # or die("DATABASE ERROR: $!"); # $dbh->{'mysql_local_infile'} = 1; # $dbh->{'mysql_enable_utf8'} = 1; # $dbh->do('SET NAMES utf8'); # $dbh->do('SET group_concat_max_len = 4096'); # max : 67107840 #$sth = $dbh->prepare(" #"); #+++++++++++++++++++++++++++++++++++++++++++# print "S T A R T thread no. $counter : static_var $static_var, var $var\n"; sleep 5; #+++++++++++++++++++++++++++++++++++++++++++# #$sth->finish(); #$dbh->disconnect(); #+++++++++++++++++++++++++++++++++++++++++++# my $bench_end = Benchmark->new; my $bench_time = timediff( $bench_end, $bench_start ); #$LOGGER->info(timestr( $bench_time, 'noc' ), "\n"); #$LOGGER->info("END"); $semaphore->up(); return; } #END thread_run thread_control();

Perl Pidfile

PID 1

tnx 2 perl.beginners

use strict; use warnings; use File::Basename; BEGIN { our $program = basename $0; die "$program already running\n" if -f "/var/run/$program"; open my $pidfile, ">", "/var/run/$program" or die "could not open /var/run$program: $!"; print $pidfile "$$\n"; close $pidfile; } # make sure the last thing done is the removal of the pidfile # note: this happens even if we die END { our $program; unlink("/var/run/$program") or die "could not delete /var/run/$program"; } ### the rest of your code # As I have said (in fact it's said by Lincoln Stein), you should add a # "if" statement here to avoid the childs delete the pid file when # they're exiting. # if ( $$ == $pid ) { # $pid is parent's pid # unlink $pidfile or die $!; # }

PID 2

tnx 2 perlhowto.com

#!/usr/bin/perl -w use strict; use warnings; ( my $PROGNAME = $0 ) =~ s!^(?:.*/)?(.+?)(?:\.[^.]*)?$!$1!x; #! my $PIDFILE = "/tmp/$PROGNAME"; if ( -f $PIDFILE ) { my $exists = kill 0, `head -1 $PIDFILE`; if ( $exists ) { # prog is running die "$PROGNAME already running [ $PIDFILE exists ]\n"; } else { # rm $PIDFILE after crash unlink("$PIDFILE") or die "could not delete $PIDFILE\n"; } } open my $pidfile, ">", "$PIDFILE" or die "could not open $PIDFILE: $!"; print $pidfile "$$\n"; close $pidfile; # # code here :) # unlink("$PIDFILE") or die "could not delete $PIDFILE\n"; exit;

press any key to continue

#+++++++++++++++++++++++++++++++++++++++++++++++# sub ask_for_abort { # #+++++++++++++++++++++++++++++++++++++++++++++++# =head2 ask_for_abort wait for key, opportunity of break =cut my $argv = shift; if ( ( $ARGV[0] ) and ( "$ARGV[0]" eq "$argv" ) ) { print "\n"; print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n"; print "!!! !!!\n"; print "!!! DESTROYING THE UNIVERSE IN PROGRESS !!!\n"; print "!!! !!!\n"; print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n"; print "\npress any key to continue\n"; print "PRESS <CTRL>-<C> TO ABORT\n"; <STDIN>; print "!!! BOOM !!!\n"; } return; } #END ask_for_abort ask_for_abort('reset')

Perl Misc

run_as

print "$<\n"; print "$(\n"; my $run_as_user = 'user'; my $run_as_group = 'group'; my $uid = (getpwnam( $run_as_user ))[2]; my $gid = (getgrnam( $run_as_group ))[2]; print "uid: $uid\n"; print "gid: $gid\n"; $( = $) = "$gid $gid"; $< = $> = "$uid"; print "$<\n"; print "$(\n"; my $ID = `/usr/bin/id`; chomp $ID; print "$ID\n";

Perl Variables

line number that Perl is executing

( see perldata ) print "We're at ", __FILE__, ' line ', __LINE__, "\n";

caller()

<a href='http://perldoc.perl.org/functions/caller.html' class="ext" target="_blank" onfocus="this.blur()" title="">caller()</a> $line = (caller(0))[2];

perl -MFile::Find=find -MFile::Spec::Functions -Tlwe \ 'find { wanted => sub { print canonpath $_ if /\.pm\z/ }, no_chdir => 1 }, @INC'

funktion name

perl cookbook

$this_function = (caller(0))[3]; ($package, $filename, $line, $subr, $has_args, $wantarray )= caller($i); # 0 1 2 3 4 5

test if number of any kind

perlretut

^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$