Showing entries with tag "Perl".

Found 60 entries

Perl: Extract a column from a hashref

I have an array full of hash references and I need to extract a column and build an array from that.

my @x = ( {'ip' => '127.0.0.1'}, {'ip' => '10.10.10.10'}, {'ip' => '192.168.5.6'} );
my @y = hash_column('ip', @x); # ["127.0.0.1", "10.10.10.10", "192.168.5.6"]
sub hash_column {
    my $col = shift();
    my @arr = @_;

    my @ret;
    foreach my $x (@arr) {
        push(@ret, $x->{$col});
    }

    return @ret;
}
Leave A Reply

Perl: Find the longest string in an array

I need a Perl way to find the maximum string length in an array so here is a function to do that:

my @words = qw(Apple Pear Watermelon Banana Cherry);
my $max   = max_length(@words); # 10
sub max_length {
    my $max = 0;

    foreach my $item (@_) {
        my $len = length($item);
        if ($len > $max) {
            $max = $len;
        }
    }

    return $max;
}
Leave A Reply

Perl: Read a text file backwards by lines

I needed to read through a log file looking for certain entries backwards (newest entries first). Perl has a File::ReadBackwards module that does exactly this:

use File::ReadBackwards;

my $file = "/var/log/message";
my $fh   = File::ReadBackwards->new($file) or die "can't read $file";

while (my $line = $fh->readline()) {
    print $line;
}
Leave A Reply

Perl: array_chunk() to split arrays into smaller chunks

I have an large array in Perl that I need in smaller chunks to make iteration easier. I borrowed a concept from PHP and implemented array_chunk() in Perl.

my @orig = qw(foo bar baz one two three red yellow green donk);
my @new  = array_chunk(3, @orig);
sub array_chunk {
    my ($num, @arr) = @_;
    my @ret;

    while (@arr) {
        push(@ret, [splice @arr, 0, $num]);
    }

    return @ret;
}
Leave A Reply

Perl: Natural sort part deux

If you want to sort an array naturally (the way a human would) you can use Perl's sort() function, but use a custom sort method:

my @input  = qw(foo foo250 foo12 foo23 bar999 bar7 bar17 bar99 18);
my @sorted = sort { &natural } @input;

print join(", ", @sorted);
sub natural {
    # Separate the word and numeric parts
    my ($word_a, $num_a) = $a =~ /(.*?)(\d+|$)/;
    my ($word_b, $num_b) = $b =~ /(.*?)(\d+|$)/;

    #print "$a / $b: $word_a, $num_a, $word_b, $num_b\n";

    # If the words are diff it's an alpha sort on the words
    if ($word_a ne $word_b) {
        return $word_a cmp $word_b;
    # Words are the same, numeric sort the number part
    } else {
        return ($num_a || 0) <=> ($num_b || 0);
    }
}

See also: Natural Sort

Leave A Reply

Perl: Simple .ini parser

I wrote a simple .ini parsing function in Perl.

my $hash_ref = parse_ini("/tmp/config.ini");
sub parse_ini {
    open (my $INI, "<", $_[0]) or return undef;

    my $ret     = {};
    my $section = "_";

    while (my $line = readline($INI)) {
        if ($line =~ /^\[(.+?)\]/) { # Section heading
            $section = $1;
        } elsif ($line =~ /^(\w.*?)\s*=\s*"?(.*?)"?\s*$/) { # Key/Value pair
            $ret->{$section}->{$1} = $2;
        }
    }

    return $ret;
}
Leave A Reply

Perl: Loop through an array and extract pairs of variables

I had an array that I wanted to iterate through and extract pairs of variables. I found this pretty neat way to do that:

Perl:

my @arr = ("red", "green", "blue", "yellow", "orange", "purple");

while (@arr) {
    my ($x, $y) = splice(@arr, 0, 2);
    print "$x:$y\n";
}

I found a bunch of different ways to do this, and benchmarked them.

PHP:

$arr = ["red", "green", "blue", "yellow", "orange", "purple"];

while ($arr) {
    [$x, $y] = array_splice($arr, 0, 2);
    print "$x:$y<br />";
}

Note: You need to be careful you have an even number of elements or you will get undefined variable errors.

Leave A Reply

Perl: Glob recursively

I wrote a simple function to let you glob a directory recursively. It's limited to a single path/glob pattern, but that's good enough for now.

use File::Find;

my @files = globr("/etc/*.cfg");
sub globr {
    my ($str)       = @_;
    my ($dir,$glob) = $str =~ m/(.*\/)(.*)/;

    $dir  ||= './'; # Only a glob, so assume current dir
    $glob ||= $str; # No dir only a glob: *.pl

    # Find all the dirs in the target dir so we can recurse through them later
    my (@ret, @dirs);
    find( { wanted => sub { if (-d $_) { push(@dirs, $_) } }, no_chdir => 1 }, $dir);

    # Go through each dir we found above and glob in them for matching files
    foreach my $dir (@dirs) {
        my @g = glob("$dir/$glob");
        push(@ret, @g);
    }

    return @ret;
}

See also: Find files recursively

Leave A Reply

Perl: Prepend a script before script execution

