nice perl tip

I just came across this excellent perl tip. I'm not sure I'd use it exactly as written, but the idea of being able to open perl modules by module name instead of file name is certainly appealing. Now, to figure out how to apply this to other languages too.

simple overrides for quick mocking in perl

A more concrete example (and one I use too frequently) of overriding for testing similar to what is described by Sawyer X at blogs.perl.org: Simple symbol overriding for tests. Of course, my example uses inheritance and re-blessing rather than symbol overriding, but the result is basically the same. I like to use the snippet below to test mail sending functionality by simply printing the resulting mail to stdout.

my $smtp = Net::SMTP->new($mailhost);
...
if ($i_dont_want_to_send_mail) {
  package Mock::SMTP;
  our @ISA = qw(Net::SMTP);

  no strict qw(refs);
  for (qw(mail to data dataend quit)) {
    *$_ = sub { };
  }

  for (qw(datasend)) {
    *$_ = sub { shift; print @_, "\n" }
  }

  # re-bless my Net::SMTP reference to a Mock reference
  $smtp = bless $smtp || {};
}

parallel ssh tool roundup

So I'm in the market for a good "parallel" ssh tool.  Basically, I want to ssh and type some commands like I always do except that instead of one command output, I want the command to be run on a bunch of machines and I want responses from each.  I've used things like mpiexec in the past, but I was hoping for something more ad-hoc.  I just want to specify hosts on the command line (with no prior setup).  I really don't even want to required ssh keys or having the same password if I can avoid it.  Like I said, just ssh as usual, run some commands, get multiple results.

Anyway, these are the tools I've come across (in no particular order).  I'll outline what I regard as the advantages and disadvantages of each below.

1. pdsh - "a high-performance, parallel remote shell utility" from Lawrence Livermore National Laboratory
2. pssh an implementation of some parallel ssh tools in python
3. dsh - dancer's / distributed shell
4. pydsh - a python version of dancer's shell
5. clusterssh - "a tool for making the same change on multiple servers"
6. mussh - "a shell script ... to execute a command or script over ssh on multiple hosts"
7. sshpt - "SSH Power Tool (sshpt) enables you to execute commands and upload files to many servers simultaneously via SSH"
8. multixterm - part of the expect project
9. clusterit - "a collection of clustering tools, to turn your ordinary everyday pile of UNIX workstations into a speedy parallel beast"
10. dish - "The diligence shell 'dish' executes commands via ssh/rsh/telnet/mysql simultaneously on several systems"

doctests for perl

There are several pod testing modules available on cpan.  However, none of them quite meets my needs.

For example, there is Test::Pod::Snippets which is really close, but considers all verbatim sections to be code (by default).

There is also Test::Inline, which allows tests to be in pod sections alongside code as well, but requires explicit testing of results.

Lastly, I found Test::Snippet, which does have a REPL loop but still wasn't quite as lightweight as I wanted.

All of the modules above required some additional non-core dependencies too, which I find irksome.  So, below is my crack at it.

package Test::Doctest;

use 5.005;
use strict;

require Exporter;
require Pod::Parser;
use vars qw(@ISA @EXPORT $VERSION);
@ISA = qw(Exporter Pod::Parser);
@EXPORT = qw(runtests);
$VERSION = '0.01';

use Carp;
use Test::Builder;
use File::Spec::Functions qw(devnull);

=head1 NAME

Test::Doctest - extract and evaluate tests from pod fragments

=head1 SYNOPSIS

  perl -MTest::Doctest -e 'runtests @ARGV' lib/Some/Module.pm

  - or -

  use Test::Doctest;
  runtests($filepath);

  - or -

  use Test::Doctest;
  my $p = Test::Doctest->new;
  $p->parse_from_filehandle(\*STDIN);
  $p->test;

=head1 DESCRIPTION

B<runtests> uses B<Pod::Parser> to extract pod text from the files
specified, evaluates each line begining with a prompt ($ by default),
and finally compares the results with the expected output using
B<is_eq> from B<Test::Builder>.

=head1 EXAMPLES

  $ 1 + 1
  2

  $ my @a = qw(2 3 4)
  3

  $ use Pod::Parser;
  $ my $p = Pod::Parser->new;
  $ ref $p;
  Pod::Parser

=head1 EXPORTS

=head2 B<runtests()>

Extract and run tests from pod for each file argument.

=begin runtests

  $ use Test::Doctest
  $ runtests
  0

