newspaint

Documenting Problems That Were Difficult To Find The Answer To

Category Archives: Perl

Perl WWW::Mechanize or LWP::UserAgent and AWS SSL Handshake Failure

TL;DR (too long, didn’t read) summary:

Force protocol and cipher:

my $ua = WWW::Mechanize->new();
$ua->ssl_opts(
  'SSL_version' => 'TLSv1_2',
  'SSL_cipher_list' => 'ECDHE-RSA-AES256-GCM-SHA384',
);

I had a script using WWW::Mechanize (which uses LWP::UserAgent under the hood) which used to work with a website. But then the website was moved and hosted on Amazon Web Services.

Suddenly my script started reporting:

SSL connect attempt failed error:14077410:SSL routines:SSL23_GET_SERVER_HELLO:sslv3 alert handshake failure at /usr/share/perl5/LWP/Protocol/http.pm line 47.

I tried debugging using a technique I found elsewhere and that was providing a command line switch to enable SSL debugging:

$ perl -MIO::Socket::SSL=debug4 myscript.pl
DEBUG: .../IO/Socket/SSL.pm:2700: new ctx 53819024
DEBUG: .../IO/Socket/SSL.pm:612: socket not yet connected
DEBUG: .../IO/Socket/SSL.pm:614: socket connected
DEBUG: .../IO/Socket/SSL.pm:636: ssl handshake not started
DEBUG: .../IO/Socket/SSL.pm:669: using SNI with hostname www.thetarget.domain
DEBUG: .../IO/Socket/SSL.pm:704: request OCSP stapling
DEBUG: .../IO/Socket/SSL.pm:723: set socket to non-blocking to enforce timeout=15
DEBUG: .../IO/Socket/SSL.pm:736: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:739: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:749: ssl handshake in progress
DEBUG: .../IO/Socket/SSL.pm:759: waiting for fd to become ready: SSL wants a read first
DEBUG: .../IO/Socket/SSL.pm:779: socket ready, retrying connect
DEBUG: .../IO/Socket/SSL.pm:736: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:739: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:742: SSL connect attempt failed

DEBUG: .../IO/Socket/SSL.pm:742: local error: SSL connect attempt failed error:14077410:SSL routines:SSL23_GET_SERVER_HELLO:sslv3 alert handshake failure
DEBUG: .../IO/Socket/SSL.pm:745: fatal SSL error: SSL connect attempt failed error:14077410:SSL routines:SSL23_GET_SERVER_HELLO:sslv3 alert handshake failure
DEBUG: ...erl5/Net/HTTPS.pm:69: ignoring less severe local error 'IO::Socket::IP configuration failed', keep 'SSL connect attempt failed error:14077410:SSL routines:SSL23_GET_SERVER_HELLO:sslv3 alert handshake failure'
DEBUG: .../IO/Socket/SSL.pm:2733: free ctx 53819024 open=53819024
DEBUG: .../IO/Socket/SSL.pm:2738: free ctx 53819024 callback
DEBUG: .../IO/Socket/SSL.pm:2745: OK free ctx 53819024

I tried capturing the session with tcpdump and viewing the session in Wireshark to make sense of what was happening:

time=0.291136 client>server protocol=TLSv1.2 message=Client Hello
time=0.581841 server>client protocol=TLSv1.2 message=Alert (Level: Fatal, Description: Handshake Failure)

So basically AWS was outright rejecting the “Client Hello” packet without any negotiation at all. Neither was it citing a reason for the handshake failure.

At this point it became guesswork. Initially I considered forcing the protocol using the ssl_opts() function:

my $ua = WWW::Mechanize->new();
$ua->ssl_opts(
  'SSL_version' => 'TLSv1_2',
);

But this gave exactly the same result.

Then I thought about forcing the cipher. But to which cipher? I looked up Amazon’s list of accepted ciphers but that didn’t help much. You can try running the following but it gives too many options:

$ openssl ciphers
ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA:ECDHE-ECDSA-AES256-SHA:SRP-DSS-AES-256-CBC-SHA:SRP-RSA-AES-256-CBC-SHA:SRP-AES-256-CBC-SHA:...

So then I tried doing a connect using openssl to see what cipher it chose:

$ # note you can also add the -servername <domain> option for SNI
$ openssl s_client -connect www.thetarget.domain:443
...
New, TLSv1/SSLv3, Cipher is ECDHE-RSA-AES256-GCM-SHA384
Server public key is 2048 bit
Secure Renegotiation IS supported
Compression: NONE
Expansion: NONE
No ALPN negotiated
SSL-Session:
    Protocol  : TLSv1.2
    Cipher    : ECDHE-RSA-AES256-GCM-SHA384
...

So I then tried my Perl script setting the cipher to that reported by openssl:

my $ua = WWW::Mechanize->new();
$ua->ssl_opts(
  'SSL_version' => 'TLSv1_2',
  'SSL_cipher_list' => 'ECDHE-RSA-AES256-GCM-SHA384',
);

This time my script worked!

$ perl -MIO::Socket::SSL=debug4 myscript.pl
DEBUG: .../IO/Socket/SSL.pm:2700: new ctx 38327392
DEBUG: .../IO/Socket/SSL.pm:612: socket not yet connected
DEBUG: .../IO/Socket/SSL.pm:614: socket connected
DEBUG: .../IO/Socket/SSL.pm:636: ssl handshake not started
DEBUG: .../IO/Socket/SSL.pm:669: using SNI with hostname www.thetarget.domain
DEBUG: .../IO/Socket/SSL.pm:704: request OCSP stapling
DEBUG: .../IO/Socket/SSL.pm:723: set socket to non-blocking to enforce timeout=15
DEBUG: .../IO/Socket/SSL.pm:736: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:739: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:749: ssl handshake in progress
DEBUG: .../IO/Socket/SSL.pm:759: waiting for fd to become ready: SSL wants a read first
DEBUG: .../IO/Socket/SSL.pm:779: socket ready, retrying connect
DEBUG: .../IO/Socket/SSL.pm:736: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:2601: did not get stapled OCSP response
DEBUG: .../IO/Socket/SSL.pm:2554: ok=1 [2] /O=Digital Signature Trust Co./CN=DST Root CA X3/O=Digital Signature Trust Co./CN=DST Root CA X3
DEBUG: .../IO/Socket/SSL.pm:2554: ok=1 [1] /O=Digital Signature Trust Co./CN=DST Root CA X3/C=US/O=Let's Encrypt/CN=Let's Encrypt Authority X3
DEBUG: .../IO/Socket/SSL.pm:2554: ok=1 [0] /C=US/O=Let's Encrypt/CN=Let's Encrypt Authority X3/CN=www.thetarget.domain
DEBUG: .../IO/Socket/SSL.pm:1664: scheme=www cert=40017248
DEBUG: .../IO/Socket/SSL.pm:1674: identity=www.thetarget.domain cn=www.thetarget.domain alt=2 www.thetarget.domain
DEBUG: .../IO/Socket/SSL.pm:739: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:749: ssl handshake in progress
DEBUG: .../IO/Socket/SSL.pm:759: waiting for fd to become ready: SSL wants a read first
DEBUG: .../IO/Socket/SSL.pm:779: socket ready, retrying connect
DEBUG: .../IO/Socket/SSL.pm:736: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:739: done Net::SSLeay::connect -> 1
DEBUG: .../IO/Socket/SSL.pm:794: ssl handshake done

Converting Raw Bytes Into Int32, Int16, UInt32, UInt16

If you find yourself processing raw bytes and want to decode signed and unsigned integers then the following routines will help.

Network-Ordered (Big Endian) Encoded Numbers

Note that the following code is for network-ordered (big endian) numbers.

In order to verify the routines coded are correct we can specify tests (test-driven development) to check they do what we expect – particularly at the boundary conditions:

use Test::More;

