Author: jkeenan
Date: Wed Feb 7 20:25:09 2007
New Revision: 16921
Added:
branches/buildtools/t/tools/ops2cutils/
branches/buildtools/t/tools/ops2cutils/02-usage.t
branches/buildtools/t/tools/ops2cutils/testlib/
branches/buildtools/t/tools/ops2cutils/testlib/Capture.pm
Modified:
branches/buildtools/lib/Parrot/Ops2c/Auxiliary.pm
branches/buildtools/tools/build/ops2c.pl
Log:
Worked on refactoring and testing of Parrot::Ops2c::Auxiliary::Usage() and
getoptions(). Reformulated Usage(), dropping dependency on Pod::Usage and
eliminating (internally) hard-coded 'exit'. (I think the caller should always
be the one to generate an 'exit', not a module used within the caller.
Otherwise, how can you test the return value?) Retained same usage message as
previously. Wrote t/tools/ops2cutils/02-Usage.t and testlib/Capture.pm.
Modified: branches/buildtools/lib/Parrot/Ops2c/Auxiliary.pm
==============================================================================
--- branches/buildtools/lib/Parrot/Ops2c/Auxiliary.pm (original)
+++ branches/buildtools/lib/Parrot/Ops2c/Auxiliary.pm Wed Feb 7 20:25:09 2007
@@ -7,17 +7,22 @@
@ISA = qw( Exporter );
@EXPORT_OK = qw( Usage getoptions );
use Getopt::Long qw(:config permute);
-use Pod::Usage;
-
-#sub Usage {
-# print STDERR <<_EOF_;
-#usage: tools/build/ops2pm.pl [--help] [--no-lines] input.ops [input2.ops ...]
-#_EOF_
-# return 1;
-#}
sub Usage {
- return pod2usage( -exitval => 1, -verbose => 0, -output => \*STDERR );
+ my $usage_msg = <<USAGE;
+ % perl tools/build/ops2c.pl trans [--help] [--no-lines] [--dynamic]
+ [--core | input.ops [input2.ops ...]]
+ trans := C | CGoto | CGP | CSwitch | CPrederef
+
+For example:
+
+ % perl tools/build/ops2c.pl C --core
+
+ % perl tools/build/ops2c.pl C --dynamic myops.ops
+
+USAGE
+ print STDERR $usage_msg;
+ return 1;
}
sub getoptions {
Added: branches/buildtools/t/tools/ops2cutils/02-usage.t
==============================================================================
--- (empty file)
+++ branches/buildtools/t/tools/ops2cutils/02-usage.t Wed Feb 7 20:25:09 2007
@@ -0,0 +1,133 @@
+#! perl
+# Copyright (C) 2006, The Perl Foundation.
+# $Id: 02-usage.t 16894 2007-02-04 22:54:29Z jkeenan $
+# 02-usage.t
+
+use strict;
+use warnings;
+BEGIN {
+ use FindBin qw($Bin);
+ use Cwd qw(cwd realpath);
+ realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$};
+ our $topdir = $1;
+ if (defined $topdir) {
+ print "\nOK: Parrot top directory located\n";
+ } else {
+ $topdir = realpath($Bin) . "/../../..";
+ }
+ unshift @INC, qq{$topdir/lib};
+}
+use Test::More tests => 30;
+use Carp;
+use Cwd;
+use lib ("$main::topdir/t/tools/ops2cutils/testlib");
+use_ok( "Capture" );
+
+use_ok( 'Parrot::Ops2c::Auxiliary', qw| Usage getoptions | );
+
+ok(chdir $main::topdir, "Positioned at top-level Parrot directory");
+my $cwd = cwd();
+my ($msg, $tie, @lines);
+{
+ $tie = tie *STDERR, "Capture" or croak "Unable to tie";
+ my $rv = Usage();
+ $msg = $tie->READLINE;
+ untie *STDERR or croak "Unable to untie";
+ is($rv, 1, "Usage() returned");
+ like($msg,
+ qr|^
+ \s*%\sperl\stools\/build\/ops2c\.pl\strans.*
+ trans\s:=.*
+ For\sexample.*
+ core.*
+ dynamic.*
+ |msx,
+ "Got expected usage message");
+}
+
+{
+ local @ARGV = qw( --no-lines );
+ my $flagsref = getoptions();
+ ok($flagsref->{nolines}, "no-lines option detected");
+ ok(! defined $flagsref->{help}, "help option not defined");
+ ok(! defined $flagsref->{dynamic}, "dynamic option not defined");
+ ok(! defined $flagsref->{core}, "core option not defined");
+}
+
+{
+ local @ARGV = ();
+ my $flagsref = getoptions();
+ ok(! defined $flagsref->{nolines}, "no-lines option not defined");
+ ok(! defined $flagsref->{help}, "help option not defined");
+ ok(! defined $flagsref->{dynamic}, "dynamic option not defined");
+ ok(! defined $flagsref->{core}, "core option not defined");
+}
+
+{
+ local @ARGV = qw( --no-lines --help --core );
+ my $flagsref = getoptions();
+ ok($flagsref->{nolines}, "no-lines option detected");
+ ok($flagsref->{help}, "help option detected");
+ ok(! defined $flagsref->{dynamic}, "dynamic option not defined");
+ ok($flagsref->{core}, "core option detected");
+}
+
+{
+ local @ARGV = qw( --dynamic );
+ my $flagsref = getoptions();
+ ok(! defined $flagsref->{nolines}, "no-lines option not defined");
+ ok(! defined $flagsref->{help}, "help option not defined");
+ ok(defined $flagsref->{dynamic}, "dynamic option defined");
+ ok(! defined $flagsref->{core}, "core option not defined");
+}
+
+{
+ local @ARGV = qw( --d );
+ my $flagsref = getoptions();
+ ok(! defined $flagsref->{nolines}, "no-lines option not defined");
+ ok(! defined $flagsref->{help}, "help option not defined");
+ ok(defined $flagsref->{dynamic}, "dynamic option defined");
+ ok(! defined $flagsref->{core}, "core option not defined");
+}
+
+{
+ local @ARGV = qw( --no-lines --help --core --d );
+ my $flagsref = getoptions();
+ ok($flagsref->{nolines}, "no-lines option detected");
+ ok($flagsref->{help}, "help option detected");
+ ok(defined $flagsref->{dynamic}, "dynamic option defined");
+ ok($flagsref->{core}, "core option detected");
+}
+
+pass("Completed all tests in $0");
+
+################### DOCUMENTATION ###################
+
+=head1 NAME
+
+02-usage.t - test C<Parrot::Ops2c::Utils::Usage()>
+
+=head1 SYNOPSIS
+
+ % prove t/tools/ops2cutils/02-usage.t
+
+=head1 DESCRIPTION
+
+The files in this directory test the publicly callable subroutines of
+F<lib/Parrot/Ops2c/Utils.pm> and F<lib/Parrot/Ops2c/Auxiliary.pm>.
+By doing so, they test the functionality of the F<ops2c.pl> utility.
+That functionality has largely been extracted
+into the methods of F<Utils.pm>.
+
+F<02-usage.t> tests whether C<Parrot::Ops2c::Auxiliary::Usage()>
+and F<getoptions()> work properly.
+
+=head1 AUTHOR
+
+James E Keenan
+
+=head1 SEE ALSO
+
+Parrot::Ops2c::Auxiliary, F<ops2c.pl>.
+
+=cut
Added: branches/buildtools/t/tools/ops2cutils/testlib/Capture.pm
==============================================================================
--- (empty file)
+++ branches/buildtools/t/tools/ops2cutils/testlib/Capture.pm Wed Feb 7
20:25:09 2007
@@ -0,0 +1,23 @@
+# Copyright (C) 2006, The Perl Foundation.
+# $Id: Capture.pm 16816 2007-01-27 06:16:23Z jkeenan $
+package Capture;
+use strict;
+# Adapted from IO::Capture::Tie_STDx.
+# Thanks as always to Mark Reynolds and Jon Morgan!
+
+sub TIEHANDLE {
+ my $class = shift;
+ bless [], $class;
+}
+
+sub PRINT {
+ my $self = shift;
+ push @$self, join '',@_;
+}
+
+sub READLINE {
+ my $self = shift;
+ return wantarray ? @$self : shift @$self;
+}
+
+1;
Modified: branches/buildtools/tools/build/ops2c.pl
==============================================================================
--- branches/buildtools/tools/build/ops2c.pl (original)
+++ branches/buildtools/tools/build/ops2c.pl Wed Feb 7 20:25:09 2007
@@ -5,7 +5,6 @@
use strict;
use lib 'lib';
-# use Pod::Usage;
use Getopt::Long qw(:config permute);
use Data::Dumper;
@@ -24,27 +23,23 @@
#
# Look at the command line options
#
-#sub Usage {
-# return pod2usage( -exitval => 1, -verbose => 0, -output => \*STDERR );
-#}
-
-#my ( $nolines_flag, $help_flag, $dynamic_flag, $core_flag );
-#GetOptions(
-# "no-lines" => \$nolines_flag,
-# "help" => \$help_flag,
-# "dynamic|d" => \$dynamic_flag,
-# "core" => \$core_flag,
-#) || Usage();
-
-my $flagref = getoptions() || Usage();
-
-#Usage() if $help_flag;
-Usage() if $flagref->{help};
-Usage() unless @ARGV;
+my $flagref = getoptions();
+
+if (
+ (not defined $flagref) or
+ $flagref->{help} or
+ (not @ARGV)
+ ) {
+ Usage();
+ exit 1;
+}
my $class_name = shift @ARGV;
my %is_allowed = map { $_ => 1 } qw(C CGoto CGP CSwitch CPrederef);
-Usage() unless $is_allowed{$class_name};
+unless ($is_allowed{$class_name}) {
+ Usage();
+ exit 1;
+}
my $trans_class = "Parrot::OpTrans::" . $class_name;
eval "require $trans_class";
