Once you find a Unicode code point you can put it into a Perl string in several ways:

my $thumbs_up = "";

$thumbs_up = "\x{1F44D}";
$thumbs_up = "\N{U+1F44D}";
$thumbs_up = chr(0x1F44D);
$thumbs_up = pack("U", 0x1F44D);

# Make sure STDOUT is set to accept UTF8
binmode(STDOUT, ":utf8");

print $thumbs_up x 2 . "\n";

If you need to see if a file is world readable you'll need to be able to break out file permissions.

my @p     = get_file_permissions("/tmp/foo.txt");
my $other = $p[2];

# 4 = readable, 2 = writeable, 1 = executable
if ($other & 4) { print "File is world readable\n"; }
if ($other & 2) { print "File is world writeable\n"; }
if ($other & 1) { print "File is world executable\n"; }

sub get_file_permissions {
    my $file = shift();

    my @x    = stat($file);
    my $mode = $x[2];

    my $user  = ($mode & 0700) >> 6;
    my $group = ($mode & 0070) >> 3;
    my $other = ($mode & 0007);

    my @ret = ($user, $group, $other);

    return @ret;
}

Reddit had a mini challenge about implementing UUIDv7 in various languages. I whipped up a Perl implementation that turned out pretty well. I submitted it to the official GitHub repo and it was accepted.

See also: UUIDv4 in Perl.

Perl has regular expressions built in to the core of the language and they are very powerful. It's easy enough to find a single match with a regexp:

# Find the *first* three letter word in the string
my $str = "one two three four five six seven eight nine ten";
my @x   = $str =~ m/\b(\w{3})\b/; # ("one")

If you want to find all of the three letter words you can add the g modifier to the end of your regex to tell it to match "globally".

# Find *all* the three letter words
my $str = "one two three four five six seven eight nine ten";
my @x   = $str =~ m/\b(\w{3})\b/g; # ("one", "two", "six", "ten")

You can also iterate on your global regexp if you want to get the matches one at a time:

my $str = "one two three four five six seven eight nine ten";
my @x   = ();
while ($str =~ m/\b(\w{3})\b/g) {
    push(@x, $1);
}

print join(",", @x); # "one,two,six,ten"

If you've written some Perl and you want to improve upon the execution speed you can use a profiler. There are several profilers available, but the best one I've found is Devel::NYTProf. Once you have the module installed you run your Perl script as normal but invoke the profiler:

perl -d:NYTProf term-colors.pl

This will result in a nytprof.out file being created in the current directory. This file contains raw stats about function calls and code timings. You can turn this data into something human readable by converting it to HTML.

nytprofhtml nytprof.out --out perl-profile/

This will create a nice HTML page with all kinds of information about how the Perl interpreter ran your script. With this information hopefully you can find places in your code that could use improvement.

I'm a big fan of SuperGenPass so I decided to learn how it works. The algorithm is pretty simple so I decided to implement it in two of my favorite languages: PHP and Perl.

Hopefully this will help someone else trying to understand the concepts. Special thanks to Iannz for the great Bash implementation I based my code on.

Perl v5.25.7 added support for the @{^CAPTURE} variable which wrapped all the regexp parenthesis captures up into an array. If you need this functionality in an older version of Perl you can use this function:

my $str =  "Hello Jason Doolis";
$str    =~ /Hello (\w+) (\w+)/;

my @captures = get_captures(); # ("Jason", "Doolis")

sub get_captures {
    no strict 'refs';

    my $last_idx = scalar(@-) - 1;
    my @arr      = 1 .. $last_idx;
    my @ret      = map { $$_; } @arr;

    return @ret;
}

If you want to add an element to the middle of an existing array you can use the splice() function. Splice modifies arrays in place. Splice takes four arguments for this: the array to modify, the index of where you want to modify, the number of items you want to remove, and an array of the elements to add.

my @x = qw(one three);

# At the 2nd index, add (replace zero elements) a one element array
splice(@x, 1, 0, ('two'));

print join(" ", @x); # "one two three"

I learned that you can extract various elements from a Perl array in a very creative/simple way. Using this syntax may simplify some of your code and save you a lot of time.

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

my @w = @colors[(0, 3)];    # ("red", "yellow");
my @x = @colors[(0, 2, 4)]; # ("red", "green", "orange");

# First and last element
my @y = @colors[(0, -1)];   # ("red", "purple");

