#!/usr/bin/perl
# Convert hexdump -C like output back to binary.  Supports * lines, wh
+ich
# xxd -r does not (this is the reason for this script).  Assumes good 
+input.

use strict;
use warnings;

my ($off, $line, $asterisk);

while (<>) {
    if (/^([[:xdigit:]]{2,}0)\s+((?:[[:xdigit:]]{2}\s+){1,16})/) {
        if (defined($asterisk)) {
            my $nlines = (hex($1) - hex($off)) / 16 - 1;
            print map { chr hex } split /\s+/, $line x $nlines;
            undef $asterisk;
        }
        print map { chr hex } split /\s+/, $2;
        $off = $1, $line = $2;
    } elsif (/^\*/) {
        $asterisk = 1;
    } else {
        last;
    }
}
[download]

https://github.com/blekko/perl-reduce

and I'm hoping to collect some user experiences for a bit more tweaking before widely advertising it in the perl community. If you have a crasher that you've never narrowed down because it looked too tedious, please give perl-reduce a try.

Twitter recently got rid of the ability to get search results as an RSS as part of their API update of 11 June 2013.

I found those feeds rather useful, so I made a little screen scraper that reimplements the functionality without needing to auth against their API (it just pulls the results out of the web search page). I guess this will be good for a while longer, like enough time to switch to statusnet, identica, or whatever.

It might be of use to some others in the monastry and illustrates the power of HTML::TreeBuilder::XPath.

I run ffmpeg from a windows console. It colors its messages, eg. warnings are (red) yellow and errors are bright red. That's all good, but when I interrupt ffmpeg, it sometimes leaves the console color changed and then all further text in the same console will be written in that color.

The cls command does not restore the color like it used to in some windows versions. Rerunning ffmpeg doesn't help because it checks the console color when it starts and restores that when it exits. I don't wish to close the console and start a new one because that would lose the command history. Thus, I need a separate command to reset the console colors. Here's a simple command to do that (put it into a batch file). Works with ActiveState perl 5.16.1.

perl -we "use Win32::Console; $con = Win32::Console->new(STD_OUTPUT_HA
+NDLE()); $con->Attr($FG_CYAN);"
[download]

I read a lot on this topic. There are solutions for this mater. The most promising involves a module named Number::Format. I found also regexp based solutions, which gave me a headache and which I could not get to work properly. Finally there are millions of fancy code bits around for this purpose. There is also one solution to forget definitively: sprintf!

The solution I am posting here is thought for web-application. Web-application written in PERL have performance issues and unfortunately performance, meaning user perceived response times, are THE acceptance factor for your application. To solve this issue we fortunately have a wonderful Apache module named mod_perl.

Mod_perl can be tuned by loading modules into memory with the PerlModule directive. However you can not load infinitely modules in memory, since it is a scarce resource (more information on http://perl.apache.org/docs/1.0/guide/performance.html). Therefore I discarded the Number::Format module solution, which holds much more functions than what I need.

A web-application can have two layers of validation and formating. The first layer being the browser, the second being the PERL code on the server. The best is of course to validate and format your data at both layer. Therefor I was looking for a solution in JavaScript and one in PERL, which would be similar. So I realized them...

Here the JavaScript function:

<script type='text/javascript'>
    function formatNumber(myElement) { // JavaScript function to inser
+t thousand separators
        var myVal = ""; // The number part
        var myDec = ""; // The digits pars
        // Splitting the value in parts using a dot as decimal separat
+or
        var parts = myElement.value.toString().split(".");
        // Filtering out the trash!
        parts[0] = parts[0].replace(/[^0-9]/g,""); 
        // Setting up the decimal part
        if ( ! parts[1] && myElement.value.indexOf(".") > 1 ) { myDec 
+= ".00" }
        if ( parts[1] ) { myDec = "."+parts[1] }
        // Adding the thousand separator
        while ( parts[0].length > 3 ) {
            myVal = "'"+parts[0].substr(parts[0].length-3, parts[0].le
+ngth )+myVal;
            parts[0] = parts[0].substr(0, parts[0].length-3)
        }
        myElement.value = parts[0]+myVal+myDec;
    }
</script>

<!-- in the html page -->
<input name="amount" id="amount" type="text" onkeyup="formatNumber(thi
+s);">
[download]

