Perl

From Torben's Wiki

Links

Template

#!/usr/bin/env perl
# old: !/usr/bin/perl

use strict;
use warnings;

# DESCRIPTION
# My Perl Template
# by Torben Menke https://entorb.net
our $VERSION = '2020-01-24';

# TODO

# IDEAS

# DONE

# Modules: My Default Set
use 5.010;                      # say
use utf8;                       # this script is written in UTF-8
use autodie qw (open close);    # Replace functions with ones that succeed or die: e.g. close
# use Data::Dumper;
# use Time::HiRes( 'time' );    # -> time() -> float of seconds

# pp -u -M Excel::Writer::XLSX -o script.exe script.pl & copy script.exe c:\tmp

# Modules: Perl Standard
use Encode qw(encode decode);
# use open ':encoding(UTF-8)';    # default encoding for all files, not working for open( my $fhIn, '<', $fileIn )
# default encoding for print STDOUT
if ( $^O eq 'MSWin32' ) {
  binmode( STDOUT, ':encoding(cp850)' );
} else {
  binmode( STDOUT, ':encoding(UTF-8)' );
}

# Modules: File Access
use File::Basename;    # for basename, dirname, fileparse
# use File::Path qw(make_path remove_tree);

# Modules: CPAN
# use LWP::UserAgent; # http requests
# use Excel::Writer::XLSX;
# perl -MCPAN -e "install Excel::Writer::XLSX"

# Start

my $s = "äöüß";
say $s;

my $fileIn = "data.txt";
open my $fhIn, '<:encoding(UTF-8)', $fileIn or die "ERROR: Can't read from file '$fileIn': $!";
# 1. as array
my @cont = <$fhIn>;
# 2. as string, via slurp
my $cont = do { local $/ = undef; <$fhIn> };
# 3. row by row
while ( my $row = <$fhIn> ) {
  chomp $row;
  print "$row\n";
}
close $fhIn;

my ( $fname, $fdir, $fext ) = fileparse( $fileIn, qr/[.][^.]*/ );
my $fileOut = "$fdir/$fname-report$fext";
open my $fhOut, '>:encoding(UTF-8)', $fileOut or die "ERROR: Can't write to file '$fileOut': $!";
print { $fhOut } $s;
close $fhOut;

Basics

Strings

SubString and Length 

say length ($s);
$s = substr( $s, 0, length( $s ) - 2 );    # remove last 2 char

Arrays

split and join 

my @L = split /b/, 'abc';
my $s = join '-', @L;

remove item from array 

my $i = 2;
splice @L, $i, 1;    # remove 1 item at position $i

min/max 

use List::Util qw( min max ); 
use List::MoreUtils qw( minmax ); # performanter than List::Util if both are desired

Check if element in list/array, see [1] for many more solutions the this 

my $thing = "asdf";
if ( not grep { $thing eq $_ } @L ) {
  say "$thing is not in list @L";
}

or 

if (grep  {$cgi->param( 'dateresolution' ) eq $_ } qw (all year quarter month) ) {
  $dateresolution = $cgi->param( 'dateresolution' );
}

Fill Array with 0 

@L = (0) x (100); # 100 times -> last one is $L[99]
Sort

Reverse (sort) list / array 

@list = reverse @list;

Sort numerically 

@list = sort {$a <=> $b} @list;

Sort alphabetically 

@list = sort {$a cmp $b} @list;

Sort by substring 

@list = sort {
  my ( $aa, $bb ) = ( $a, $b );
  # remove 'ID,' for comparison
  $aa =~ s/^\d+,//;
  $bb =~ s/^\d+,//;
  $aa cmp $bb;
} @list ;
Sorting Hashes
my %h;
# by values, reverse
foreach my $k ( sort { $h{ $b } <=> $h{ $a } } keys %h ) {
  # last if $h{$k}==1;
  say "$h{$k}\t$k";
}

# by keys
foreach my $k ( sort keys %h ) {
  say "$k\t$h{$k}";
}
Sorting an Array of Hashes

Sort array of hashrefs by a certain hash key 

my @sorted = sort {
  my ( $aRef, $bRef ) = ( $a, $b );
  my %aHash = %{ $aRef };
  my %bHash = %{ $bRef };
  $aHash{ 'moving_time' } <=> $bHash{ 'moving_time' };
} @list;

Math

rounding: 

my $float = 12.345;
$float = 0 + sprintf '%.1f', $float;

integer rounding from [2] 

sub round {
  my ( $f ) = @_;
  return int( $f + $f / abs( $f * 2 || 1 ) );
}

defined/undef

my $var;
my @L;
my %h;
if ( not defined $var )        { say 'Var is undef'; }
if ( not %h )                  { say 'Hash is empty'; }
if ( not exists $h{ 'key' } ) { say "Hash has no key 'key'"; }
if ( not defined $h{ 'key' } ) { say "Hash key 'key' has undefined value"; }
# shorter:
say defined $var ? 'DEFINED' : 'NOT';

Undefine/delete 