# First ten items
my @z = @array[0 .. 10];    # Using the `..` range operator

Basically any call to an array where the payload is an array of indexes will return a new array with those items extracted.

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

# You can also use an array variable to specify the elements to extract
my @ids = (1,3,5);
my @x   = @colors[@ids]; # ("blue", "yellow", "purple")

Note: Since you are referencing the whole array (not one element) you use the @ sigil instead of $.

I use human_size() a lot in Perl, and sometimes it's nice to have a colored version. Here is a quick colorized version:

sub human_size_c {
    my $size = shift();
    if (!defined($size)) { return undef; }

    if    ($size >= (1024**5) * 0.98) { $size = sprintf("\e[38;5;167m%.1fP\e[0m", $size / 1024**5); }
    elsif ($size >= (1024**4) * 0.98) { $size = sprintf("\e[38;5;105m%.1fT\e[0m", $size / 1024**4); }
    elsif ($size >= (1024**3) * 0.98) { $size = sprintf("\e[38;5;45m%.1fG\e[0m" , $size / 1024**3); }
    elsif ($size >= (1024**2) * 0.98) { $size = sprintf("\e[38;5;47m%.1fM\e[0m" , $size / 1024**2); }
    elsif ($size >= 1024)             { $size = sprintf("\e[38;5;226m%.1fK\e[0m", $size / 1024);    }
    elsif ($size >= 0)                { $size = sprintf("\e[38;5;160m%dB\e[0m"  , $size);           }

    return $size;
}

See also: Original human_size()

If you want to remove an item from an array you can use a inverse grep filter like this:

my @x = qw(foo bar baz orange);
@x    = grep { !/orange/ } @x;

or

my @x = qw(foo bar baz orange);
@x    = grep { $_ ne 'orange' } @x;

I have a directory of data files I wanted to read line-by-line simply. You can loop through each file, open a filehandle, process the lines, close the filehandle, but that can be repetitive. Perl has a unique mechanism where it will iterate across all the files in the @ARGV array automatically. You can fake out the @ARGV array with your own list of files and then iterate accordingly:

local @ARGV = sort(glob("/tmp/data/*.txt"));

# Special ARGV filehandle reads all the files sequentially
while (my $line = readline(ARGV)) {
    print $line;
}

Perl allows you to create a reference to subroutine and store it in a variable. This allows subroutines to be passed around to other functions. In Perl speak these are called coderefs. There are two ways to create them:

my $one = sub { print "Hello world!"; }
my $two = \&hello_world;

sub hello_world {
    print "Hello world!";
}

Calling a code reference is simple:

$coderef->(); # No params
$coderef->($param1, $param2);

I have a list of IP addresses that I want sorted in a human readable fashion. A simple sort() on a list of IPs will not work because the octets may be: one, two, or three digits long which confuses sort(). Here is a simple sorting function for a list of IP addresses:

my @ips    = qw(198.15.0.20 4.2.2.1 10.11.1.1 10.100.1.1 65.182.224.40);
my @sorted = sort by_ip_address @ips;

sub by_ip_address {
    return ip2long($a) <=> ip2long($b);
}

Note: You will need my ip2long() function for this to work.

I need a random temporary file to put some data in while my script executes. The file should be removed automatically after the script completes. Enter File::Temp which handles all of this for you.

use File::Temp;

my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);

Alternately if you need a temporary directory that's automatically removed on completion you can use:

use File::Temp;

my $dir = File::Temp::tempdir(CLEANUP => 1);

Note: File::Temp is a core module, so you already have it.

Pay day is once a month on the 7th. Can you calculate the number of days until payday using a Perl one-liner in less than a hundred characters? I wasn't able to do it, but some creative Redditors were:

perl -E '$_=-1;for($t=time;$d!=7;$t+=86400){$_++;$d=(localtime($t))[3]}say'

I needed simple and portable way to generate a version 4 UUID in Perl, so I hacked apart various pieces of UUID::Tiny and came up with this.

sub uuidv4 {
    my $uuid = '';

    # Four random bytes
    for (my $i = 0; $i < 4; $i++) {
        $uuid .= pack('I', int(rand(2 ** 32)));
    }

    # Replace the version of the UUID with 4 (0x40)
    substr($uuid, 6, 1, chr(ord(substr($uuid, 6, 1)) & 0x0f | 0x40 ));

    my @parts = map { substr $uuid, 0, $_, '' } ( 4, 2, 2, 2, 6 );
    my @hex   = map { unpack("H*", $_) } @parts;
    my $ret   = join('-', @hex);

    return $ret;
}

