What I learned from perlbrew

I signed up for Neil Bowers' CPAN Pull Request Challenge, and the first module I got was App::perlbrew. After some looking and guessing, gugod pointed me to one of his problems, and after some time reading and understanding how things work, I got it done.

It took me a while to figure out how it worked. I had seen and used something like it — I had found out about dispatch tables from my local friendly neighborhood Perl Mongers — and I have started to use old-school Perl object orientation on occasion, but this combined them in a very interesting way.

A lot of the clever, however, isn't where I thought it was, which I didn't realize until now. The symbol-table manipulation isn't about making the commands work, but rather guessing what you meant if you give a command it can't handle. The "magic" is all about $s = $self->can($command) and $self->$s(@$args).

I wrote a quick stub of an application that would show off how to this works, with lots of comments that are meant to explain what's meant to happen instead of how it's supposed to work, as "Most comments in code are in fact a pernicious form of code duplication".

If you try symtest.pl foo, it will print 1 and foo. If you try symtest.pl food, it'll just print 1. If you instead try symtest.pl fod, it'll print "unknown command" and suggest foo and food as alternate suggestions. Like a boss.

One of the coolest things, I think is that you can put your user-facing methods in a second module. Or, perhaps I just have a low threshold for cool.

If you have questions about the code, or understand the things I handwave and know you can do better, please comment below.

	package Sym ;
	# Sample code for making an easily extendable command-line
	# application with Perl
	use feature qw{ say } ;
	use strict ;
	use warnings ;
	use Data::Dumper ;
	# Sym2 includes all the actual called functions
	use Sym2 ;
	# the object just contains the arguments set.
	sub new {
	my ( $class, @argv ) = @_ ;
	my $self ;
	$self->{args} = [] ;
	if (@argv) {
	$self->{args} = \@argv ;
	}
	return bless $self, $class ;
	}
	# you could replace this with Pod::Usage or the like
	# this can be moved to just run instead of run_command, I suppose,
	# but this is exactly how I grabbed this from perlbrew
	# it'd be easy, as $args is essentially $self->{args}
	sub run {
	my ($self) = @_ ;
	$self->run_command( $self->{args} ) ;
	}
	# this is easily the coolest part of the program right here
	sub run_command {
	my ( $self, $args ) = @_ ;
	if ( scalar @$args == 0 || lc $args->[0] eq 'help' ) {
	$self->help() ;
	exit ;
	}
	if ( lc $args->[0] eq 'commands' ) {
	say join "\n\t" , '' , $self->commands() ;
	exit ;
	}
	my $command = $args->[0] ;
	# I didn't know can() existed. It tells you if a string works as
	# an object method. This is the cool thing that is at the core of
	# this code. $self->can($var) is the core of this bit, and we could
	# easily go to drop the rest of this if desired.
	# $self->can($var) simply turns the symbol table into a
	# dispatch table.
	my $s = $self->can("run_command_$command") ;
	unless ($s) {
	$command =~ y/-/_/ ;
	$s = $self->can("run_command_$command") ;
	}
	# If we haven't gotten the name so far, we'll give it another pass.
	unless ($s) {
	# we think you might've meant something else. If there's many
	# choices we guess you meant, we'll show you a list.
	# if there's one, we'll show you that one.
	# else, we don't think you typed that right. lots of clever behind
	# that,, too.
	my @commands = $self->find_similar_commands($command) ;
	if ( @commands > 1 ) {
	@commands = map { ' ' . $_ } @commands ;
	die
	"Unknown command: `$command`. Did you mean one of the following?\n"
	. join( "\n", @commands )
	. "\n" ;
	}
	elsif ( @commands == 1 ) {
	die "Unknown command: `$command`. Did you mean `$commands[0]`?\n"
	;
	}
	else {
	die "Unknown command: `$command`. Typo?\n" ;
	}
	}
	# this is probably not necessary, but when mocking this up,
	# I didn't have everything put together, $s should be a code
	# ref, so we check to see that it is, and if not, we alert
	# and exit.
	unless ( 'CODE' eq ref $s ) { say 'Not a valid command' ; exit ; }
	$self->$s(@$args) ;
	}
	# another function more or less grabbed direct from perlbrew.
	# you add functions of the form "run_command_*", such as
	# "run_command_do_this_thing" and it puts it into the @commands
	# array, so you can later run "app.pl do-this-thing"
	sub commands {
	my ($self) = @_ ;
	my @commands ;
	# interviewers love to ask about the ternary operator, so
	# if you don't know it:
	# $variable = (boolean statement) ? val if true : val if false
	# here we grab the package and the symbol table for the package
	my $package = ref $self ? ref $self : $self ;
	my $symtable = do {
	no strict 'refs' ;
	\%{ $package . '::' } ;
	} ;
	# he're we're just grabbing the names of the functions and, if they
	# start with "run_command_", we turn all underlines into dashes and
	# add it to the commands list
	foreach my $sym ( sort %$symtable ) {
	if ( $sym =~ /^run_command_/ ) {
	my $glob = $symtable->{$sym} ;
	if ( defined *$glob{CODE} ) {
	$sym =~ s/^run_command_// ;
	$sym =~ s/_/-/g ;
	push @commands, $sym ;
	}
	}
	}
	return @commands ;
	}
	# this uses editdist, which I don't really get, but beyond that, it's
	# fairly simple. editdist gives a number of choices with a numerical
	# indication of how close it is to the desired command. That array
	# of choices is sorted by that similarity index, and it returns just
	# the closest entries.
	sub find_similar_commands {
	my ( $self, $command ) = @_ ;
	my $SIMILAR_DISTANCE = 6 ;
	my @commands = sort { $a->[1] <=> $b->[1] }
	grep {defined}
	map {
	my $d = editdist( $_, $command ) ;
	( $d < $SIMILAR_DISTANCE ) ? [ $_, $d ] : undef
	} $self->commands ;
	if (@commands) {
	my $best = $commands[0][1] ;
	@commands = map { $_->[0] } grep { $_->[1] == $best } @commands ;
	}
	return @commands ;
	}
	# another straight grab.
	# straight copy of Wikipedia's "Levenshtein Distance"
	sub editdist {
	my @a = split //, shift ;
	my @b = split //, shift ;
	# There is an extra row and column in the matrix. This is the
	# distance from the empty string to a substring of the target.
	my @d ;
	$d[$_][0] = $_ for ( 0 .. @a ) ;
	$d[0][$_] = $_ for ( 0 .. @b ) ;
	for my $i ( 1 .. @a ) {
	for my $j ( 1 .. @b ) {
	$d[$i][$j] = (
	$a[ $i - 1 ] eq $b[ $j - 1 ]
	? $d[ $i - 1 ][ $j - 1 ]
	: 1 + min(
	$d[ $i - 1 ][$j],
	$d[$i][ $j - 1 ],
	$d[ $i - 1 ][ $j - 1 ]
	)
	) ;
	}
	}
	return $d[@a][@b] ;
	}
	# returns the minimum value of the array. used in editdist()
	sub min(@) {
	my $m = $_[0] ;
	for (@_) {
	$m = $_ if $_ < $m ;
	}
	return $m ;
	}
	# this would best be replaced by something using Pod::Usage or the
	# like.
	sub help {
	my ($self) = @) ;
	say 'HELP!!!' ;
	}
	1 ;
	__DATA__
	The MIT License
	Copyright (c) 2015 Dave Jacoby
	Copyright (c) 2010,2011,2012,2013 Kang-min Liu
	Permission is hereby granted, free of charge, to any person obtaining a copy
	of this software and associated documentation files (the "Software"), to deal
	in the Software without restriction, including without limitation the rights
	to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
	copies of the Software, and to permit persons to whom the Software is
	furnished to do so, subject to the following conditions:
	The above copyright notice and this permission notice shall be included in
	all copies or substantial portions of the Software.
	THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
	THE SOFTWARE.