undef $var; # equals $var = undef;
undef @L; # equals @L = ()
undef $L[ 2 ]; # or $L[ 2 ] = undef;
splice @L, 2, 1;    # remove 1 item at position 2
undef %h; # equals %h = ()
undef $h{ 'key' }; # or $h{ 'key' } = undef;
delete $h{ 'key' }; # removes both: key and value

Regular Expressions

Look Ahead 

s/String.*(?=\n)//sg;

Look Behind 

s/(?<=\n)String.*//sg;

Use ! for negative look behind / backs

Timing

use Time::HiRes( 'time' );    # -> time() -> float of seconds
my $tsStart = time;
# ...
say sprintf "%.1fs after performing XYZ", ( time - $tsStart );

Date

V1 

# TimeStamp -> String
my $datestr;
@_ = localtime time;
# ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
$datestr = sprintf "%04d-%02d-%02d_%02d-%02d-%02d\n", $_[ 5 ] + 1900, $_[ 4 ] + 1, $_[ 3 ], $_[ 2 ], $_[ 1 ], $_[ 0 ];
# DE Format
@_ = localtime time;
$datestr = sprintf "%02d.%02d.%04d %02d:%02d:%02d", $_[ 3 ], $_[ 4 ] + 1, $_[ 5 ] + 1900, $_[ 2 ], $_[ 1 ], $_[ 0 ];

# String -> TimeStamp
use Time::Local;
my $timestamp = timelocal( $sek, $min, $h, $d, $m - 1, $y - 1900 );

sub convertTimeStamp2Date {
  my ( $ts ) = @_;
  @_ = localtime $ts;
  # ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
  my $datestr = sprintf "%02d.%02d.%04d", $_[ 3 ], $_[ 4 ] + 1, $_[ 5 ] + 1900;
  return $datestr;
}

V2 

use DateTime;

sub reformatDate {
  # 01/Nov/2012:19:17:55 -0700 -> CET Timezone
  my ( $in ) = @_;

  $in =~ m/^(\d{2})\/([a-z]{2,3})\/(\d{4}):(\d{2}):(\d{2}):(\d{2}) ([+\-]?\d{4})/i or die " E: date strange;";
  my ( $d, $m, $y, $h, $min, $s, $tzoffset ) = ( $1, $2, $3, $4, $5, $6, $7 );

  my %mo = (
    'Jan' => '01',
    'Feb' => '02',
    'Mar' => '03',
    'Apr' => '04',
    'May' => '05',
    'Jun' => '06',
    'Jul' => '07',
    'Aug' => '08',
    'Sep' => '09',
    'Oct' => '10',
    'Nov' => '11',
    'Dec' => '12'
  );
  $m = $mo{ $m };

  my $dt = DateTime->new(
    year      => $y,
    month     => $m,
    day       => $d,
    hour      => $h,
    minute    => $min,
    second    => $s,
    time_zone => 'America/Los_Angeles'
  );
  $dt->set_time_zone( 'Europe/Berlin' );

  my $dateStr = sprintf "%4d-%02d-%02d_%02d:%02d:%02d", $dt->year(), $dt->month(), $dt->day(), $dt->hour(), $dt->minute(), $dt->second();
  return $dateStr;
}

handling of iso8601 date format

use Date::Parse;

my $datestr = "2021-05-14T09:22:21Z"; # iso8601 format
say $datestr;
# my ($ss,$mm,$hh,$day,$month,$year,$zone) = strptime($date);
my $ts= str2time($datestr);

use DateTime;
# my $dt = DateTime->now()->iso8601().'Z';
my $dt = DateTime->from_epoch( epoch => $ts+10);
say $dt->iso8601().'Z';

convert week and year -> date

use Date::Tie;
tie my %dt, 'Date::Tie', year => 2018, week => 30, weekday => 5;
say "$dt{day}.$dt{month}.$dt{year}";
say $dt{epoch}; # TimeStamp

Multidim Lists / References

Hash of hashes / multidim hast 

my %hash;
$hash{$status}{"Count"}{$knowMsg}++;
...
foreach my $knowMsg (keys (%{$hash{$status}{"Count"}})) { ... }
...
my $count = 0;
$count = $hash{$status}{"Count"}{$knowMsg} if exists ($hash{$status}{"Count"}{$knowMsg});

Creation 

$scalarref = \$foo; 
$arrayref  = \@ARGV; 
$hashref   = \%ENV; 
$coderef   = \&handler; 
$globref   = \*foo;

Modification 

$hashref->{'key'} = 'value';

Readout / copying 

@list = @{ $hash{ $keyx } };
# General: 
$s = ${ $scalarref };
@L = @{ $arrayref };
%h = %{ $hashref };

anonymous list: [ ... ] 

$arrayref = [ 1, 2, 'a', 'b', 'c' ];
# $arrayref -> [2] == 'a' 
$arrayref = [ 1, 2, [ 'a', 'b', 'c' ] ]; 
# $arrayref -> [2][1] == 'b'

anonymous hash: { ... } 

$hashref = { 
  'Adam'  => 'Eve', 
  'Clyde' => 'Bonnie', 
};

Save an array inside a hash: 