I need to prepend some code before I run my Perl script. In my prepended script I will set some debug variables and add some debugging subroutines. The easiest way I've found to do this is with the -I and -M parameters. This allows you to set an include directory, and a specific module to be loaded before your script starts.

I was able to create a debug.pm in my /tmp/ directory and prepend it to my Perl script like this:

perl -I/tmp/ -Mdebug my_script.pl

This tells Perl to add /tmp/ to the list of locations to look for modules, and then to load the module debug. Then you simply make a debug.pm that includes the global variables you want to include and your main script will be able to read them.

Leave A Reply

Perl: Find files recursively

I needed to search recursively through a directory structure for files that matched a specific pattern. The simplest way that I found was using File::Find. I wrote a simple wrapper function to make searching simpler and more straight-forward. It uses regular expression matching so it should be quite flexible.

# All the files that end in .pl
my @perl_files = find_recurse(qr/\.pl$/, "/home/user/");
# Anything with kitten in the name
my @kittens    = find_recurse(qr/kitten/, "/home/user/");
# All .mp3 and .ogg files
my @aud_files  = find_recurse(qr/\.(mp3|ogg)$/, "/home/user/");
# Search two directories
my @cfg_files  = find_recurse(qr/\.cfg$/, ("/tmp/", "/etc/"));
use File::Find;

# Recursively search for files matching a pattern
sub find_recurse {
    my ($pattern, @dirs) = @_;
    if (!@dirs) {
        @dirs = (".");
    }

    my @ret = ();
    find(sub { if (/$pattern/) { push(@ret, $File::Find::name) } }, @dirs);

    return @ret;
}
Leave A Reply

Perl: Parse Linux log time strings

Linux has a common date/time format used in logs that looks like May 4 01:04:16. Often I will need to parse that into a unixtime so I wrote a function to do it so I won't have to reinvent the wheel next time:

use Time::Piece;

my $epoch = linux_timestr("May  4 01:04:16");

sub linux_timestr {
    my $time_str = shift();
    # Since this string type doesn't include the year we append the current
    # year to make the calculations correct. Otherwise we get 1970
    my $year     = (localtime())[5] + 1900;
    $time_str   .= " $year";

    my $format = "%b %d %H:%M:%S %Y";
    my $x      = localtime->strptime($time_str, $format);

    return $x->epoch();
}

Other common formats are cdate and ISO 8601

# cdate
my $x = localtime->strptime("Sat May  8 21:24:31 2021", "%a %b %d %H:%M:%S %Y");
# ISO 8601
my $y = localtime->strptime("2000-02-29T12:34:56", "%Y-%m-%dT%H:%M:%S");
Leave A Reply

Perl: Rounding a number

If you need to round a number in Perl you can use the POSIX method round(). If for some reason you don't want to use the POSIX method I wrote a pure Perl version of round() that is pretty fast.

use POSIX;

my $num = 3.14156;

print(POSIX::round($num)); # 3
print(round($num));        # 3
sub round {
    my $num = shift();
    my $ret;

    if ($num < 0) {
        $ret = int($num - 0.5);
    } else {
        $ret = int($num + 0.5);
    }

    return $ret;
}

Along with round, sometimes you want "round to the nearest X", which I also implemented:

sub nearest {
    my ($num, $nearest) = @_;

    my $div = $num / $nearest;
    my $ret = round($div) * $nearest;

    return $ret;
}
Leave A Reply

Perl: Calculate ellapsed milliseconds

In Perl if you want to calculate time in milliseconds (thousandths of a second) you can use Time::HiRes and the time() function.

use Time::HiRes qw(time);

my $start = time();

# Stuff you want to time here

my $elapsed = time() - $start;

printf("%0.2f seconds\n", $elapsed);
printf("%0.1f milliseconds\n", $elapsed * 1000);
printf("%d microseconds\n", $elapsed * 1000 * 1000);
printf("%d nanoseconds\n", $elapsed * 1000 * 1000 * 1000);
Leave A Reply

Perl: A script that contains valid Perl and Python code

Perl has a cool runtime option named -x that causes Perl to scan a file for the first shebang line with "perl" in it, and start executing there. This allows you to embed Perl in other files, like text files, or email files.