=end

=cut

sub runtests {
  my ($total, $success, @tests) = (0, 0);
  my $test = Test::Builder->new;

  for (@_) {
    my $t = Test::Doctest->new;
    $t->parse_from_file($_, devnull);
    $total += @{$t->{tests}};
    push @tests, $t;
  }

  if (!$test->has_plan) {
    $test->plan(tests => $total);
  }

  for (@tests) {
    $success += $_->test == @{$_->{tests}}
  }

  return $success;
}

=head1 METHODS

=head2 B<initialize()>

Initialize this B<Test::Doctest> pod parser. This method is
not typically called directly, but rather, is called by
B<Pod::Parser::new> when creating a new parser.

=begin initialize

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ @{$t->{tests}}
  0

=end

=begin custom prompt

  $ use Test::Doctest
  $ my $t = Test::Doctest->new(prompt => 'abc')
  $ $t->{prompt}
  abc

=end

=cut

sub initialize {
  my ($self) = @_;
  $self->SUPER::initialize;
  $self->{tests} = [];
}

=head2 B<command()>

Override B<Pod::Parser::command> to save the name of the
current section which is used to name the tests.

=begin command

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ $t->command('head1', "EXAMPLES\nthese are examples", 1)
  $ $t->{name}
  EXAMPLES

=end

=cut

sub command {
  my ($self, $cmd, $par, $line) = @_;
  $self->{name} = (split /(?:\r|\n|\r\n)/, $par, 2)[0];
}

=head2 B<textblock()>

Override B<Pod::Parser::textblock> to ignore normal blocks of pod text.

=begin textblock

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ not defined $t->textblock
  1

=end

=cut

sub textblock { }

=head2 B<verbatim()>

Override B<Pod::Parser::verbatim> to search verbatim paragraphs for
doctest code blocks.  Each block found, along with information about
its location in the file and its expected output is appended to the
list of tests to be executed.

=begin verbatim

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ $t->verbatim("  \$ 1+1\n  2", 1)
  1

=end

=begin verbatim no prompt

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ $t->verbatim("abc", 1)
  0

=end

=begin verbatim custom prompt

  $ use Test::Doctest
  $ my $t = Test::Doctest->new(prompt => '#\s+')
  $ $t->verbatim("  # 1+1\n  2", 1)
  1

=end

=cut

sub verbatim {
  my ($self, $par, $line) = @_;
  my $prompt = $self->{prompt} ? $self->{prompt} : '\$\s+';
  my $name = $self->{name} ? $self->{name} : q{};
  my @lines = split /(?:\r|\n|\r\n)/, $par;
  my @code;

  for (@lines) {
    if (/^\s+$prompt(.+)/) {
      # capture code
      push @code, $1;
    } elsif (/^\s+(.+)/ and @code) {
      # on first non-code line, with valid code accumlated
      my $file = $self->input_file ? $self->input_file : 'stdin';
      push @{$self->{tests}}, [$name, $file, $line, $1, @code];
      @code = ();
    } elsif (/^=cut/) {
      # stop processing on =cut (even without a leading blank line)
      last;
    }
  }

  return @{$self->{tests}};
}

=head2 B<test()>

Evaluates each test discovered via parsing and compares the results
with the expected output using B<Test::Builder::is_eq>.

=begin test empty

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ $t->test
  0

=end

=begin test non-empty

  $ use Test::Doctest
  $ my $t = Test::Doctest->new
  $ $t->command('begin', 'test', 1)
  $ $t->verbatim("  \$ 1+1\n  2", 2)
  $ @{$t->{tests}}
  1

=end

=cut

sub test {
  my ($self) = @_;
  my @tests = @{$self->{tests}};
  my $run = 0;
  my $test = Test::Builder->new;

  if (!$test->has_plan) {
    $test->plan(tests => scalar @tests);
  }

  for (@{$self->{tests}}) {
    local $" = ';';
    my ($name, $file, $line, $expect, @code) = @{$_};
    my $result = eval "sub { @code }->()";
    if ($@) {
      croak $@;
    }
    $test->is_eq($result, $expect, "$name ($file, $line)");
    $run++;
  }

  return $run;
}

1;

__END__

=head1 HISTORY

=over 8

=item 0.01

Original version

=back

=head1 SEE ALSO

L<Pod::Parser>, L<Test::Builder>

B<Pod::Parser> defines the parser interface used to extract the tests.