Perl has a unique feature where if it sees a line that contains __DATA__ the parser will stop there as if the file ended. This allows you put non-perl code after your __DATA__ line: text, json, HTML, etc. Perl will even allow you to read the text after the __DATA__ like it's a normal file handle. This function will read all the text after your __DATA__ block.

sub get_data_str {
    local $/ = undef; # Slurp mode
    return readline(DATA);
}

Note: Perl also recognizes __END__ but that text is not readable.

See also: PHP version

I'm a big fan of .ini files because they're human readable, and also very machine readable. I wrote a quick function to convert a hashref to a simple .ini string.

my $str = hash_to_ini({ data => { 'name' => 'scott', animal => 'dog' }});

sub hash_to_ini {
    my $x   = $_[0];
    my $ret = '';

    foreach my $key (sort(keys(%$x))) {
        my $val = $x->{$key};

        if (ref($val) eq "HASH") {
            $ret .= "[$key]\n";
            foreach my $k (sort(keys(%$val))) { $ret .= "$k = " . $val->{$k} . "\n"; }
        } else { $ret .= "$key = $val\n" }
    }

    $ret =~ s/\n\[/\n\n[/; # Add a space between sections
    return $ret;
}

I also wrote a version in PHP

function hash_to_ini($x) {
    $ret = '';

    foreach (array_keys($x) as $key) {
        $val = $x[$key];

        if (is_array($val)) {
            $ret .= "[$key]\n";
            foreach (array_keys($val) as $k) { $ret .= "$k = " . $val[$k] . "\n"; }
        } else { $ret .= "$key = $val\n"; }
    }

    $ret = preg_replace("/\n\[/", "\n\n[", $ret);
    return $ret;
}

Note: see also parse_ini()

This is a quick method to send an SMTP email message using on core Perl modules.

use Net::SMTP;
use Time::Piece;

my $smtp_server = "mail.server.com";
my $smtp        = Net::SMTP->new($smtp_server, Timeout => 3, Hello => 'hostname.server.com');

my $err;
my $ok = send_email('to@domain.com', 'from@domain2.com', 'Test subject', '<b>HTML</b> body', \$err);

if (!$ok) { print "Error: $err" }

sub send_email {
    my ($to, $from, $subject, $html_body, $err) = @_;

    $smtp->mail($from);
    my $ok = $smtp->to($to);

    if ($ok) {
        # Ghetto strip tags
        my $text_body = $html_body =~ s/<[^>]*>//rgs;
        my $sep       = time() . "-$smtp_server";

        my $headers  = "To: $to\n";
        $headers    .= "From: $from\n";
        $headers    .= "Subject: $subject\n";
        $headers    .= "Date: " . localtime->strftime() . "\n";
        $headers    .= "Message-ID: <" . time() . "\@$smtp_server>\n";
        $headers    .= "Content-type: multipart/alternative; boundary=\"$sep\"\n\n";
        $headers    .= "This is a multi-part message in MIME format\n\n";

        # Text version
        $headers .= "--$sep\n";
        $headers .= "Content-Type: text/plain\n\n";
        $headers .= "$text_body\n\n";

        # HTML version
        $headers .= "--$sep\n";
        $headers .= "Content-Type: text/html\n\n";
        $headers .= "$html_body\n\n";

        # Closing separator
        $headers .= "--$sep--\n";

        $smtp->data();
        $smtp->datasend($headers);
        $smtp->dataend();
    } else {
        $$err = $smtp->message();
    }

    return $ok;
}

I need to extract all the unique elements from an array. There is no built-in way to do this, but there are several user functions you can use.

my @x = qw(one two one three one four);
my @y = array_unique(@x); # ("one", "two", "three", "four")

# Borrowed from: https://perlmaven.com/unique-values-in-an-array-in-perl
sub array_unique {
    my %seen;
    return grep { !$seen{$_}++ } @_;
}

I stand corrected, List::Util includes a uniq() function to do exactly this, is a core module, and is included with all Perl installations.

Perl function to return a human readable string for a time duration in seconds.

my $str = human_time_diff(320);  # "5 minutes"
my $str = human_time_diff(3700); # "1 hour"

sub human_time_diff {
    my $seconds = int(shift());
    my $num     = 0;
    my $unit    = "";
    my $ret     = "";

    if ($seconds < 120) {
        $ret = "just now";
    } elsif ($seconds < 3600) {
        $num  = int($seconds / 60);
        $unit = "minute";
    } elsif ($seconds < 86400) {
        $num  = int($seconds / 3600);
        $unit = "hour";
    } elsif ($seconds < 86400 * 30) {
        $num  = int($seconds / 86400);
        $unit = "day";
    } elsif ($seconds < (86400 * 365)) {
        $num  = int($seconds / (86400 * 30));
        $unit = "month";
    } else {
        $num  = int($seconds / (86400 * 365));
        $unit = "year";
    }

    if ($num > 1) { $unit .= "s"; }
    if ($unit) { $ret = "$num $unit"; }

    return $ret;
}

See also: PHP version

It's common to come across date strings in log files that you want to convert to a Unixtime. Perl has Data::Parse which offers a str2time() function to do this.

use Date::Parse;

my $ut = str2time("Thu, 13 Oct 94 10:13:13 +0700") # 782017993;

I wrote a version of strtotime() in a function that may be more portable. It has the limitation that it does not support timezone strings, but if you don't need them then it is a valid alternative.

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;
}

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;
}

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;
}

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

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;
}

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.

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

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.

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.