$hash{ $keyx } = \@list;

see perlref.html


Remove Row and Column from Symmetric Matrix

sub removeRowColFromMatrix {
  # removes row $i and col $i from symmetric matrix
  # in: $i, ref to @matrix
  # out: nothing, since working on ref to matrix
  my ( $i, $refMatrix ) = @_;
  # remove row $i
  splice @{ $refMatrix }, $i, 1;
  # remove col $i
  foreach my $row ( @{ $refMatrix } ) {
    next unless defined $row;
    my @L = @{ $row };
    next if ( $#L < $i );
    splice @L, $i, 1;
    $row = \@L;
  }
  return;
}

sub removeRowsColsFromMatrix {
  # removes multiple rows and columns from symmetric matrix
  # first the rows are removed (=fast), than columns are removed (=slow) from the remaining rows
  # $refIndicesToRemove MUST BE ORDERD DESC!!!
  # in: $refIndicesToRemove, $refMatrix
  # out: nothing, since working on ref to matrix
  my ( $refIndicesToRemove, $refMatrix ) = @_;
  foreach my $i ( @{ $refIndicesToRemove } ) {
    # remove row $i
    splice @{ $refMatrix }, $i, 1;
  }
  # remove col $i
  foreach my $i ( @{ $refIndicesToRemove } ) {
    foreach my $row ( @{ $refMatrix } ) {
      next unless defined $row;
      my @L = @{ $row };
      next if ( $#L < $i );
      splice @L, $i, 1;
      $row = \@L;
    }
  }
  return;
}

my @matrix = ( [ 'q', 'w', 'e', 'r', 't' ], [ 'q', 'w', 'e', 'r', 't' ], [ 'q', 'w', 'e', 'r', 't' ], [ 'a', 's', 'd', 'f', 'g' ], [ 'q', 'w', 'e', 'r', 't' ] );

removeRowColFromMatrix( 3, \@matrix );
print "@matrix";

@_ = ( 2, 4 );
removeRowsColsFromMatrix( \@_, \@matrix );
print "@matrix";

Store/read hash to/from file

from [3] 

use Storable;
store \%table, 'file';
my $hashref = retrieve( 'file' );
my %hash    = %{ retrieve( 'file' ) };    # retrieve hash instead of hashref

Column-wise sum of arrays

from [4] 

my @A2sum = ( 
  [ 1, 0, 0, 0, 1 ], 
  [ 1, 1, 0, 1, 1 ], 
  [ 2, 0, 2, 1, 0 ] 
  );
my @sums;
foreach my $column ( 0 .. $#{ $A2sum[ 0 ] } ) {
  my $sum;
  foreach my $aref ( @A2sum ) {
    $sum += $aref->[ $column ];
  }
  push @sums, $sum;
}

Transpose Matrix

my @rows       = ();
my @transposed = ();

# This is each row in your table
push @rows, [ qw(0 1 2 3 4 5 6 7 8 9 10) ];
push @rows, [ qw(6 7 3 6 9 3 1 5 2 4 6) ];

for my $row ( @rows ) {
  for my $column ( 0 .. $#{ $row } ) {
    push @{ $transposed[ $column ] }, $row->[ $column ];
  }
}

[5]

Array Minus / Delta / Difference

V2: unique lists -> remove hits from hash to speed up checks

sub arrayMinus {
  # use @diff = arrayMinus(\@array1, \@array2)
  # returns A MINUS B
  my ( $refA, $refB ) = @_;
  my @A = @{ $refA };
  my @B = @{ $refB };
  # TODO: %hB reduzieren nach jeder Prüfung
  my %hB = map { $_ => 1 } @B;
  # my @diff = grep {not $hB{$_}} @A;
  my @diff;
  foreach my $item ( @A ) {
    if ( not exists $hB{ $item } ) {
      push @diff, $item;
    } else {
      delete $hB{ $item };    # remove item from hash for speeding up checks
    }
  }
  return @diff;
}

V1: simple

sub arrayMinus {
  # use @diff = arrayMinus(\@array1, \@array2)
  # returns A MINUS B
  my ( $refA, $refB ) = @_;
  my @A    = @{ $refA };
  my @B    = @{ $refB };
  my %hB   = map { $_ => 1 } @B;
  my @diff = grep { not $hB{ $_ } } @A;
  return @diff;
}
my @diff = arrayMinus( \@array1, \@array2 )

ANSIColor: Colorful Terminal Output

ANSIColor 

use Term::ANSIColor;
print color 'bold blue';
print "This text is bold blue.\n";
print color 'reset';

Encoding

For console output in Windows 

use utf8;     #this script is written in UTF-8
use Encode qw(encode decode);
my $encodingSTDOUT = 'CP850';            # Windows/DOS: 'CP850'; Linux: UTF-8
my $s              = 'ÄÖÜäöüß';
print encode ( $encodingSTDOUT, $s );

for files 

open( OUT, ">", "join.csv" );
binmode( OUT, ":UTF-8" );
binmode( OUT, ":encoding(Latin1)" );

or for all files 

use open ":encoding(Latin1)";

When using pp to compile executeable files (.exe) the following flag is required: 

pp ... -M PerlIO::encoding ...

On utf8, UTF-8 and their differences see [6] 

# Using UTF-8 (in any case and with either a hyphen or underscore) is the strict, valid encoding and gives a warning for invalid sequences.

After correct decoding regular expression \w matches word chars like 'äöüß'.

Guess Encoding

[7] 

use Encode::Guess qw/utf8 latin1 UTF-8/;
my $decoder = guess_encoding( $data, 'UTF-8' );
$decoder = guess_encoding( $data, 'iso-8859-1' ) unless ref $decoder;
die $decoder unless ref $decoder;
printf "Decoding as %s\n\n", $decoder->name;
$data = $decoder->decode( $data );

File-Access

chdir to dir of perl file 

chdir dirname( __FILE__ );

Template/Snipping

see top of this page

Handling path, name, extension

use File::Basename;
use File::Path qw(make_path remove_tree);
my $file = '/tmp/asdf.txt';
my ( $fname, $fdir, $fext ) = fileparse( $file, qr/\.[^.]*/ );
$fext = "\L$fext";    # lower ext.
my $fileOut = $fdir . 'backup/' . $fname . $fext;

make dir including full path/tree 

$_ = dirname( $fileOut );
make_path $_ unless -d $_;

remove path/tree recursivly 

remove_tree (dirname( $fileOut ));

Copy

use File::Copy;
copy($source, $target);

Filesize

my $size = -s $file;

or 

my $size = (stat($file))[7]

or 

my ($device, $inode, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime,
  $ctime, $blksize, $blocks) = stat($file);

Check OS

my $os;
if    ( $^O eq 'MSWin32' ) { $os = 'win'; }
elsif ( $^O eq 'linux' )   { $os = 'lin'; }
else                       { die "unknown OS: $^O\n"; }

Recursive file Access V2 / traverse

from [8] 

my $path = shift || '.';
traverse( $path );

sub traverse {
  my @queue = @_;
  while ( @queue ) {
    my $thing = shift @queue;
    if ( -f $thing and $thing =~ m/\.jpe?g$/i ) {
      say $thing;
      # doSomething ($thing );
    }
    next if not -d $thing;
    opendir my $dh, $thing or die;
    while ( my $sub = readdir $dh ) {
      next if $sub eq '.' or $sub eq '..';
      push @queue, "$thing/$sub";
    }
    closedir $dh;
  }
  return;
}

Recursive file Access V1

from [9] Delete old files of ext .log in folder if file is older than 365 days 

use Modern::Perl;
use Path::Class;
my @dirs = grep {-d} <*>;
foreach ( @dirs ) {
  my $dir = dir( $_ );
  $dir->traverse(
    sub {     # Path::Class::Dir allows to dive / traverse into all children
      my ( $child, $cont ) = @_;
      if ( not $child->is_dir and $child->stat ) {    # not is_dir -> file
        if ( $child =~ m/\.log$/i ) {                 # filter on file name / ext
          if ( $child->stat->mtime < ( time - 365 * 86400 ) ) {
            say "$child could be deleted";            # to delete
                                                      # unlink $child;
          } else {
            # say $child . " : " . sprintf( "%.2f", ( time - $child->stat->ctime ) / 86400 ) . " days";
          }
        }    # filename match
      }                    # is a file
      return $cont->();    # returns children for iteration
    }
  );
}

Compile Perl to .exe (Windows)

short answer: 

perl -MCPAN -e "install PAR::Packer" 
pp -o script.exe script.pl
# include mudules via -M or -a
pp -M String::Similarity -a "../lib/TM/TestModuleMath.pm" -o script.exe script.pl

Error "Can't locate utf8_heavy.pl": If UTF-8 is used set 

pp -u ...

DLL libexpat-1__.dll missing 

pp -l "libexpat-1__.dll"

Zip files

use IO::Compress::Zip qw(zip $ZipError) ;
my $pathToZip = "Activities.zip";
my @jsonFiles = </activityList/*.json>;
zip 
 \@jsonFiles => $pathToZip
 , FilterName => sub { s<.*[/\\]><> } # trim path -> filename only
 , TextFlag => 1 # It is used to signal that the data stored in the zip file/buffer is probably text.
 , CanonicalName => 1 # This option controls whether the filename field in the zip header is normalized into Unix format before being written to the zip file.
 , ZipComment  => "Created by Torben" # comment, just for fun
 , Level => 7 # [0..9], 0=none, 9=best compression
 or die "zip failed: $ZipError\n";

or 

use Archive::Zip;
my $zip = Archive::Zip->new();
$zip->addTree( '.' );
$zip->writeToFileNamed( '../slide1.zip' );


Unzip

use Archive::Extract;
my $ae = Archive::Extract->new( archive => $fileZip );
my $ok = $ae->extract( to => $dirOut );
if ( not $ok == 1 ) {
  die "E: $fileZip not unzipped ";
}

Sendmail

sub send_mail {
  # in: $subject, $body, $to_address
  # out: nothing
  # send an email
  my ( $subject, $body, $to_address ) = @_;
  $subject = encode( 'UTF-8', $subject );
  $body    = encode( 'UTF-8', $body );
  my $mailprog = '/usr/lib/sendmail';
  open( my $fh, "| $mailprog -t" ) || print { *STDERR } "Mail-Error\n";
  print { $fh } "To: $to_address\n";
  print { $fh } "Subject: $subject\n";
  print { $fh } "Content-Type: text/plain; charset=\"utf-8\"\n";
  print { $fh } "\n$body"; # \n starts body
  close $fh;
  return;
} ## end sub send_mail

Jpeg Image Meta Data EXIF + IPTC

use strict;
use warnings;
use 5.010;    # say
use Data::Dumper;

my $file = '181226_190440_TME_2285.jpg';
die "E: can't find/open file '$file'" unless -f $file;

# EXIF Info
use Image::EXIF;

my $exif = Image::EXIF->new( $file ) or die $!;
print Dumper $exif;
my $exif_info = $exif->get_all_info();
# get_all_info()
# get_image_info()
# get_camera_info()
# get_other_info()
# get_point_shoot_info()
# get_unknown_info()

print Dumper $exif_info;

my %h         = %{ $exif_info };
my $imageDate = $h{ 'other' }{ 'Image Generated' };    # 2018:09:29 11:46:41
say $imageDate;

# IPTC Info
use Image::IPTCInfo;

# Create new iptcinfo object
my $iptc_info = new Image::IPTCInfo( $file ) or die $!;
print Dumper $iptc_info;
# Check if file had IPTC data
unless ( defined( $iptc_info ) ) { die Image::IPTCInfo::Error(); }

print Dumper $iptc_info->Keywords();
print Dumper $iptc_info->SupplementalCategories();
print Dumper $iptc_info->Contacts();

my $keywordsRef = $iptc_info->Keywords();    # Keywords, SupplementalCategories, or Contacts

Read Excel

See https://metacpan.org/pod/Spreadsheet::Read and https://perlmaven.com/read-an-excel-file-in-perl 

# pp -u -l "libexpat-1__.dll" -M Spreadsheet::Read -M Spreadsheet::ParseExcel -M Spreadsheet::ParseXLSX -o script.exe script.pl
use Spreadsheet::Read qw(ReadData);
# perl -MCPAN -e "install Spreadsheet::Read"
use Encode;
my $file = "Test.xls";
my ( $fname, $fdir, $fext ) = fileparse( $file, qr/\.[^.]*/ );
my $fileOut = "$fname.txt";
open my $fh, '>:encoding(UTF-8)', $fileOut;
my $book = ReadData( $file );
say { $fh } "Kunde:\t" . $book->[ 1 ]{ B3 };
close $fh;

# iterate over all cells
my @rows = Spreadsheet::Read::rows( $book->[ 1 ] );
my @row = @{ $rows[ $i - 1 ] };
# replace undef -> 
@row = map { ( defined $_ ? $_ :  ) } @row;
foreach my $i ( 1 .. scalar @rows ) {
  foreach my $j ( 1 .. scalar @{ $rows[ $i - 1 ] } ) {
    say chr( 64 + $i ) . "$j " . ( $rows[ $i - 1 ][ $j - 1 ] //  );
  }
}

Create Excel

see https://perlmaven.com/create-an-excel-file-with-perl see https://metacpan.org/pod/Spreadsheet::WriteExcel::Examples#Example:-autofit.pl for an auto-scale-column-width hack 

# pp -u -l "libexpat-1__.dll" -M Spreadsheet::Read -M Spreadsheet::ParseExcel -M Spreadsheet::ParseXLSX -M Excel::Writer::XLSX -o script.exe script.pl
use Excel::Writer::XLSX;
# perl -MCPAN -e "install Excel::Writer::XLSX"
my $workbook  = Excel::Writer::XLSX->new( 'report.xlsx' );
my $worksheet = $workbook->add_worksheet();
$workbook->set_properties(
    title    => 'This is a title',
    author   => 'Torben Menke',
    comments => 'Created with Perl and Excel::Writer::XLSX',
);
# Add a handler to store the width of the longest string written to a column.
# We use the stored width to simulate an autofit of the column widths.
#
# You should do this for every worksheet you want to autofit.
$worksheet->add_write_handler(qr[\w], \&store_string_widths);
$s = \@Reihenfolge;
my $line = 0; # starts at 0
$worksheet->write( $line, 0, $s ); # header row
...
@L = map { $h{$_} } @Reihenfolge;
$s = \@L;
$line ++;
$worksheet->write($line, 0, $s ); # data row
...
# Run the autofit after you have finished writing strings to the workbook.
autofit_columns($worksheet); # from # https://metacpan.org/pod/Spreadsheet::WriteExcel::Examples#Example:-autofit.pl 
$workbook->close;

Date and Time Cells (write_date_time)

my $date_format = $workbook->add_format( num_format => 'dd.mm.yyyy hh:mm:ss' ); # for *display* in Excel
@_=localtime($ts); #($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
my $datestr = sprintf "%4d-%02d-%02dT%02d:%02d:%02dZ ",$_[5]+1900,$_[4]+1,$_[3],$_[2],$_[1],$_[0]; # !!! ISO8601 format, required for Excel !!!
# 2018-08-28 or 2018-08-28T14:24:22+00:00 or 2018-08-28T14:24:22Z or 20180828T142422Z
$worksheet->write_date_time( $row, $col, $datestr , $date_format )

GUI - TK - File Open Dialog

use Tk;
my $mw = MainWindow->new();
$mw->title( "Some Window" );
my $infile = $mw->getOpenFile();    # getSaveFile()
print "$infile\n";

Catch CRTL+C/STRG+C

$SIG{INT} = \&interrupt; # catch STRG+C
# ...
sub interrupt {
  say "Caught a control c!";
  # ...
  exit;
}

Options / Commandline Parameters

Help: Cpan Nice Article 

use Getopt::Long;

var 1 

my %o;        # stores command line parameters/options
$o{ 'trans' }   = 1;     # defaults
$o{ 'logname' } = "";
$o{ 'sleep' }   = 1.3;
my $res = GetOptions( \%o, "trans|t!", "logname|n=s", "sleep|s=f" );
if ( $o{ 'logname' } eq "" ) {
  say "
   Parameters:
   --logname -n NAME   = name of logfile
   --trans             = enable/disable, default = enable
   --sleep -s x        = Sleep/wait x sec between each ping, default: 1 sec
   ";
  exit 1;                # 0 = ok, 1 = error
}

var2 

use Getopt::Long;
my %o;        # stores command line parameters/options
$o{ 'trans' } = 1;    # defaults
$o{ 'gray' }  = 0;
my $res = GetOptions( \%o, "trans|t!", "trim!", "gray|grey|g!" );

# simple flag: 1/0
my $debug = 0;        # set default value for option
$res = GetOptions( "debug" => $debug );
print "Debug flag is $debug";
# ./script.pl --debug

# read options
my $age;
$res = GetOptions( "age=i" => $age );
# i for int ; s for string
if ( $age ) { print "Input age is $age years"; }
# ./script.pl --age=89

# optional options
# use ":" instead of "="
$res = GetOptions( "age:i" => $age );

# multiple names for one option
my $color;
$res = GetOptions( "color|colour|c" => $color );

# yes / no value
my $counter = -1;    # default value
$res = GetOptions( "counter!" => $counter );
# ./script.pl --counter -> counter is 1
# ./script.pl --nocounter -> counter is 0

# hashing it
$res = GetOptions( \%o, "base=i", "height=i" );
print $o{ 'base' };

Create a Perl Module for code reuse

use, require, do

use ModuleName;     # prefered way, use statements happen at compile time and throw an exception if they fail. Allows for importing functions into the current namespace
require ModuleName; # 'require' happens at run-time, and 'use' happens and compile-time
require 'file.pl';  # same
do 'file.pl';       # execute file as Perl script, similar to eval but in the same namespace. used for configurations.

[10]: Standard practice is to use use most of the time, require occasionally, and do rarely.

example1

main.pl 

use lib ('./');
use TMsConfig qw( %o );
print %o;

TMsConfig.pm 

package TMsConfig;
use Exporter qw(import); # gives you Exporter's import() method directly -> use for exporting variables via our @EXPORT
our @EXPORT = qw( %o );
our %o;
$o{'para1'} = 42;
1;    # Module needs to return 1

example2

from [11]

.../lib/TM/TestModuleMath.pm 

package TM::TestModuleMath;
use strict;
use warnings;
use Exporter qw(import);
our $var = 42;
our @EXPORT    = qw ($var);         # put stuff here you want to export
our @EXPORT_OK = qw(add multiply);  # will be exported on request
sub add {
  my ($x, $y) = @_;
  return $x + $y;
}
sub multiply {
  my ($x, $y) = @_;
  return $x * $y;
}
1;

.../dir1/main.pl 

#!/usr/bin/perl
# pl -> exe:
# pp -a "../lib/TM/TestModuleMath.pm" -o TestMain.exe TestMain.pl
#  -M Data::Dumper
use strict;
use warnings;
use File::Basename qw(dirname);
use Cwd  qw(abs_path); 
use lib dirname(dirname abs_path $0) . '/lib'; # => <ThisScript>../lib
use TM::TestModuleMath qw(add); 
print add(19, $var);

Crypto: Hashing

use MIME::Base64;    # encode_base64,decode_base64
                     # Base64 = 6 Bit encoded: A-Z,a-z,0-9,+,/ see https://en.wikipedia.org/wiki/Base64#Base64_table
use Digest::MD5 qw(md5 md5_hex md5_base64);
use Digest::SHA qw(sha512 sha512_hex sha512_base64);

my $data = "Moin Torben";

say "Data:\t'" . $data . "'";
say "Base64:\t'" . encode_base64( $data ) . "'";

say "MD5:\t'" . md5( $data ) . "'";
say "MD5hex:\t'" . md5_hex( $data ) . "'";
say "MD5base64:\t'" . fix_base64_padding( md5_base64( $data ) ) . "'";

say "SHA512:\t'" . sha512( $data ) . "'";
say "SHA512hex:\t'" . sha512_hex( $data ) . "'";
say "SHA512base64:\t'" . fix_SHA_base64_padding( sha512_base64( $data ) ) . "'";


sub fix_base64_padding {
  # appends "=" unless length is of modulo 4
  # from https://perldoc.perl.org/Digest/SHA.html#PADDING-OF-BASE64-DIGESTS
  my ( $s ) = @_;
  while ( length( $s ) % 4 ) {
    $s .= '=';
  }
  return $s;
}

HTTP POST/GET using LWP

my $ua = LWP::UserAgent->new();    # create User Agent using LWP
my %h;                             # hash for http parameters
$h{ 'id' }     = $id;
$h{ 'secret' } = $secret;
$h{ 'code' }   = $code;
my $response = $ua->post( $url, \%h );    # or get
my $cont = $response->as_string();
$cont = decode( 'UTF-8', $cont );

V0: LWP:Simple 

use LWP::Simple;    # network access
                    # read a file
my $content = get( $url );
getstore( $url, $localfilename );    # download file

Attention: for access to some pages like Wikipedia you need to rename the useragent, as perl lwp is on their blacklist: 

use LWP::Simple qw($ua get getstore);
$ua->agent( 'My agent/1.0' );

WWW::Mechanize Web Browsing

my $mech = WWW::Mechanize->new();
my $url  = "https://www.google.de";

$mech->get( $url );
# print Dumper $mech->content() and die;
# print Dumper $mech->forms() and die;
# print Dumper $mech->form_id('login_form') and die;
 
# Form Submit Var 1
# $mech->set_fields( email => 'myemail', password => 'mypassword' );
# $mech->submit();
# print Dumper $mech->content() and die;

# Form Submit Var 2
$mech->submit_form(
  form_id => 'login_form',
  fields  => { email => 'myemail', password => 'mypassword' },
);
die "Error: no success" unless ($mech->success);
print Dumper $mech->content() and die;

Strava: Web access URL, download contend, decode JSON to hash

use utf8;
use Encode;
use LWP::UserAgent;
# creat User Agent using LWP
my $url   = "https://www.strava.com/api/v3/athlete";
my $req   = HTTP::Request->new( GET => $url );
my $token = 1234567890;
$req->header( 'Accept'          => 'application/json' );
$req->header( 'Accept-Encoding' => 'UTF-8' );
$req->header( 'Authorization'   => "Bearer $token" );
my $ua = LWP::UserAgent->new();
$ua->agent( "MyApp/0.1 " );
my $res = $ua->request( $req );

if ( not $res->is_success ) {
  print "HTTP get code: ", $res->code,    "\n";
  print "HTTP get msg : ", $res->message, "\n";
  # use Data::Dump qw/ dd /;
  # dd( $res->as_string );
  die( "leaving" );
}
my $cont = $res->decoded_content;    # content, decoded if it was zipped
$cont = decode( 'UTF-8', $cont );

use JSON;                            # imports encode_json, decode_json, to_json and from_json.
my $j       = JSON->new->allow_nonref;
my $decoded = $j->decode( $cont );       # decoded results hashref or arrayref

if ( ref( $decoded ) eq "HASH" ) {
  my %h = %{ $decoded };
} elsif ( ref( $decoded ) eq "ARRAY" ) {
  my @L = @{ $decoded };
} else {
  die "E: message '$decoded' is no HASHREF or ARRAYREF";
}

Templates / Snippets

Trim String

sub trimString {
  my $s = shift;
  $s =~ s/[\s\r\n]+/ /g;
  $s =~ s/(^ | $)//g;
  return $s;
}

Generation of tables from file contents

#!/usr/bin/perl
use strict;
use warnings;
use 5.010;

# Perl Standard Modules
use File::Basename;
use Encode;

my $s;
my @L;
my @ListOfFiles = <input/*.csv>;
my $fileOut     = "report.csv";
open my $fh, '>:encoding(UTF-8)', $fileOut or die "ERROR: Can't write to file '$fileOut': $!";

my @Reihenfolge = qw(
    Kunde
    Bezeichnung
);
$s = join "\t", @Reihenfolge;    # header line
say { $fh } $s;

foreach my $file ( @ListOfFiles ) {
  my %h;
  my ( $fname, $fdir, $fext ) = fileparse( $file, qr/\.[^.]*/ );
  say $fname;
  $h{ 'Kunde' }       = $kunde;
  $h{ 'Bezeichnung' } = $bez;

  @L = map { $h{ $_ } } @Reihenfolge;
  $s = join "\t", @L;
  say { $fh } $s;
}
close { $fh };