B<Test::Builder> is used to plan the tests and determine the results.

=head1 AUTHOR

Bryan Cardillo E<lt>dillo@cpan.org<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Bryan Cardillo

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

recursive descent json parser in perl

Sure, there are real, fully featured, well tested json parsers out there, but for a brief moment I thought I might need to write my own (why is a different story altogether, but for now I'll just say that trimming dependencies was necessary).

Anyway, after a quick look at the spec (hint, its very simple) and a couple of hours coding, I can now present a reasonably functional (character escapes are missing, might be missing other features as well) recursive descent json parser implementation in perl. This is definitely not the best choice for adding json support to your next perl project, however it is a simple and practical example of recursive descent parsing that others might find useful.

Anecdotally, if eval'ing json input is not a concern (for security reason's it probably should be), you might just substitute arrows (=>) for colon's (:) while reading in json and eval it as an even simpler alternate solution...

#!/usr/bin/env perl
package json;

use 5.006;
use strict;
use warnings;

use Carp;

BEGIN {
    for (qw(file buffer token line pos)) {
        eval "sub $_ : lvalue { \$_[0]->{$_}=\$_[1] if \@_>1;\$_[0]->{$_} }";
        croak $@ if $@;
    }
}

sub new {
    bless { file => *ARGV, line => 0, pos => 0 }, $_[0];
}

sub accept {
    my ($self, $chrs) = @_;
    for (split(//, $chrs)) {
        return 0 unless $self->token eq $_;
        $self->advance;
    }
    return 1;
}

sub expect {
    my ($self, $chrs) = @_;
    $self->accept($chrs) or confess $self->error;
    $self;
}

sub error {
    my ($self) = @_;
    "unexpected token '", $self->token, "' at line ", $self->line, "\n";
}

sub advance {
    my ($self, $ns) = @_;
    for ($self->token = undef; not defined $self->token; $self->pos++) {
        unless ($self->buffer and $self->pos < length($self->buffer)) {
            defined($self->buffer = readline($self->file)) or return;
            $self->line++;
            $self->pos = 0;
        }
        $self->token = substr($self->buffer, $self->pos, 1)
            if ($ns or substr($self->buffer, $self->pos, 1) !~ /[[:space:]]/);
    }
}

sub object {
    my ($self, $object, $key, $val) = @_;
    $key = $self->expect('"')->string;
    $val = $self->expect('"')->expect(':')->value;
    $object->{$key} = $val;
    $self->object($object) if $self->accept(',');
    $object;
}

sub array {
    my ($self, $array) = @_;
    push @$array, $self->value;
    $self->array($array) if $self->accept(',');
    $array;
}

sub string {
    my ($self, $str) = @_;
    do {
        $str .= $self->token;
        $self->advance(1);
    } while ($self->token ne '"');
    $str;
}

sub digits {
    my ($self, $d) = @_;
    do {
        $d .= $self->token;
        $self->advance(1);
    } while ($self->token =~ /[[:digit:]]/);
    $d;
}

sub number {
    my ($self, $n) = @_;
    $n .= '-' if ($self->accept('-'));
    $n .= $self->digits();
    if ($self->accept('.')) {
        $n .= '.';
        $n .= $self->digits();
    }
    if ($self->accept('e') or $self->accept('E')) {
        $n .= 'e';
        if ($self->accept('+')) {
            $n .= '+';
        } elsif ($self->accept('-')) {
            $n .= '-';
        }
        $n .= $self->digits();
    }
    $self->advance if $self->token =~ /[[:space:]]/;
    $n+0;
}

sub value {
    my ($self, $value) = @_;
    $self->advance unless defined $self->token;
    if ($self->accept('{')) {
        $value = $self->object({});
        $self->expect('}');
    } elsif ($self->accept('[')) {
        $value = $self->array([]);
        $self->expect(']');
    } elsif ($self->accept('"')) {
        $value = $self->string;
        $self->expect('"');
    } elsif ($self->accept('null')) {
        $value = undef;
    } elsif ($self->accept('true')) {
        $value = 1;
    } elsif ($self->accept('false')) {
        $value = 0;
    } elsif ($self->token =~ /[[:digit:].-]/) {
        $value = $self->number;
    } else {
        confess $self->error;
    }
    $value;
}

sub main {
    use Data::Dumper;
    print Data::Dumper->Dump([json->new->value], ['json']);
}

main unless caller;

1;