is( str_to_uint32( "\x00\x00\x00\x01" ),          1, "uint32 1" );
is( str_to_uint32( "\xFF\xFF\xFF\xFF" ), 4294967295, "uint32 4294967295" );
is( str_to_uint16( "\x00\x01" ),                  1, "uint16 1" );
is( str_to_uint16( "\xFF\xFF" ),              65535, "uint16 65535" );
is( str_to_int32( "\x00\x00\x00\x01" ),           1, "int32 1" );
is( str_to_int32( "\xFF\xFF\xFF\xFF" ),          -1, "int32 -1" );
is( str_to_int32( "\x7F\xFF\xFF\xFF" ),  2147483647, "int32 2147483647" );
is( str_to_int32( "\x80\x00\x00\x00" ), -2147483648, "int32 -2147483648" );
is( str_to_int16( "\x00\x01" ),                   1, "int16 1" );
is( str_to_int16( "\xFF\xFF" ),                  -1, "int16 -1" );
is( str_to_int16( "\x7F\xFF" ),               32767, "int16 32767" );
is( str_to_int16( "\x80\x00" ),              -32768, "int16 -32768" );

Decoding network-ordered unsigned integers is very easy in Perl with the unpack() function. For documentation see the pack() function and perlpacktut tutorial pages.

sub str_to_uint32 {
  return unpack( "N", $_[0] ); # "N" for "Network" order (big-endian)
}

sub str_to_uint16 {
  return unpack( "n", $_[0] ); # "n" for "Network" order (big-endian)
}

Decoding network-ordered signed integers is slightly more difficult as the pack() function does not appear to directly support such encodings. Instead we can convert a decoded unsigned representation and, if negative, apply twos’ compliment. From the Wikipedia page:

Conveniently, another way of finding the two’s complement of a number is to take its ones’ complement and add one.

The corollary is that to decode a negative number we take the ones’ compliment and subtract one. We use the pragma use integer; to ensure that bit flipping is done on integral values, not floating-point.

sub str_to_int32 {
  use integer;

  my $num = str_to_uint32( $_[0] );
  if ( $num & 0x80000000 ) {
    $num = 0 - ( ( ( ~ $num ) & 0xFFFFFFFF ) + 1 );
  }

  return $num;
}

sub str_to_int16 {
  use integer;

  my $num = str_to_uint16( $_[0] );
  if ( $num & 0x8000 ) {
    $num = 0 - ( ( ( ~ $num ) & 0xFFFF ) + 1 );
  }

  return $num;
}

Upon running our tests we get the following output:

me@myhost:~ $ perl -w test_functions.pl
ok 1 - uint32 1
ok 2 - uint32 4294967295
ok 3 - uint16 1
ok 4 - uint16 65535
ok 5 - int32 1
ok 6 - int32 -1
ok 7 - int32 2147483647
ok 8 - int32 -2147483648
ok 9 - int16 1
ok 10 - int16 -1
ok 11 - int16 32767
ok 12 - int16 -32768

Little Endian Encoded Numbers

The same routines can be used with a minor differences. Firstly setting up our tests:

use Test::More;

is( str_to_uint32( "\x01\x00\x00\x00" ),          1, "uint32 1" );
is( str_to_uint32( "\xFF\xFF\xFF\xFF" ), 4294967295, "uint32 4294967295" );
is( str_to_uint16( "\x01\x00" ),                  1, "uint16 1" );
is( str_to_uint16( "\xFF\xFF" ),              65535, "uint16 65535" );
is( str_to_int32( "\x01\x00\x00\x00" ),           1, "int32 1" );
is( str_to_int32( "\xFF\xFF\xFF\xFF" ),          -1, "int32 -1" );
is( str_to_int32( "\xFF\xFF\xFF\x7F" ),  2147483647, "int32 2147483647" );
is( str_to_int32( "\x00\x00\x00\x80" ), -2147483648, "int32 -2147483648" );
is( str_to_int16( "\x01\x00" ),                   1, "int16 1" );
is( str_to_int16( "\xFF\xFF" ),                  -1, "int16 -1" );
is( str_to_int16( "\xFF\x7F" ),               32767, "int16 32767" );
is( str_to_int16( "\x00\x80" ),              -32768, "int16 -32768" );