VCard

find end of tag: 

.*?(?=\n[A-Z\-]+[:;])


Base64->JPEG

use File::Basename;
use MIME::Base64;
my $vcard;
$vcard =~ s/\r\n/\n/g;    # EOL -> Linux
$vcard =~ m/\nPHOTO[^:]*:(.*?)(?=\n[A-Z\-]+[:;])/s;
my $photo = $1;

my ( $fname, $fdir, $fext ) = fileparse( $fileIn, qr/\.[^.]*/ );
my $photoOut     = "output/$fname.jpg";
my $photoDecoded = MIME::Base64::decode_base64( $photo );
open my $fhPhoto, '>', $photoOut or die $!;
binmode $fhPhoto;
print { $fhPhoto } $photoDecoded;
close $fhPhoto;

Debugging

Size of variable in bytes 

use Devel::Size qw(total_size);
say total_size(\@matrix);

Total memory usage from [12] 

use Memory::Usage;
my $mu = Memory::Usage->new();
# Record amount of memory used by current process
$mu->record('starting work');
# Do the thing you want to measure
$object->something_memory_intensive();
# Record amount in use afterwards
$mu->record('after something_memory_intensive()');
# Spit out a report
$mu->dump();

UnitTests

see [13] file script.pl containing the logic 

sub add {
  my ( $a, $b ) = @_;
  return $a + $b;
}