The same function in PERL

sub thousandformat { # Formats number with thousand separators
    my ($number) = @_;
    my $currnb = "";
    my ($mantis, $decimals) = split(/\./, $number, 2);
    $mantis =~ s/[^0-9]//g;
    while ( length($mantis) > 3 ) {
        $currnb = "'".(substr($mantis, length($mantis)-3, 3 )).$currnb
+;
        $mantis = substr($mantis, 0, length($mantis)-3);
    }
    $currnb = $mantis.$currnb;
    if ( $decimals ) { $currnb .= ".".$decimals; }
    else { $currnb .= ".00"; }
    return $currnb;
}
[download]

Enjoy

K

I've put together a new perl module on CPAN called Yote. It directly and automatically binds javascript client objects to perl server objects. The objects are container objects that live in an object database. The objects are lazily loaded as needed and are automatically stored with their contents automatically. The following example works out of the box as long as the Hello package is in the Yote server's perl classpath. The hello count will be preserved in Yote's data store.

package Hello;
use base 'Yote::AppRoot';

sub hello {
  my( $self, $input ) = @_;
  $self->set_hello_count( $self->get_hello_count( 0 ) + 1 );
  return "Hello $input, I have said hello ". 
        $self->get_hello_count() . " times";
}

1;
[download]

$.yote.init();

var hello_app = $.yote.fetch_app( 'Hello' );

alert( hello_app.hello( prompt( "What is your name?" ) ) );
[download]

This wasn't the first time the MTU sizes had been monkeyed with, so I decided to throw something together that might help us identify MTU problems more quickly.

I'd found Network Duplex speed test so, I used much of that for the actual ping packet creation, which referenced Net::Ping code, so I also compared the current version of that against what was given in the duplex test node. Then I had to figure out how to turn on the don't fragment flags of the packet. Anyway, the results are below.

Hopefully someone else will find this useful.

-Scott

I had a bunch of music lyrics that I wanted to print and I didn't want to manually drive gedit. I did, however, want to retain the document formatting. I found a hint in Re^2: using Brother QL-570 printer with Perl and also found sample commands in an Ubuntu Community Documentation post for using the Open Office command line interface for batch printing or viewing. The are also posts out there for doing a similar thing with MS-Word.

The following is what I threw together. It does the job for me, YMMV. I needed to print UTF-8 text files, but Open Office will try to print whatever file you give it using the file extension as a guide to the file format. I have also printed .odt files.

James

use v5.12;
use PPI;
use Perl::Critic::Utils;
use Acme::MetaSyntactic;

my $meta = "Acme::MetaSyntactic"->new("haddock");

my $input = <<'CODE';
use Foo qw(imported_func);

sub announce {
    my $val = shift @_;
    print "$val\n";
}

my @list = qw( foo bar baz );
for my $i (0 .. $#list) {
    my $value = imported_func($list[$i]);
    announce($value) if __PACKAGE__->can("announce");
}
CODE

my $doc = "PPI::Document"->new(\$input);
my (%names, %localsub);

for my $word (@{ $doc->find("PPI::Token::Word")||[] })
{
    if ($word->sprevious_sibling eq "sub")
    {
        $localsub{$word}++;
    }
}

for my $word (@{ $doc->find("PPI::Token::Word")||[] })
{
    my $case =
        ($word eq uc $word) ? sub { uc $_[0] } :
        ($word eq lc $word) ? sub { lc $_[0] } : sub { $_[0] };
    
    if (Perl::Critic::Utils::is_perl_builtin($word))
    {
        next;
    }
    elsif ($word->sprevious_sibling eq "sub" and $localsub{$word})
    {
        $word->set_content($names{$word} ||= $case->($meta->name));
    }
    elsif (Perl::Critic::Utils::is_function_call($word) and $localsub{
+$word})
    {
        $word->set_content($names{$word} ||= $case->($meta->name));
    }
}