use File::Find;

# 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/"));

# 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;
}

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");

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 ($nearest, $num) = @_;

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

    return $ret;
}

Note: Math::Round also includes both of these functions.

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);

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

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;
}

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.

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;
}

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

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.

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.

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, $data) = @_;

    open(my $fh, ">", $file) or return undef;
    binmode($fh, ":encoding(UTF-8)");
    print $fh $data;
    close($fh);

    return length($data);
}

I also implemented a quick version of file_get_contents():

sub file_get_contents {
    open(my $fh, "<", $_[0]) or return undef;
    binmode($fh, ":encoding(UTF-8)");

    my $array_mode = ($_[1]) || (!defined($_[1]) && wantarray);

    if ($array_mode) { # Line mode
        my @lines  = readline($fh);

        # Right trim all lines
        foreach my $line (@lines) { $line =~ s/[\r\n]+$//; }

        return @lines;
    } else { # String mode
        local $/       = undef; # Input rec separator (slurp)
        return my $ret = readline($fh);
    }
}

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.

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;

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.

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;
}

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;

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);

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>

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])/;

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

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.

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);

Here is a similar function written in Python 3.x:

xarray = qw("reg blue green orange yellow")

def qw(xstr):
    ret = xstr.strip().split()

    return ret

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 "" and 0.

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

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.

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, $txt) = @_;

    # 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"; }
    if ($txt)         { $ret .= $txt . "\e[0m";   }

    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

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

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.

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;
}

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;
}

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.

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.

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.

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);
    }
}

Or you can use AUTOLOAD to only load the module if you actually call k()

sub AUTOLOAD { 
    our $AUTOLOAD; # keep 'use strict' happy

    if ($AUTOLOAD eq 'main::k' || $AUTOLOAD eq 'main::kd') {
        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);
        }

        eval($AUTOLOAD . '(@_)');
    }
}

These functions should mimic some Krumo functionality.

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);

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);

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;
}

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.

Simple Perl function to tell if a string is numeric.

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

    return 0
}

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"'

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

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

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

    return 0;
}

Alternately you can use grep which in some cases can be faster:

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

    my $ret = grep { $_ eq $needle; } @haystack;

    return $ret;
}

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

Simple code to get the current uptime in days.

sub get_uptime {
   open(FILE,'/proc/uptime');
   my $line = <FILE>;
   close FILE;

   # The first value is seconds of uptime, not sure about the second
   my ($seconds,$foo) = split(/\s+/,$line);

   # Convert seconds to days
   my $ret = int($seconds / (3600 * 24));

   return $ret;
}

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 (!defined($size)) { return undef; }

    if    ($size >= (1024**5) * 0.98) { $size = sprintf("%.1fP", $size / 1024**5); }
    elsif ($size >= (1024**4) * 0.98) { $size = sprintf("%.1fT", $size / 1024**4); }
    elsif ($size >= (1024**3) * 0.98) { $size = sprintf("%.1fG", $size / 1024**3); }
    elsif ($size >= (1024**2) * 0.98) { $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;
}

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!

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; }
   }
}

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;
}

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},
    ],
);

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.

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

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;

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

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;
}

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;
}