file script.t containing the testcases 

use diagnostics;
use Test::More;    # qw( no_plan );

use lib( '.' );
do 'script.pl';

plan tests => 6;    # set how many test cases are going to be executed, to check to unintended die() etc.

# tests go here
is( add( 0, 0 ), 0, 'Nullsumme' );
isnt( add( 0, 0 ), 1, 'Nullsumme - isn\'t' );
# Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok()
pass( "test X" );    # synonym for ok( 1, "test X" );
fail( "test Y" );    # synonym for ok( 0, "test Y" );

subtest 'some subtests with own test plan count' => sub {
  plan tests => 2;
  is( add( -1,      +1 ),      0,      '+/-1' );
  is( add( 0.00001, 0.00009 ), 0.0001, 'float' );
};

pass( "test Z" );

run via 

perl script.t

Constant Variables

variant 1 using constant pragma 

use constant PI    => 4 * atan2(1, 1);
use constant DEBUG => 0;
print "Pi equals ", PI, "...\n" if DEBUG;
use constant WEEKDAYS => qw(
    Sunday Monday Tuesday Wednesday Thursday Friday Saturday
);
print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";

variant 2 using Const::Fast 

use Const::Fast;
const my $foo => 'a scalar value';
const my @bar => qw/a list value/;
const my %buz => ( a => 'hash', of => 'something' );