view raw Sym.pm hosted with ❤ by GitHub

	package Sym2 ;
	use feature qw{ say } ;
	use strict ;
	use warnings ;
	use Exporter qw{import} ;
	use Data::Dumper ;
	# all these are nonsense functions, serving to pad out the
	# symbol table and give find_similar_commands() a reason to
	# show multiple
	our @EXPORT = qw{
	run_command_diesel_fitter
	run_command_bar
	run_command_blee
	run_command_foo
	run_command_food
	run_command_quuz
	run_command_smith
	run_command_xyz
	} ;
	sub run_command_bar {
	my ($self) = @) ;
	say '2' ;
	}
	sub run_command_blee {
	my ($self) = @) ;
	say '3' ;
	}
	sub run_command_diesel_fitter {
	my ($self) = @) ;
	say q{These'll fit 'er} ;
	}
	sub run_command_foo {
	my ($self) = @) ;
	say '1' ;
	say join '|', @ARGV ;
	}
	sub run_command_food {
	my ($self) = @) ;
	say '1' ;
	}
	sub run_command_quuz {
	my ($self) = @) ;
	say '4' ;
	}
	sub run_command_smith {
	my ($self) = @) ;
	say q{xxxxxxxx} ;
	}
	sub run_command_xyz {
	my ($self) = @) ;
	say 'xyz' ;
	}
	1 ;

view raw Sym2.pm hosted with ❤ by GitHub

	#!/usr/bin/env perl
	use feature qw{ say } ;
	use strict ;
	use warnings ;
	use lib '~' ;
	use Sym ;
	my $sym = Sym->new(@ARGV) ;
	$sym->run() ;

view raw symtest.pl hosted with ❤ by GitHub