for my $word (@{ $doc->find(sub { $_[1]->isa("PPI::Token::Symbol") or 
+$_[1]->isa("PPI::Token::ArrayIndex") })||[] })
{
    next if $word->isa("PPI::Token::Magic");
    
    my $case =
        ($word eq uc $word) ? sub { uc $_[0] } :
        ($word eq lc $word) ? sub { lc $_[0] } : sub { $_[0] };
    
    (my $sigil = "$word") =~ s/(\w.*)$//g;
    my $rest = $1;
    
    if ($word->isa("PPI::Token::Symbol"))
    {
        $names{$word->symbol} ||= $case->($meta->name);
        $word->set_content($sigil . $names{$word->symbol});
    }
    else
    {
        $names{"\@$rest"} ||= $case->($meta->name);
        $word->set_content($sigil . $names{"\@$rest"});
    }
}

for my $qq (@{ $doc->find(sub { $_[1]->isa("PPI::Token::Quote::Double"
+) or $_[1]->isa("PPI::Token::Quote::Interpolate") })||[] })
{
    my $txt = "$qq";
    
    if ($localsub{$qq->string})
    {
        $txt =~ s/${\quotemeta($qq->string)}/$names{$qq->string}/eg;
    }
    else
    {
        $txt =~ s/([\$\@]\w+)/$names{$1}?substr($1,0,1).$names{$1}:$1/
+eg;
    }
    
    $qq->set_content($txt);
}

print $doc;

__END__
use Foo qw(imported_func);

sub cry_babies {
    my $numbskulls = shift @_;
    print "$numbskulls\n";
}

my @two_timing_troglodytes = qw( foo bar baz );
for my $cheat (0 .. $#two_timing_troglodytes) {
    my $gyroscope = imported_func($two_timing_troglodytes[$cheat]);
    cry_babies($gyroscope) if __PACKAGE__->can("cry_babies");
}
[download]

(Updated to add support for tracking locally defined versus imported functions; and ->can support.)