All we have to do is simply change two functions:

sub str_to_uint32 {
  return unpack( "V", $_[0] ); # "V" for "VAX" order (little-endian)
}

sub str_to_uint16 {
  return unpack( "v", $_[0] ); # "v" for "VAX" order (little-endian)
}

Upon running our tests we get the following output:

me@myhost:~ $ perl -w test_functions.pl
ok 1 - uint32 1
ok 2 - uint32 4294967295
ok 3 - uint16 1
ok 4 - uint16 65535
ok 5 - int32 1
ok 6 - int32 -1
ok 7 - int32 2147483647
ok 8 - int32 -2147483648
ok 9 - int16 1
ok 10 - int16 -1
ok 11 - int16 32767
ok 12 - int16 -32768

Debugging LWP::UserAgent in Perl 5

Over the years the way of dumping the sent and received headers of HTTP requests changed. It used to be the following line added to your script would result in headers being dumped:

use LWP::Debug qw(+);

But more recently the approach has been to add handlers to the user agent, e.g.:

$ua->add_handler(
  "request_send",
  sub {
    my $msg = shift;              # HTTP::Message
    $msg->dump( maxlength => 0 ); # dump all/everything
    return;
  }
);

$ua->add_handler(
  "response_done",
  sub {
    my $msg = shift;                # HTTP::Message
    $msg->dump( maxlength => 512 ); # dump max 512 bytes (default is 512)
    return;
  }
);

The dump() function is documented in the HTTP::Message module.

The dump() function has a few options that can be provided:

  • maxlength – maximum number of bytes to display, zero for unrestricted (all)
  • no_content – a string to replace “(no content)” with
  • prefix – a string to prepend to each line dumped

The handlers available are documented in the LWP::UserAgent module and are:

  • request_preprepare
  • request_prepare
  • request_send
  • response_header
  • response_data
  • response_done
  • response_redirect

A Utility to Convert Date Formats

The following Perl script converts from various forms to various forms:

#!/usr/bin/perl -w

use Time::Local;
use Date::Parse;

use strict;

sub help {
  print( STDERR "parsedate.pl - Utility for converting date formats\n" );
  print( STDERR "\n" );
  print( STDERR "Enter a date in one of the following formats:\n" );
  print( STDERR "  epoch: 1526615052 - time in seconds past 1 Jan 1970 UTC\n" );
  print( STDERR "  javaepoch: 1526615092916 - time in ms past 1 Jan 1970 UTC\n" );
  print( STDERR "\n" );
}

sub display_time {
  my ( $epoch ) = @_;

  printf( "\n" );

  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);

  my @ltime = localtime( $epoch );
  my @gtime = gmtime( $epoch );

  my $min_diff = ( $ltime[2] - $gtime[2] ) * 60;
  $min_diff += ( $ltime[1] - $gtime[1] );
  if ( $ltime[3] != $gtime[3] ) {
    if ( $ltime[3] == ( $gtime[3] + 1 ) ) {
      $min_diff += ( 24 * 60 );
    } elsif ( $gtime[3] == ( $ltime[3] + 1 ) ) {
      $min_diff -= ( 24 * 60 );
    } elsif ( $ltime[3] == 1 ) {
      $min_diff += ( 24 * 60 );
    } else {
      $min_diff -= ( 24 * 60 );
    }
  }

  my $sign = "+";
  if ( $min_diff <= 0 ) {
    $min_diff = ( 0 - $min_diff );
    $sign = "-";
  }

  my $tz_hour = int( $min_diff / 60 );
  my $tz_min = $min_diff - ( $tz_hour * 60 );

  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @ltime;

  my $iso8601;
  $iso8601 = sprintf(
    "%04d-%02d-%02dT%02d:%02d:%02d%s%02d:%02d",
    $year + 1900, $mon + 1, $mday,
    $hour, $min, $sec, $sign, $tz_hour, $tz_min
  );

  printf( "Local time:\n" );
  printf( "  %s\n", $iso8601 );
  printf( "  %s\n", scalar( localtime( $epoch ) ) );
  printf( "\n" );

  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @gtime;
  $iso8601 = sprintf(
    "%04d-%02d-%02dT%02d:%02d:%02dZ",
    $year + 1900, $mon + 1, $mday,
    $hour, $min, $sec
  );

  printf( "GMT/UTC:\n" );
  printf( "  %s\n", $iso8601 );
  printf( "  %s\n", scalar( gmtime( $epoch ) ) );
  printf( "  %d\n", $epoch );
  printf( "\n" );
}