This got me thinking about embedding a working Perl script in another file. Python allows you to have large multi-line comment blocks using triple quotes """ blocks around your text. Using these comment blocks I was able to embed Perl code inside of a Python script. Effectively you can have a single file that is executable by Perl (with -x) and Python. I wrote up a quick proof-of-concept dual language script.

python dual-perl-python.py
perl -x dual-perl-python.py

Gives varying output:

Hello world from Python v3.8.7
Hello world from Perl v5.30.3
Leave A Reply

Perl: Simple file cache

I need a simple disk based object cache and Cache::File was overkill. I wrote my own dependency free (only core modules) version:

cache($key);                     # Get
cache($key, $val);               # Set expires is 1 hour (default)
cache($key, $val, time() + 900); # Set expires in 15 minutes
cache($key, undef)               # Delete

I purposely wrote it small so it can be copy/pasted in to other scripts simply. I wrote a more robust implementation with some basic tests as well. When an entry is fetched that is expired it will be removed from disk. Abandoned cache entries will persist on disk until cache_clean() is called.

sub cache {
    use JSON::PP; use Tie::File; use File::Path; use Digest::SHA qw(sha256_hex);

    my ($key, $val, $expire, $ret, @data) = @_;

    my $hash = sha256_hex($key || "");
    my $dir  = "/dev/shm/perl-cache/" . substr($hash, 0, 3);
    my $file = "$dir/$hash.json";
    mkpath($dir);

    tie @data, 'Tie::File', $file or die("Unable to write $file"); # to r/w file

    if (@_ > 1) { # Set
        $data[0] = encode_json({ expires => int($expire || 3600), data => $val, key => $key });
    } elsif ($key && -r $file) { # Get
        eval { $ret = decode_json($data[0]); };
        if ($ret->{expires} && $ret->{expires} > time()) {
            $ret = $ret->{data};
        } else {
            unlink($file);
            $ret = undef;
        }
    }

    return $ret;
}
Leave A Reply

Perl: Create a variable pointer to a built-in filehandle

I have a function that takes a filehandle for an argument. This is easy for filehandles that you create with open() but gets more complex if you try to use one of the automatic filehandles. Using the * syntax you can create a pointer to the symbol table for that entry.

$fh = \*STDIN;
$fh = \*STDOUT;
$fh = \*DATA;

Once it's a standard scalar variable it can easily be passed to a function.

Leave A Reply

Perl: Run a shell command and capture STDOUT and STDERR separately

Often I'll want to run a shell command and capture STDOUT and STDERR separately. I wrote a function to simplify this process:

my $x    = shell_cmd($cmd);
my $exit = $x->{exit};
my $err  = $x->{stderr};
my $out  = $x->{stdout};
# Run a command and return STDOUT/STDERR/Exit
sub shell_cmd {
    use IPC::Open3;
    my ($cmd) = @_;
    my ($STDIN, $STDOUT, $STDERR, $pid, $ret) = (1,2,3,undef,{});

    # If it's an arrayref run it directly (no shell)
    if (ref($cmd) eq 'ARRAY') {
        $pid = IPC::Open3::open3($STDIN, $STDOUT, $STDERR, @$cmd);
    } else {
        $pid = IPC::Open3::open3($STDIN, $STDOUT, $STDERR, $cmd);
    }
    waitpid($pid, 0);

    # Set FH slurp mode
    local $/ = undef;

    $ret->{exit}   = int($? >> 8);
    $ret->{stderr} = readline($STDERR);
    $ret->{stdout} = readline($STDOUT);
    $ret->{cmd}    = $cmd;

    return $ret;
}
Leave A Reply

Perl: Slurp entire file in a one liner

I need to change some text in a file that's spread across multiple lines. This means perl -pE won't work because it treats each line as a separate regexp. Reading the file in to one big string and then running a multiline regexp is the best solution.

Using -0777 tells Perl to read the entire file in to one string and allows multi-line regexps to work as intended.

If you have an input file with the content like:

if (foo
    && bar && !true) {
    # Do stuff
}

You can change the if statement with a one-liner like this:

perl -0777 -pE 's/\(foo.*?\)/(test)/s' /tmp/input.txt
Leave A Reply

Perl: Named captures in regexps

In a regular expression you can capture strings into variables using the default syntax:

$str = "2020-05-20";
$str =~ m/(\d{4})-(\d{2})-(\d{2})/;

printf("Year: %s Month: %s Day: %s\n", $1, $2, $3);

In a more complex regular expression/string things may move around. In this case it's better to use named captures instead of numeric captures. This can be done by using the (?<name>) syntax. This will capture that parenthesis pair in to the hash %+ with the name specified.

$str = "2020-05-20";
$str =~ m/(?<year>\d{4})-(?<month>\d{2})-(?<day>\d{2})/;

printf("Year: %s Month: %s Day: %s\n", $+{year},$+{month},$+{day});

Using named captures you can easily update your regular expression if the position of elements in your string change.

Note: If you use named captures, Perl also populates the numeric equivalent.

Leave A Reply

Perl: Time::Piece

Perl has a great core module for dealing with dates and times: Time::Piece.

use Time::Piece;

my $t = localtime();

my $unixtime = $t->epoch(); # Unixtime
my $human    = $t->cdate(); # Human readable

# Format a date/time for output
print $t->strftime("%Y-%M-%d") . "\n";

# Convert a specific format to a date/time object
my $bd = localtime->strptime("1985-02-14", "%Y-%M-%d");
print "You were born on a " . $bd->fullday . " in " . $bd->year . "\n";

# Date/Time addition
print "In one hour it will be: " . (localtime() + 3600)->hms . "\n";

It works by overriding the built in localtime() and gmtime() functions and giving them an object oriented interface. I highly recommend looking at it if you have to deal with dates and times.

Leave A Reply

Perlfunc: file_put_contents()

PHP has a really handy function called file_put_contents() that simplifies writing to a file. I did a quick Perl version of that function for my scripts.

sub file_put_contents {
    my ($file, $str) = @_;

    open (my $fh, ">", $file) or return undef;
    print $fh $str or return 0;
    close $fh;

    return length($str);
}

I also implemented a quick version of file_get_contents():

sub file_get_contents {
    open (my $fh, "<", $_[0]) or return undef;

    local $/ = undef; # Input rec separator (slurp)
    my $ret  = readline($fh);

    return $ret;
}
Leave A Reply

Perl: Change a specific line in a file

If you need to change a specific line in a text file based on line number you can use the following Perl one-liner:

perl -pi -e '$_ = "New value\n" if $INPUT_LINE_NUMBER == 75' file.txt

Just change the 75 to whatever line number you want to update.

Leave A Reply

Perl: Fetch HTTPS content

If you need to fetch a remote URL via HTTPS in a Perl script the easiest way I have found is to use HTTP::Tiny. HTTP::Tiny is a core module, and included in all Perl installations.

Sample code:

use HTTP::Tiny;

my $http = HTTP::Tiny->new(verify_SSL => 1, timeout => 5);
my $resp = $http->get("https://www.perturb.org/");
my $body = $resp->{content};

print $body;
Leave A Reply

Perl: Printing lines of a file between two delimiters

I need to print out the lines of a text file that are between a specific starting delimiter and and ending delimiter:

perl -nE 'print if /START_DELIMITER/../END_DELIMITER/' input.txt

or use this to exclude the delimiter lines

perl -nE '/END_DELIMITER/ and $y = 0; $y and print; /START_DELIMITER/ and $y = 1' input.txt

This method also works for data passed in via a pipe.

Leave A Reply

Perl: Check if a pid is active

If you need to see if a pid is currently active you can use send the process a null signal using kill(). You can create a function to check the status of a pid like this:

sub is_running {
    my $pid = shift();

    # Check if the pid is active
    my $running = kill(0, $pid);

    return $running;
}
Leave A Reply

Perl: redirect STDOUT and STDERR to a file

I need to redirect STDOUT and STDERR to a log file in my script. I didn't find really conclusive documentation on the best way to do this so here is what I came up with.

my $file = "/tmp/debug.log";
open(my $stdlog, ">", $file) or die("Cannot open $file");

*STDOUT = $stdlog;
*STDERR = $stdlog;
Leave A Reply

Perl: hashes in list syntax and arrays in hash syntax

Today I learned that Perl list and hash syntax can be used interchangeably. If you use list syntax but assign to a hash Perl will convert the pairs in to hash key/values.

my @array = ("one", "two", "three", "four");      # Create a standard array
my %hash  = ("apple", "red", "banana", "yellow"); # Create a hash using list syntax
my %hash  = ("apple" => "red", "banana" => "yellow"); # Create a standard hash
my @array = ("one" => "two", "three" => "four");      # Create an array using hash syntax

This is also why qw() is able to create hashes. Perl automagically converts lists to hashes if they're being assigned to a hash (and they have an even number of elements):

my %turtles = qw(Donatello Purple Raphael Red Michelangelo Orange Leonardo Blue);
Leave A Reply

Vim: Plugins written in Perl

Vim has it's own internal scripting language called Vimscript, which is complicated and only appropriate in Vim. Most versions of Vim ship with Perl support. I taught myself how to write a simple Vim script in Perl. The following will define a Vim function named CommaToggle, that calls a perl function named comma_toggle. This will toggle spaces after commas on/off.

function! CommaToggle()
perl << EOF

# Get the current line number, and line text
my ($line_num,$column) = $curwin->Cursor();
my $line               = $curbuf->Get($line_num);

if ($line =~ /,/) {
    my $fixed = comma_toggle($line);
    $curbuf->Set($line_num,$fixed);
}

sub comma_toggle {
    my $line = shift();

    if ($line =~ /, /) {
        # Remove spaces after commas
        $line =~ s/, /,/g;
    } else {
        # Add a space after commas
        $line =~ s/,/, /g;
    }

    return $line;
}

EOF
endfunction

Other Vim/Perl commands are available from the documentation. Then you can map a key combination to call that function:

nnoremap <Leader>, :call CommaToggle()<cr>
Leave A Reply

Perl: regular expression to check for ANSI sequences

I needed to test if a given string contains ANSI color codes. Here is the regexp I settled on to check for that:

my $ansi_color_regex = qr/\e\[[0-9]{1,3}(?:;[0-9]{1,3}){0,3}[mK]/;
if ($str =~ /$ansi_color_regex/) {
    print "String has some ANSI in it\n";
}

Alternately you can capture the color numbers with this regex:

my $ansi_color_regex = qr/(\e\[([0-9]{1,3}(;[0-9]{1,3}){0,3})[mK])/;
Leave A Reply

Perl: Natural Sort

I have a array with a bunch of names like vlan-1, vlan100, vlan34 which do not sort appropriately using Perl's standard sort() function. Sort::Naturally to the rescue! I didn't want to install an entire module for one sort operation, and require a dependency, so I ripped out just the natural sort function and included that in my script.

sub nsort {
    my($cmp, $lc);
    return @_ if @_ < 2;   # Just to be CLEVER.

    my($x, $i);  # scratch vars

    map
        $_->[0],

    sort {
        # Uses $i as the index variable, $x as the result.
        $x = 0;
        $i = 1;

        while($i < @$a and $i < @$b) {
            last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
            ++$i;

            last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
            ++$i;
        }

        $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
    }

    map {
        my @bit = ($x = defined($_) ? $_ : '');

        if($x =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s) {
            # It's entirely purely numeric, so treat it specially:
            push @bit, '', $x;
        } else {
            # Consume the string.
            while(length $x) {
                push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
                push @bit, ($x =~ s/^(\d+)//s) ?    $1  :  0;
            }
        }

        \@bit;
    }
    @_;
}

This is a slightly more portable version rather than maintaining the Sort::Naturally dependency.

See also: Natural Sort Part Deux

Leave A Reply

Perl: Working with columnar data

I have a text file of data that is in whitespace separated columns that I need to work with. Perl has a command line option -a to enable auto-splitting the input into an array called @F. Using a Perl one-liner you can automatically split at whitespace separation like this:

cat /tmp/file_list.txt | perl -lane 'print "mv $F[3] $F[1]"'

This will output mv commands to rename the file in the 4th column to the 2nd column.

More information available in perlrun.

Leave A Reply

PHP: Quote Word

I needed a function similar to Perl's qw. If you pass a string to this function it will return an array of the words, stripping any separating whitespace. If you pass true as the second parameter you will instead get a hash returning each word in a key/value pair.

function qw($str,$return_hash = false) {
    $str = trim($str);

    // Word characters are any printable char
    $words = str_word_count($str,1,"!\"#$%&'()*+,./0123456789-:;<=>?@[\]^_`{|}~");

    if ($return_hash) {
        $ret = array();
        $num = sizeof($words);

        // Odd number of elements, can't build a hash
        if ($num % 2 == 1) {
            return array();
        } else {
            // Loop over each word and build a key/value hash
            for ($i = 0; $i < $num; $i += 2) {
                $key   = $words[$i];
                $value = $words[$i + 1];

                $ret[$key] = $value;
            }

            return $ret;
        }
    } else {
        return $words;
    }
}

This is useful in the following scenarios:

$str  = "Leonardo    Donatello    Michelangelo    Raphael";
$tmnt = qw($str);

$str = "
    Leonardo       Blue
    Donatello      Purple
    Michelangelo   Orange
    Raphael        Red
";
$turtles = qw($str,true);
Leave A Reply

Perl: remove empty elements from array

I have an array with a bunch of empty strings, and other "empty" items, that I want to remove. Perl's grep() command makes this very simple:

@a = ("one", "", "three", "four", 0, "", undef, "eight");

@b = grep($_, @a);

# @b = ("one","three","four","eight");

The first argument to grep is an expression which evaluates whether $_ is a truthy value. This could easily also have been $_ ne "" so we don't also filter out false and 0.

Leave A Reply - 1 Reply

Perl: assign a regexp search/replace to a variable

Often I will want to assign a variable to be a search and replace of another variable. Logically you might write it like this:

$str = "foofoofoobar";
$new = $str =~ s/foo/FOO/g;

# $new contains 3 because three things were replaced in the string
print "$new\n";

This will not work because you are assigning the number of replacements made to $new. This is not what we wanted. Instead we want the search and replace to return the new string:

$str = "foofoofoobar";
$new = $str =~ s/foo/FOO/gr;

print "$new\n";

Note the /r after the regular expression. Documentation on /r is in Perlop

Leave A Reply

Perl: Using modules and @INC

I was going to write an article about using modules in Perl but Perl Maven did a better job than I ever could have. The article explains all the places Perl looks to find a given module, and how you give it alternate locations. The only thing I would add is that if you print out %INC it will list all the modules that were loaded, and from where.

use Data::Dumper;

print Dumper(\%INC);

Outputs:

$VAR1 = {
          'strict.pm' => '/usr/share/perl5/strict.pm',
          'Data/Dumper.pm' => '/usr/lib64/perl5/vendor_perl/Data/Dumper.pm',
          'warnings/register.pm' => '/usr/share/perl5/warnings/register.pm',
          'vars.pm' => '/usr/share/perl5/vars.pm',
          'overloading.pm' => '/usr/share/perl5/overloading.pm',
          'Carp.pm' => '/usr/share/perl5/vendor_perl/Carp.pm',
          'overload.pm' => '/usr/share/perl5/overload.pm',
          'constant.pm' => '/usr/share/perl5/vendor_perl/constant.pm',
          'bytes.pm' => '/usr/share/perl5/bytes.pm',
          'warnings.pm' => '/usr/share/perl5/warnings.pm',
          'XSLoader.pm' => '/usr/share/perl5/XSLoader.pm',
          'Exporter.pm' => '/usr/share/perl5/vendor_perl/Exporter.pm'
        };

Looks like Data::Dumper has quite a few dependencies.

Leave A Reply

Perl: ANSI colors

Perl's Term::ANSIColor is good but sometime it's overkill. I wrote a function to change colors before your print.

$color = color("13_on_5");
$reset = color("reset");

print $color . "Pink on purple" . $reset . "\n";
# String format: '115', '165_bold', '10_on_140', 'reset', 'on_173', 'red', 'white_on_blue'
sub color {
    my $str = shift();

    # If we're NOT connected to a an interactive terminal don't do color
    if (-t STDOUT == 0) { return ''; }

    # No string sent in, so we just reset
    if (!length($str) || $str eq 'reset') { return "\e[0m"; }

    # Some predefined colors
    my %color_map = qw(red 160 blue 27 green 34 yellow 226 orange 214 purple 93 white 15 black 0);
    $str =~ s|([A-Za-z]+)|$color_map{$1} // $1|eg;

    # Get foreground/background and any commands
    my ($fc,$cmd) = $str =~ /^(\d{1,3})?_?(\w+)?$/g;
    my ($bc)      = $str =~ /on_(\d{1,3})$/g;

    # Some predefined commands
    my %cmd_map = qw(bold 1 italic 3 underline 4 blink 5 inverse 7);
    my $cmd_num = $cmd_map{$cmd // 0};

    my $ret = '';
    if ($cmd_num)     { $ret .= "\e[${cmd_num}m"; }
    if (defined($fc)) { $ret .= "\e[38;5;${fc}m"; }
    if (defined($bc)) { $ret .= "\e[48;5;${bc}m"; }

    return $ret;
}

The ANSI color numbers can be determined using term-colors.pl.

Note: You can test if you're outputting to a TTY which supports ANSI colors, or a file using the -t test.

sub is_tty {
    return -t STDOUT;
}

See also: Regexp to check for ANSI color codes
See also: Tests

Leave A Reply

Perl: Quick extract variables from @ARGV

I'm a big fan of Getopt::Long, but sometimes I do not want to include a large module to extract two arguments. I wrote a quick function that will parse simple command line arguments and give you a hash of their values.

sub argv {
    state $ret = {};

    if (!%$ret) {
        for (my $i = 0; $i < scalar(@ARGV); $i++) {
            # If the item starts with "-" it's a key
            if ((my ($key) = $ARGV[$i] =~ /^--?([a-zA-Z_]\w*)/) && ($ARGV[$i] !~ /^-\w\w/)) {
                # If the next item does not start with "--" it's the value for this item
                if (defined($ARGV[$i + 1]) && ($ARGV[$i + 1] !~ /^--?\D/)) {
                    $ret->{$key} = $ARGV[$i + 1];
                    $ARGV[$i]    = $ARGV[$i++] = undef; # Flag key/val to be removed
                } else { # Bareword like --verbose with no options
                    $ret->{$key}++;
                    $ARGV[$i] = undef; # Flag item to be removed
                }
            }
        }
        @ARGV = grep { defined($_); } @ARGV; # Remove processed items from ARGV
    };

    if (defined($_[0])) { return $ret->{$_[0]}; } # Return requested item

    return $ret;
}

Note: I also wrote a similar implementation for PHP

Leave A Reply

Perl: See the path of a module

I've been testing various version of a Perl module and I wanted to make sure I was testing with the right one. This code snippet will output the paths of the loaded modules.

perl -MData::Dump::Color -e 'dd(\%INC);'

This example loads Data::Dump::Color and then outputs the contents of %INC which contains the paths of all loaded modules.

Leave A Reply

Perl: Count number of a specific character in a string

I needed to count how many * characters were in a string, so I wrote this simple function.

sub char_count {
    my ($needle,$str) = @_;
    my $len = length($str);
    my $ret = 0;

    for (my $i = 0; $i < $len; $i++) {
        my $found = substr($str,$i,1);

        if ($needle eq $found) { $ret++; }
    }

    return $ret;
}

You can also write it using tr:

sub char_count {
    my ($needle,$haystack) = @_;
    my  $count = $haystack =~ tr/$needle//;

    return $count;
}
Leave A Reply - 2 Replies

Perl: find the index of an array item

I needed to find the index of an item in an array so I wrote a simple Perl function.

my @arr = qw(foo bar baz donk);
my $x   = array_index("bar", @arr)); # 1
sub array_index {
    my ($needle, @haystack) = @_;

    if (defined($needle)) {
        for (my $idx = 0; $idx < @haystack; $idx++) {
            if ($haystack[$idx] eq $needle) {
                return $idx;
            }
        }
    }

    return undef;
}
Leave A Reply - 1 Reply

Command line trim()

Often I'll need to trim (remove leading and trailing whitespace) from command line output. The easiest way I've found is to pipe to a one line Perl script

my_messy_command.sh | perl -pE 's/^\s+|\s+$//'

This runs a replace regexp on the input, trims extraneous whitespace and outputs the cleaner version.

Leave A Reply

Perl: Conditionally load a module

I am using Data::Dump which has a drop in replacement named Data::Dump::Color. I wanted to conditionally/programmatically load a specific module.

if ($color) {
    use Data::Dump::Color;
} else {
    use Data::Dump;
}

This doesn't work because use statements are run before ANY other code is run. The above code will load BOTH modules, because use always runs. Instead you have to use require.

if ($color) {
    require Data::Dump::Color;
    Data::Dump::Color->import();
} else {
    require Data::Dump;
    Data::Dump->import();
}

Calling require does not automatically import all the exported functions, so you have to specifically call the include() function.

Leave A Reply - 2 Replies

Perl: Increment a number in a text file

I have a manifest file that contains a build_version=XX number field (among a lot of others) that I want to automatically increment. Here is a simple Perl one-liner to increment that number in a given file.

perl -pi -e 's/(build_version)=(\d+)/"build_version=" . ($2 + 1)/e' manifest

In this example the /e in the regexp says that the replace value is an expression. In this case the replace value is some math that add adds one to the current value.

Leave A Reply

Perl: detect if a module is installed before using it

I wanted to check if a Perl module was installed at runtime, and error out accordingly if it wasn't. This allows me to print intelligent error messages if a module is not installed.

eval { require Weird::Module; };
if ($@) { die("Module is not installed\n"); }

This allows you to create runtime functions depending on which module is installed:

# Debug print variable using either Data::Dump::Color (preferred) or Data::Dumper
# Creates methods k() and kd() to print, and print & die respectively
BEGIN {
    if (eval { require Data::Dump::Color }) {
        *k = sub { Data::Dump::Color::dd(@_) };
    } else {
        require Data::Dumper;
        *k = sub { print Data::Dumper::Dumper(\@_) };
    }

    sub kd {
        k(@_);

        printf("Died at %2\$s line #%3\$s\n",caller());
        exit(15);
    }
}

These functions should mimic some Krumo functionality.

Leave A Reply

Regexp for spliting on non-escaped characters

I have a string like the following:

desc=Did you know 2 + 2 \= 4?

I want to split each chunk of that string into segments separated by the equal signs. I can't just split on the equal signs because the text has an equal sign in it. I need to split on the non-escaped equal signs.

@parts = split(/(?<!\\)=/,$str);

This is called positive and negative look behind.

In PHP the only difference is that you have to double escape your \

$parts = preg_split('/(?<!\\\\)=/',$str);
Leave A Reply

Perl: doing a regexp replace on an array

I have an array of items that I want to do a quick regexp replace on each element. Here is a very elegant solution:

@names = ("John", "Paul", "george", "Ringo");
s/^g/G/g for @names;
print join(", ",@names);
Leave A Reply

Perlfunc: pfile()

PHP has a handy function named file() that will read the contents of a file into a variable. I wrote a quick Perl version of the same function.

sub pfile {
    my $target = shift();
    my $is_fh  = defined(fileno($target));
    my $ret;

    # If we passed in a FH read everything from that
    if ($is_fh) {
        while (readline($target)) { $ret .= $_; }
    # Else it's a file to be opened 
    } else {
        open (my $fh, "<", $target) or return undef;

        while (<$fh>) { $ret .= $_; }
    }

    if (wantarray) {
        return split('\n',$ret);
    }

    return $ret;
}
Leave A Reply - 1 Reply

Perl: Count occurrences of substring

I needed a quick way to count the number of times a substring appears in a larger string.

$count = @{[$haystack =~ /$needle/g]};

Updated: This is a more clear solution:

my $count = scalar(split(/$needle/,$haystack)) - 1;

Lots of good options found in the comments though.

Leave A Reply - 2 Replies

Perlfunc: is_numeric()

Simple Perl function to tell if a string is numeric.

sub is_numeric {
    if ($_[0] =~ m/^[+-]?\d+(\.\d+)?$/) {
        return 1;
    }

    return 0
}
Leave A Reply

Obfuscate some data in perl

If you have some data you don't want to be readily readable in Perl you can obfuscate it with the unpack function. You can take a given string and encode it as printable hex and store that, and later unpack it for use in the real world.

perl -E 'print unpack("H*", "I love Perl!") . "\n"'
perl -E 'print pack("H*", "49206c6f7665205065726c21") . "\n"'
Leave A Reply

Perlfunc: in_array()

If you need to determine if an array contains a specific element you can use this function:

sub in_array {
    my $needle   = shift();
    my @haystack = @_;

    foreach my $l (@haystack) {
        if ($l eq $needle) { return 1; }
    }

    return 0;
}

Note: If you want to check integers just change the eq to ==

Leave A Reply

Perlfunc: human_size()

Quick function to convert bytes to a human readable string:

my $str = human_size(1536);       # "1.5K"
my $str = human_size(1234567);    # "1.2M"
my $str = human_size(1234567890); # "1.1G"
sub human_size {
    my $size = shift();

    if ($size > 1024**5) {
        $size = sprintf("%.1fP", $size / 1024**5);
    } elsif ($size > 1024**4) {
        $size = sprintf("%.1fT", $size / 1024**4);
    } elsif ($size > 1024**3) {
        $size = sprintf("%.1fG", $size / 1024**3);
    } elsif ($size > 1024**2) {
        $size = sprintf("%.1fM", $size / 1024**2);
    } elsif ($size > 1024) {
        $size = sprintf("%.1fK", $size / 1024);
    } elsif ($size >= 0) {
        $size = sprintf("%dB", $size);
    }

    return $size;
}

Here is the same function implemented in PHP:

function human_size($size) {
    # If the size is 0 or less, return 0 B this stops math errors from occurring
    if ($size <= 0) {
        return '0B';
    } else {
        $unit=array('B','K','M','G','T','P');
        return @round($size/pow(1024,($i=floor(log($size,1024)))),2) . $unit[$i];
    }
}

The same function in C

char buf[8] = "";

human_size(348, buf);
printf("Got: %s\n", buf);

char* humanSize(unsigned long long size, char* str) {
    if (size > 1152921504606846976L) {
        snprintf(str, 7, "%.1fE", (float)size / 1152921504606846976L);
    } else if (size > 1125899906842624L) {
        snprintf(str, 7, "%.1fP", (float)size / 1125899906842624L);
    } else if (size > 1099511627776L) {
        snprintf(str, 7, "%.1fT", (float)size / 1099511627776L);
    } else if (size > 1073741824L) {
        snprintf(str, 7, "%.1fG", (float)size / 1073741824L);
    } else if (size > 1048576L) {
        snprintf(str, 7, "%.1fM", (float)size / 1048576L);
    } else if (size > 1024) {
        snprintf(str, 7, "%.1fK", (float)size / 1024);
    } else if (size <= 1024) {
        snprintf(str, 7, "%uB", (unsigned)size);
    }

    return str;
}
Leave A Reply - 1 Reply

Perl: END { }

Sometimes in coding I've found that you need to have code that runs on exit, regardless of why. In Python you can use atexit but in Perl it's as easy as defining an END code block:

END {
    # Do some clean up code
    close OUTPUT_FILE;
    output_close_message()
}

Cool it looks like there is a BEGIN method as well!

Leave A Reply

Perlfunc: days_in_month

Code to figure out the days in a given month. Of course it's leap year aware.

sub days_in_month() {
   use Time::Local;

   my ($month,$year) = @_;
   if ($month < 1 || $month > 31) { return 0; }
   if ($year < 1970 || $year > 2036) { return 0; }

   my $secs = timelocal(0,0,13,1,$month - 1,$year);
   for (my $i = 27; $i < 32; $i++) {
      my $new_month = ((localtime($secs + ($i * 86400)))[4]) + 1;

      if ($new_month != $month) { return $i; }
   }
}
Leave A Reply

Perl: Seconds Since Midnight

Some quick perl to return the number of seconds in the current day since midnight.

sub midnight_seconds {
   my @time = localtime();
   my $secs = ($time[2] * 3600) + ($time[1] * 60) + $time[0];

   return $secs;
}

The same code just written in PHP.

function midnight_seconds() {
   $secs = (date("G") * 3600) + (date("i") * 60) + date("s");
   return $secs;
}
Leave A Reply - 6 Replies

Perl Sexy Data Structure

Just an example of a weird/exotic/sexy data structure in Perl. This is correct syntax, just in case I need to reference it in the future.

%hash = (
    1 => 'one',
    2 => 'two',
    3 => {
        'blind' => 'mice',
        'musketeers' => 'men',
    },
        4 => 'four',
        5 => {
            'spanish' => 'cinco',
            'french' => 'cinq',
            'german' => 'fünf',
    },
    6 => [7,8,9,10],
    11 => {
        'level-1' => {
            'level-2' => {
                'level-3' => "last",
            },
        },
    },
    12 => [
        [1,2,3],
        [4,5,6],
        [7,8,9],
    ],
    13 => [
        {'one' => 1},
        {'two' => 2},
    ],
);
Leave A Reply

Perl: Sorting a hash

This syntax still doesn't make much sense to me but here is how you sort a perl hash by value. This returns a list of all the keys of the hash sorted in the order you want. To reverse the sort simply change $a and $b locations with each other.

@sort = sort{ $unique{$a} <=> $unique{$b} } keys %unique;
Leave A Reply - 2 Replies

Perlfunc: trim()

Perl function to trim leading and trailing whitespace, borrowed from String::Util.

sub trim {
    my ($s) = (@_, $_); # Passed in var, or default to $_
    if (!defined($s) || length($s) == 0) { return ""; }
    $s =~ s/^\s*//;
    $s =~ s/\s*$//;

    return $s;
}

To trim an each item in an array you can do:

@array = map { &trim($_) } @array;
Leave A Reply

Perl: Replace text in a file

If you need to replace some instances of a string in a file with something new you can use the following Perl one liner.

perl -pi -e "s/search/replace/g" /tmp/foo.txt
Leave A Reply

Perlfunc: ip2long

sub ip2long {
    my $ip = shift;
    my @ip = split(/\./,$ip);

    #Make sure it's a valid ip
    if ($ip !~ /\d{1,3}\.\d{1,3}\.\d{1,3}/) { return 0; }

    if (scalar(@ip) != 4) { return 0; }

    #Perform the bit shifting to align each octet in the long correctly
    my $i = ($ip[0] << 24) + ($ip[1] << 16) + ($ip[2] << 8) + $ip[3];
    return $i;
}
sub long2ip {
    my $long = shift();
    my (@i,$i);

    $i[0] = ($long & 0xff000000) >> 24;
    $i[1] = ($long & 0x00ff0000) >> 16;
    $i[2] = ($long & 0x0000ff00) >> 8;
    $i[3] = ($long & 0x000000ff);

    $i = "$i[0].$i[1].$i[2].$i[3]";
    return $i;
}
Leave A Reply