One specific question is how to capture STDERR and assign it to the remote host it came from. (I haven't spent much time investigating this issue, so there's probably some easy fix I've overlooked.)

Here's the script:

UAV::Pilot is a Perl library for controlling UAVs. It currently works with the Parrot AR.Drone, with plans to expand to others in the future.

Demo video

The current library supports basic commands, such as takeoff, pitch, roll, yaw, vert speed, and land. All the preprogrammed flight animations are also in place. Navigation data and video are not yet supported–see the ROADMAP file for future plans.

Github repository: https://github.com/frezik/UAV-Pilot

CPAN: https://metacpan.org/module/TMURRAY/UAV-Pilot-0.1/lib/UAV/Pilot.pm

I spend today reading about how to pipe a mail received by postfix into a perl script. I read a lot but could hardly find a solution for my setup. So I give one here.

The case

An application must be able to process email coming in from the net and it must be also able to respond to these emails.

The setup:

• The machine is configured to send all emails over an MTA somewhere in the network
• The MTA hosts a virtual mail domain for which it forwards all its email to the machine
• The machine holds an application written in PERL
• A PERL script īs used as delivery agent to process some mails
• The tested platform: Linux Ubuntu 12.04 LTS, postfix 2.9.6

The postfix main.cf configuration created by dpkg-reconfigure postfix

    myhostname = [host name]
    alias_maps = hash:/etc/aliases
    alias_database = hash:/etc/aliases
    myorigin = /etc/mailname
    mydestination = [list for local delivery]
    relayhost = [the MTA name for sending emails]
    mynetworks = [see posfix documentation]
    mailbox_size_limit = [you would rather set it!]
    recipient_delimiter = +
    inet_interfaces = all
    inet_protocols = ipv4
    mail_spool_directory = /var/mail
[download]

My solution:

As usual TIMTOWTDI but a simple alias will NOT work! My solution works without:

• A cryptic central definition of a local delivery agent in master.cf
• Having pcre compiled in postfix. I have no use for this.
• Creating OS users or virtual users on the system.
• No other ugly things I read.

Now you have to:

• Modify your main.cf to redirect the mail.
• Create a redirect map for postfix
• Create an alias which will fool postfix and deliver the mail to the script

Modifications to the main.cf configuration

To avoid creating whatsoever users, we will use a kind of redirect. So we add a line like the following to the main.cf file:

Notice the hash: prefix to the file. This works well and avoid to re-compile postfix with pcre, in case it is not included.

Creation of the redirect map

Create the file defined above and enter a line with a regexp and a name in it:

Notice you have to use a regexp as first argument on this line! The alias name does not matter. Only secure name@domain is the correct email address.

Creation of the alias

Now we create the alias which will pipe the email into our script. Add a line like the following to the /etc/aliases file:

Notice you have to secure both alias name match!

Activate the whole thing

To activate all this you have to

• Create your redirect map with postmap [path to ]/redirect
• Activate your new aliases with newaliases
• Load the new posfix configuration with posfix reload

The result

This is what you will get in the STDIN of your script

   From [who ever]@[whatever].com  Mon Apr 22 17:48:08 2013
   Return-Path: <[who ever]@[whatever].com >
   X-Original-To: [name]@[machine domain]
   Delivered-To: [name]@[machine domain]
   Received: by [No matter to you]
   To: <[name]@[machine domain]>
   Subject: [What so ever]
   X-Mailer: mail (GNU Mailutils 2.2)
   Message-Id: <20130422154808.4100143A9@lap01>
   Date: Mon, 22 Apr 2013 17:48:08 +0200 (CEST)
   From: [who ever]@[whatever].com
   
   lkjahsdlfkjhlahsdf
   lkjahdsflkjhasdlfh
   lkjahsdflkjhsaldfhk
[download]

Notice: If you intent to open(OUT ">", $filename); in your PERL script it will fail with a missing privilege error. To avoid this you have to set default_privs = to an other user than nobody in the postfix main.cf. This has impact on the whole postfix setting. I did not analyse it until now. So if you do this, you do it at your own risk.

Enjoy!

K

Despite an incredible amount of literature on this topic, I could not find a proper solution for this issue. Accordingly I post my one here.

I had to realize a relatively complex web application. This application bases on CGI.pm and mod_perl for performance reasons and supports several languages. I wanted to have one single code for the logic of the application. An additional requirement was be to be able to add languages easily. After reading a lot about solutions involving templates or dictionaries (typically gettext), I figured out using PERL language packages would fulfill most of my requirements. The problem was to load the appropriate language module at application start up time and to allow the user to change the language for example for print outs. Here is the solution I worked out.

First make a set of simple language packages with names like EN.pm, FR.pm, DE.pm. Each of these modules holds hashes with the texts for the application's forms. For this solution to work properly, the hash names must be in lower case. Example for a log in form:

- French in FR.pm: $login{msg1} = "Identifiant";

- German in DE.pm: $login{msg1} = "Benutzername";

- English in EN.pm: $login{msg1} = "User name";

Next use the following at the beginning of each language package to export the content. Example for EN.pm:

This will export all hashes in lower case and avoid for example the EXPORT array. Next you will have to import the correct languages package in your cgi script with a statement like use [Modulename];.

Unfortunaltely you can hardly load modules dynamically and can hardly reference a variable in a module dynamically. Constructs like use $language; or ${language}::login{msg1}; will not work.

Despite lot of posts on this topic, I haven't found a solution to solve this issue. This means so or so I will not be able to load the languages dynamically but will have to manage the supported languages in the code of the application's logic.

My solution bases on a language variable I called syslang. This variable is either set by the calling cgi script or defined by the selected language of the client's browser. I begin my cgi scripts the following way and include a global language variable:

    # ----------------------------------------------------------------
+----------------
    # Script header
    # ----------------------------------------------------------------
+----------------
    # Loading perl modules
    my $start = time();
    use FindBin qw($Bin);
    use File::Basename;
    use Cwd;
    use CGI qw/:standard *table tr td select/;
    use CGI::Carp;
    use CGI::Session;
    use Data::Dumper;
    use strict;
    
    # Our global language variable
    our $syslang = undef;
[download]

Next I add the path to my application or packages to @INC array. My application packages are always in a lib directory. This is also the location of the language packages. For the solution to work the @INC array must be enhanced with a begin block or the script will not compile:

    # Notice: this will work with Apache, cheap web-server might be a 
+serious issue!
    # a) Detect if we are called by the web-server or not
    # b) Set the path accordingty
    BEGIN {
        # Adding application lib path
        my $libdir = undef;
        if ( not defined($ENV{SERVER_NAME}) ) { $libdir = getcwd; }
        else { $libdir = File::Basename::dirname($ENV{SCRIPT_FILENAME}
+); }
        # I know.... but sometimes I am lazy!
        chdir "$libdir/../lib";
        $libdir = getcwd;
        if ( not grep(/$libdir/, @INC) ) { push (@INC, $libdir); }
        undef $libdir;
    }

[download]

Now we need to manage the languages. We need to load the package with the correct texts, knowing the user can change the language of the application. Because of mod_perl we need to unload the language modules first and the reload the correct module to force Apache to recompile the script. Here my solution for this:

    # Setting the language 
    # This one is to fool the compiler! Don't ask!
    use EN;

    # Testing if the language has allready be set or using the one def
+ines by the browser
    # frdlang is my cgi language parameter
    my $q = new CGI;
    if ( $q->param("frdlang") ) { $syslang = uc($q->param("frdlang"));
+ }
    elsif ( not $syslang ) { $syslang = uc(substr($ENV{HTTP_ACCEPT_LAN
+GUAGE}, 0, 2)); }

    # Unloading language modules to force recompiling under mod_perl
    foreach my $lang ( grep(/DE.pm$|FR.pm$|EN.pm$/, keys(%INC)) ) { de
+lete $INC {$lang}; }

    # Loading apropriate language module
    if ( uc($syslang) =~ /^DE/ ) { require DE; DE->import(); }
    elsif ( uc($syslang) =~ /^FR/ ) { require FR; FR->import(); }
    elsif ( uc($syslang) =~ /^EN/ ) { require EN; EN->import(); }

[download]

Now we might have the issue that some packages return some part of the HTML form, tipically the menus. The language of these parts musst also be changed each time the user switches the language. So we need to reload all the modules impacted. Here my solution for this:

    # Unloading the application language related module to force recom
+pile under mod perl
    foreach my $module ( grep(/utils.pm$|install.pm$|login.pm$/, keys(
+%INC)) ) { delete $INC{$module}; }
    
    # setting languages for each modules to load
    $utils::syslang = $syslang;
    $install::syslang = $syslang;
    $login::syslang = $syslang;
    
    # Loading language dependent modules
    require utils; utils->import();
    require install; install->import();
    require login; login->import();

    # ... your cgi code.
[download]

This solution has beed tested extensively however any suggestion for something more decent is welcome.

K.

ppiwx / wxppi show PPI tree, and PPI::Statement::serialize / PPI::Token::HereDoc::here_line_range ## column_number / line_number

wrote it a few years ago to explore PPI, now with color

usage ppiwx utf8file.pl anotherutf8file.pl ...

expects UTF-8 , so whateveryou need to do :) iconv -f UTF-16 -t UTF-8 < in > out or piconv -f UTF-16LE -t UTF-8 < in > out