Parse HTML

use HTML::TreeBuilder 5 -weak;
# ...
my $tree = HTML::TreeBuilder->new;
# $tree->parse($url);
# $tree->parse_file($fileIn);
$tree->parse_content($html);
my $e = $tree-> look_down('class', 'infobox geography vcard');
if (defined $e) {
  print $e->as_HTML;
  # print $e->as_text;
} else {
  die "E: 'infobox geography vcard' not found";
}

Perltidy Parameters

see Visual Studio Code, for a complete list see [14]

Threads

Parallel computation using multiple threads for usage of multiple cpu cores. From [15] 

use strict; use warnings;

use threads;
use Thread::Queue;
my $numThreads = 2;

# Preparing Threads
my $q = new Thread::Queue;
my @Threads = ();

# the work to be done for all items of thread queue
sub tsub {
  my $thrNum = shift;
# processing query
  while (my $x = $q->dequeue) {
    $_ = "$pathToGnuplot $gpoutfile";
    say "Thread $thrNum: $x";
    system($x);  # $x = gnuplotfile
  }
  return;
}  

# Filling the queue with the list
$q->enqueue($_) for (@OutFiles);
for (1..$numThreads) { $q->enqueue(undef); } # for stop condition
# Fill the Threads Object
for my $thrNum (1..$numThreads) { 
  push @Threads,threads->new(\&tsub,$thrNum);
}