sub main {
  # Join command line arguments into a single string
  my $input = join( " ", @ARGV );

  my $epoch = undef;

  if ( $input =~ m/^\s*$/ ) {
    help();

    print( "Using current time as no time string provided.\n\n" );
    $epoch = time();
  } elsif ( $input =~ m/^\d{1,10}$/ ) {
    printf( STDERR "Detected Unix epoch date format\n" );
    $epoch = int( $input );
  } elsif ( $input =~ m/^\d{13}$/ ) {
    printf( STDERR "Detected Java epoch (in ms) date format\n" );
    $epoch = ( int( $input ) / 1000.00 );
  } else {
    printf( STDERR "Trying to parse date string...\n" );
    $epoch = Date::Parse::str2time( $input );
  }

  if ( ! $epoch ) {
    die( "Failed to parse date" );
  }

  display_time( $epoch );
}

main();

Installing Selenium for Perl on Ubuntu 16.04

First I had to download the “Selenium Standalone Server” (a Java .jar file) from the Selenium download page (version 3.5.3 as of writing this article).

Then I ensured I had a JRE (Java run-time environment) by executing:

~$ sudo apt-get install openjdk-9-jre

I also downloaded the Mozilla GeckoDriver from the download page specified above (version 0.18.0 as of writing this article). I then extracted geckodriver-v0.18.0-linux64.tar.gz (the geckodriver executable) into the same folder as the Java Selenium Standalone Server .jar.

~$ cd /opt/selenium
~$ tar -xvjf geckodriver-v0.18.0-linux64.tar.gz

I started up the Java Selenium Standalone Server in a different terminal window by running:

~$ cd /opt/selenium
~$ $ java -jar selenium-server-standalone-3.5.3.jar
2017-09-02 04:35:00.772:INFO::main: Logging initialized @601ms to org.seleniumhq.jetty9.util.log.StdErrLog
2017-09-02 04:35:00.973:INFO:osjs.Server:main: jetty-9.4.5.v20170502
2017-09-02 04:35:00.991:WARN:osjs.SecurityHandler:main: ServletContext@o.s.j.s.ServletContextHandler@77f1baf5{/,null,STARTING} has uncovered http methods for path: /
2017-09-02 04:35:00.995:INFO:osjsh.ContextHandler:main: Started o.s.j.s.ServletContextHandler@77f1baf5{/,null,AVAILABLE}
2017-09-02 04:35:01.012:INFO:osjs.AbstractConnector:main: Started ServerConnector@87a85e1{HTTP/1.1,[http/1.1]}{0.0.0.0:4444}
2017-09-02 04:35:01.012:INFO:osjs.Server:main: Started @845ms

Next I installed a package for Perl support of Selenium by downloading the CPAN package Selenium-Remote-Driver v1.20 (25 May 2017) and extracting the file Selenium-Remote-Driver-1.20.tar.gz and running the following commands:

~$ sudo apt-get install libwww-perl libarchive-zip-perl libfile-which-perl libio-string-perl libjson-perl libmoo-perl libxml-simple-perl libtry-tiny-perl libsub-install-perl libtest-longstring-perl libnamespace-clean-perl make
~$ cd /opt/selenium
~$ tar -xvjf Selenium-Remote-Driver-1.20.tar.gz
~$ cd Selenium-Remote-Driver-1.20
~$ perl -w Makefile.PL
~$ make

Then I wrote a test script:

#!/usr/bin/perl -w

use lib '/opt/selenium/Selenium-Remote-Driver-1.20/lib';
use Selenium::Remote::Driver;

use strict;

print( "- Connecting to Selenium Server Standalone (Java)...\n" );
my $driver = Selenium::Remote::Driver->new(
  'remote_server_addr' => "localhost",
  'port' => 4444,
  'browser_name' => 'firefox',
);

print( "- Opening Google webpage...\n" );
$driver->get( "http://www.google.com/" );

print( "- Display webpage title on console...\n" );
print $driver->get_title() . "\n";

sub find_and_visit() {
  print( "- Search for 'newspaint'...\n" );
  my $elem = $driver->find_element( "//input[\@name='q']" );
  if ( ! $elem ) {
    print( "Could not find input element with name 'q'.\n" );
    return;
  }

  $elem->send_keys( "newspaint" );
  sleep( 2 );

  my $submit = $driver->find_element(
    "//input[\@value='Google Search']"
  );
  if ( ! $submit ) {
    print( "Could not find Google Search button.\n" );
    return;
  }

  $submit->click();
  sleep( 5 );

  my @anchors = $driver->find_elements( "//a" );
  foreach my $anchor ( @anchors ) {
    my $href = $anchor->get_attribute( "href" );
    next if ( ! $href );

    if ( $href eq "https://newspaint.wordpress.com/" ) {
      print( "Clicking on newspaint blog link...\n" );
      $anchor->click();
      sleep( 5 );
      last;
    }
  }
}

find_and_visit();

print( "Quitting...\n" );
$driver->quit();

Using HTML::Mason With CGI Provider

So you want to use HTML::Mason (version 1) but your web provider gives you cPanel-like access to CGI scripting only?

Download HTML::Mason from CPAN and extract the contents from the /lib directory into your account, say, into a directory called /lib/perl/mason.

Then create a file, /public_html/cgi-bin/mason_handler.cgi, which contains:

#!/usr/bin/perl

use lib $ENV{"DOCUMENT_ROOT"} . "/../lib/perl/mason";
use HTML::Mason::CGIHandler;

my $h = HTML::Mason::CGIHandler->new(
  data_dir => '/tmp/mason_data',
  allow_globals => [qw(%session $u)],
);

$h->handle_request;

Now you want to configure your Apache to use this handler for Perl Mason webpages in the /public_html/mason directory (Apache v2.2):

<Directory /public_html/mason>
  <FilesMatch "\.html$">
    Action html-mason /cgi-bin/mason_handler.cgi
    SetHandler html-mason

    # for Apache 2.2
    Order allow,deny
    Allow from all

    # for Apache 2.4 (see https://httpd.apache.org/docs/2.4/upgrading.html)
    #Require all granted
  </FilesMatch>

  <FilesMatch "^(autohandler|dhandler)$">
    Action html-mason /cgi-bin/mason_handler.cgi
    SetHandler html-mason

    # for Apache 2.2
    Order allow,deny
    Allow from all

    # for Apache 2.4 (see https://httpd.apache.org/docs/2.4/upgrading.html)
    #Require all granted
  </FilesMatch>
</Directory>

Some CGI website providers require additional Perl modules for HTML::Mason to work, these can all be downloaded and extracted from CPAN:

  • Exception/Class.pm
  • Devel/StackTrace.pm
  • Class/Container.pm
  • Class/Data/Inheritable.pm
  • Params/Validate.pm *
  • Params/ValidatePP.pm *

(the files marked with a * are those that can be downloaded from CPAN and use the command perl Makefile –pm to force native perl code generation).

Using Perl to Make Signed Requests to Public Transport Victoria Timetable API