Code is in spoiler readmore tags :) to download just the code, click "Download Code" below

Update: After posting version 1 the problem of overlapping matches has been bugging me so much I've actually found a solution. Instead of using straight regex substitution I now do all the matching first, then apply the colors afterwards. I've tested it quite a bit but it's still experimental.

#!/usr/bin/perl

use strict;
use warnings;
use Term::ANSIColor;

my @rules = @ARGV;
while (my $line = <STDIN>) {
  print rewrite($line, @rules);
}
exit;

# Process a single line
sub rewrite {
  my $line = shift;
  my @rules = @_;
  my @marks = ();
  # Process each rule and find areas to mark
  while (@rules) {
    my $regex = shift @rules;
    my $color = shift @rules || 'bold yellow';
    $color = color('reset').color($color);
    while ($line =~ /$regex/ig) {
      my $reset = undef;
      # Scan match area to find last color
      foreach my $i (reverse $-[0] .. $+[0]) {
        if (defined $marks[$i]) {
          $reset = $marks[$i] unless defined $reset; 
          $marks[$i] = undef; # Cancel previous color
        }
      }
      # If necessary, keep scanning to beginning of line
      unless (defined $reset) {
        foreach my $i (reverse 0 .. $-[0]) {
          if (defined $marks[$i]) {
            $reset = $marks[$i]; 
            last;
          }
        }
      }
      # Mark area
      $marks[$-[0]] = $color;
      $marks[$+[0]] = $reset || color('reset');
    }  
  }
  # Apply color codes to the string
  foreach my $i (reverse 0 .. $#marks) {
    substr($line, $i, 0, $marks[$i]) if defined $marks[$i];
  }
  return $line;
}