# Wait for all threads to complete execution.
foreach (@Threads) {
  print $_->join; # wait for thread, returns return value
}

Sharing variables 

use threads::shared;
my $count :shared ;
...
sub threadSub{
  lock ($count); #until end of block
  $count ++;  # test
}

Archive::Zip

[16] 

use Archive::Zip qw( :ERROR_CODES :CONSTANTS );

Create zip and add stuff

my $zip = Archive::Zip->new(); # Create a Zip file
foreach my $i (@list) {
  if (-d $i)    { $zip->addTree($i,$i);}
  elsif (-f $i) { $zip->addFile($i);}
}
die unless ( $zip->writeToFileNamed($newZipFilename) == AZ_OK );

Extract a single file from zip archiv

my $zip = Archive::Zip->new();
die unless ( $zip->read( $templatefilename ) == AZ_OK );
$zip->extractMember( $fileNameToExtract );

Remove a file from zip archiv

my $zip = Archive::Zip->new();
die unless ( $zip->read( $newZipFilename ) == AZ_OK );
my $member = $zip->memberNamed( $fileToExtract );
$zip-> removeMember ($member);
die unless ($zip->overwrite() == AZ_OK); # save
unlink $fileToExtract;
push @ODPs, $newZipFilename;
Retrieved from "https://entorb.net//wiki/index.php?title=Perl&oldid=4886"