So you want to create an application to access the Public Transport Victoria (PTV) Timetable API.

You’ve followed the instructions and e-mailed a request for a developer ID and an access key; and you’ve received both in an e-mail that contained text similar to the following:

Thank you for your interest in the PTV Timetable API.

Your email address has now been registered and your user Id and API key are
below.

User Id: 2912345

API Key: 4cc12345-ff11-2222-a00a-dd1297cd04aa

Now you want to create a signed request using Perl to access the API.

The following function will take a URL and return a signed URL that can be used to access that URL:

#!/usr/bin/perl -w

use Digest::HMAC;
use Digest::SHA;

use strict;

my $devid = "2912345";
my $apikey = "4cc12345-ff11-2222-a00a-dd1297cd04aa";

sub sign_url {
  my ( $url ) = @_;

  # add ?devid=$devid or &devid=$devid to URL
  $url .= ( index($url, "?") < $[ ) ? "?" : "&";
  $url .= "devid=$devid";

  # strip out base URL from part used in signing
  my $request = $url;
  $request =~ s{^(([a-z]+)://+)?[^/]+}{};

  # calculate signature using API key and URL without base
  #   e.g. sign over a string like "/v3/routes?devid=2912345"
  my $signature = Digest::HMAC::hmac_hex(
      $request,
      $apikey,
      \&Digest::SHA::sha1
  );

  $url .= "&signature=" . $signature;
  return $url;
}

print sign_url( "http://timetableapi.ptv.vic.gov.au/v3/routes" );

This should output the following:

$ perl -w signtest.pl
http://timetableapi.ptv.vic.gov.au/v3/routes?devid=2912345&signature=b7ee928f05499a0016746daef5013dba35224d8e

The example is using an invalid signature and devid, so this example URL will not actually return a page; you will have to provide the access key and devid you received in your e-mail.

Note: it is absolutely essential that you do not change the capitalisation of the access key in this script. While it looks like a hex string it is actually treated as case-sensitive text.

The Perl Hash Assignment Gotcha

Question: what do you get if you run the following Perl script?

use warnings;

my %hash => (
    'name' => 'Jimmy',
);

Answer: you get the message:

Useless use of a constant (name) in void context at hashtest.pl line 3.
Useless use of a constant (Jimmy) in void context at hashtest.pl line 3.

So what went wrong? The answer is simple enough but very easy to miss. You probably wanted to assign to the hash variable – but used the comma operator (=>) instead.

To fix merely use an equals sign only after declaring the hash variable:

use warnings;

my %hash = (
    'name' => 'Jimmy',
);

Filtering EasyList For Hosts-File Style Adblock

If you have an Android (rooted CyanogenMod) phone you may be wondering how to block advertising from your web browser.

You may have heard of the hosts file trick that makes the phone assume certain (advertising) domains are hosted at the localhost (127.0.0.1) – which is the phone itself and not running its own web server and thus will instantly respond to any such requests with a “cannot connect” type response – quickly and simply filtering out advertisement domains.

We can make use of Adblock filtering lists such as EasyList by looking for any whole-domain rules, extracting the domain name, and putting into the hosts file.

The script is as follows:

#!/usr/bin/perl -w

use strict;

my %hosts = ();
while ( <> ) {
    if ( $_ =~ m/^\|\|([a-z][a-z0-9-_.]+\.([a-z]{2,3}))\^\s*$/ ) {
        $hosts{$1} = 1;
    }
}

foreach my $host ( sort keys %hosts ) {
    print( "127.0.0.1\t$host\n" );
}

We can use this by downloading the EasyList (as, say, easylist.txt). Then:

user@host:~> perl filter-easylist-to-hosts.pl easylist.txt >easylist.hosts

As of 2014-08-18 there were 5029 such hosts in the list. You can add them to a hosts.new file. This file should look something like (all domains except localhost are fictionalised in this example):

127.0.0.1	localhost

127.0.0.1	an.advertising.net
127.0.0.1	be.advertised.to
127.0.0.1	more.commercialism.com
...
127.0.0.1	zzz.adverts.biz

You must ensure that your hosts file always has a localhost entry in it.

Next, connect your phone via USB and shell to it. The steps are:

  • push the new hosts file to the SD card (temporary location)
  • shell to the phone, become super user
  • find the /system mount path, remount /system as rw (read-write)
  • copy the old /etc/hosts file (backup)
  • copy the new /sdcard/hosts.new file to /etc/hosts
  • remount /system as ro (read-only)
user@host:~> adb push hosts.new /sdcard/
1572 KB/s (236687 bytes in 0.147s)

user@host:~> adb shell
shell@p880:/ $ su
root@p880:/ # mount |grep system
/dev/block/platform/sdhci-tegra.3/by-name/APP \
  /system \
  ext4 \
  ro,seclabel,noatime,nodiratime,user_xattr,acl,barrier=0,data=ordered,noauto_da_alloc \
  0 0
root@p880:/ # mount -o rw,remount \
  /dev/block/platform/sdhci-tegra.3/by-name/APP \
  /system
root@p880:/ # cd /etc
root@p880:/etc # cp hosts hosts.old
root@p880:/etc # cp /sdcard/hosts.new ./hosts
root@p880:/etc # mount -o ro,remount \
  /dev/block/platform/sdhci-tegra.3/by-name/APP \
  /system
root@p880:/etc # exit
shell@p880:/ $ exit
user@host:~>

Iterating With OpalORB

If you’re using the Perl CORBA interface, OpalORB, and you want to iterate through a list then you have to use iterator objects and process the list some elements at a time.

Here is a method I’ve used for iterating in Perl:

# list all XML files in this folder
my $numPerGrab = 25;
my ($objectItems, $objectItemIterator); # scalars to hold iteration objects
$folder->list_with_patterns(
    +[ "*.xml" ], # pattern_seq
    $numPerGrab, # number per grab
    \$objectItems,
    \$objectItemIterator
);

my $next_n_result = 1;
while ( 1 ) {
    # process this chunk of returned items
    foreach ( @{$objectItems} ) {
        printf( "  - file name \"%s\"\n", $_->name() );
    }

    last if ( ! $next_n_result ); # no more
    last if ( $objectItemIterator->_get_orb ); # iterator not valid

    # get next set of items
    $next_n_result = $objectItemIterator->next_n( $numPerGrab, \$objectItems );
}

# should probably destroy the iterator when done with it
# - but don't know if checking _repo_id is the right way to do it
if ( $objectItemIterator->{_repo_id} ) {
    $objectItemIterator->destroy();
}

The equivalent iteration done in Java would look like:

ObjectItemsHolder objectItems = new ObjectItemsHolder();
ObjectItemIteratorHolder iterator = new ObjectItemIteratorHolder();

int numPerGrab = 25;

folder.list_with_patterns(
    new String[] { "*.xml" }, /* pattern_seq - the sequence of the patterns (ORed) */
    (int)numPerGrab, /* how_many - how many objects will be returned (0 for all) */
    objectItems, /*  items - the sequence of the subitems requested */
    iterator /* iterator - an iterator to retrieve the remaining subitems */
);

ObjectItemIterator recordSet = iterator.value;
bool next_n_result = true;
while ( true ) {
    for ( ObjectItem item: objectItems.value ) {
        System.out.println( "  - " + item.info.name );
    }

    if ( ! next_n_result )
        break;

    if ( recordSet == null )
        break;

    next_n_result = recordSet.next_n( (int)numPerGrab, objectItems );
} while ( 1 );

It is worth noting that when iterating it may be faster to get smaller groups of items than larger. Initially I was trying to pull 500 filenames at a time but I found my script actually performed much faster pulling 25 filenames at a time. A little counter-intuitive but worth testing depending on your circumstances.

There are probably better patterns to use for iteration and by all means leave me a comment if you can demonstrate a better one. But this should get you going if you have no idea where to start.