=pod

=head1 NAME

em - console emphasis tool version 2

=head1 DESCRIPTION

em is a command line tool for visually emphasizing text in log files e
+tc. by 
colorizing the output matching regular expressions.
 
=head1 SYNOPSIS

em REGEX1 [COLOR1] [REGEX2 [COLOR2]] ... [REGEXn [COLORn]]

=head1 USAGE

REGEX is any regular expression recognized by Perl. For some shells
this must be enclosed in double quotes ("") to prevent the shell from
interpolating special characters like * or ?.

COLOR is any ANSI color string accepted by Term::ANSIColor, such as
'green' or 'bold red'.

Any number of REGEX-COLOR pairs may be specified. If the number of arg
+uments
is odd (i.e. no COLOR is specified for the last REGEX) em will use 'bo
+ld yellow'.

Overlapping rules are supported. For characters that match multiple ru
+les, 
only the last rule will be applied.

=head1 EXAMPLES

In a system log, emphasize the words "error" and "ok":

=over

tail -f /var/log/messages | em error red ok green

=back

In a mail server log, show all email addresses between <> in white, su
+ccesses in green:

=over

tail -f /var/log/maillog | em "(?<=\<)[\w\-\.]+?\@[\w\-\.]+?(?=\>)" "b
+old white" "stored message|delivered ok" "bold green"

=back

In a web server log, show all URIs in yellow:

=over

tail -f /var/log/httpd/access_log | em "(?<=\"get).+?\s"

=back

=head1 BUGS AND LIMITATIONS

Multi-line matching is not implemented.

All regular expressions are matched without case sensitivity.

=head1 AUTHOR

Andreas Lund <floyd@atc.no>

=head1 COPYRIGHT AND LICENSE

Copyright 2009-2013 Andreas Lund <floyd@atc.no>. This program is free 
+software; 
you may redistribute it and/or modify it under the same terms as Perl 
+itself.

=cut
[download]

Update: There is one other cool way to use this tool, and that's regex testing. Simply type "em" and the regex you want to test. Example:
em "0x[0-9a-f]+"
Now input your test strings one by one, and "em" will show you exactly what matches and what doesn't. Hit Ctrl+D (EOF) to exit.