Showing entries with tag "Perl".

Found 26 entries

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: 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

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

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 21 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+)?_?(\w+)?/g;
    my ($bc)      = $str =~ /on_?(\d+)/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 {
    my $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];
            # Bareword like --verbose with no options
            } else {
                $ret->{$key}++;
            }
        }
    }

    # We're looking for a certain item
    if ($_[0]) { return $ret->{$_[0]}; }

    return $ret;
}
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.

sub array_id {
   my ($needle,@haystack) = @_;
   my $count = 0;

   foreach my $item (@haystack) {
      if ($item eq $needle) {
         return $count;
      }

      $count++;
   }

   return -1;
}
Leave A Reply - 1 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

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

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

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

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.

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

Perlfunc: human_size()

Quicky function to get data size in human readable format.

sub human_size {
   my $size = shift();

   if ($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 > 1) {
      $size = sprintf("%dB",$size);
   }

   return $size;
}
Leave A Reply - 1 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: 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