Peter Scott wrote:
>
> Tony Olekshy wrote:
> >
> > In fact, not only would I be pleased and honoured to author the
> > Perl 6 core Try.pm module, I'm already working on a Perl 5 standard
> > reference implementation.
>
> > Peter, I think we should make this approach more clear in RFC 88.
>
> I'm not convinced that this can totally be implemented in a
> module.
#- File Try.pm -#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#
#
# Subject: Structured Exception Handling Mechanism for Perl 6
#
# Purpose: Perl 5 Reference Implementation of RFC 88 functions.
#
# This is a self-documenting self-testing implementation, in
# Perl 5, of the functionality referred to in Perl 6 RFC 88,
# with syntax modified as required by Perl 5. Save in Try.pm.
#
# Author: Tony Olekshy
# Principal Software Architect
# Avra Software Lab Inc.
#
# Copyright: Avra Software Lab Inc, 1999-2000.
#
#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#
use strict; $Try::VERSION = "1.0.1.2"; # 2000-08-26
=head1 ABSTRACT
This document assumes a certain familiarity with [RFC-88].
26 regression tests can be found herein at /#- Regress/.
To run the regression tests, use one of:
perl -we "use Try regress => 1"
perl -we "use Try regress => 2"
perl -we "use Try regress => 1, test => 'syntax-1'"
perl -we "use Try regress => 2, test => 'syntax-1'"
If regress => !0 is specified, regression test are run at import
time. If regress => 2, detailed output is generated, otherwise
successes report as a single output line. If test => "syntax-1"
is specified, only test "syntax-1" is run (see /!syntax-1/ for
this example).
To run manual tests, perl -w test.pl, where test.pl looks like:
use strict;
use Try;
try sub { throw Exception "Foo" },
catch sub { print "$@[0]\n" };
=head1 DESCRIPTION
use Try;
exception 'Alarm';
try sub {};
try sub {}, catch sub {};
try sub {}, catch "Foo" => sub {};
try sub {}, catch "Foo", "Bar" => sub {};
try sub {}, catch sub {} => sub {};
try sub {}, finally sub {};
throw Alarm "Can't foo.";
=head1 IMPLEMENTATION
This reference implementation is written for readability,
testability, and distributability. A production version
would be optimized for performance. The syntax has been
chosen to make the reference implementation simple, not to
suggest a preferred syntax for the constructs of RFC 88.
The exception, try, catch, and finally "keywords" are exported
to the invoker's package. Try and Exception packages are
defined, the latter of which contains the base class for
exception objects.
The current unwind stack is kept in @@; $@[0] is current
exception, due to Perl 5 constraints on $@ inside eval.
While unwinding, $@ is join("\n",@@)."\n".
This implementation uses explicit subs in the syntax for try,
catch, and finally clauses, due to Perl 5 parser constraints.
Catch clauses that list exception class names take a list of
quoted-string class names, due to Perl 5 parser constraints.
Lexical scope is not shared between clauses, as per Perl 5.
Clauses are closures, not blocks, so @_ == () therein.
Clauses are eval'd, therefore $@ eq "" therein. Use $@[0].
Local gotos across unwind-semanitics blocks have not been tested.
Dead-code catch clauses are not currently detected by engine.
Note that: try {}; finally {}; will ignore the finally! It should
be written try {}, finally {}; This would, presumably, be solved
by parser extensions in Perl 6.
Full exception statement functionality is not yet available.
Mechanism hooks are not yet implemented.
=head1 ISSUES
Get rid of the sub on the sub {} terms.
$@ should equal $@[0] inside the clause blocks, not "".
=head1 REFERENCE
[RFC-88] http://tmtowtdi.perl.org/rfc/88.pod
[RFC-80] http://tmtowtdi.perl.org/rfc/80.pod
=cut
# Interface -------------------------------------------------------------
package Try;
sub exception { &_exception; return undef; }
sub try { return &_try; }
sub catch { return (_catch => @_); }
sub finally { return (_finally => @_); }
sub Hook { return &_Hook; }
package Exception;
sub new { $_[0]->_construct(@_[1..$#_]); }
sub throw { $_[0]->_throw( @_[1..$#_]); }
package main;
@@ = (); # Used for unwind-time exception stack.
# Implementation [ Try ] ------------------------------------------------
package Try;
$Try::Debug = 0; # Set this to include Try subs in traceback.
$Try::Trace = 0; # Set this to trace flow control logic.
$Try::Force = 0; # Set this to force regression temp file writes.
$Try::Temp = "=regress";# Temp file name for regression test capture.
my $_depth = 0; # Keeps track of nested trys for inits.
my $_stack = ""; # Formatted version of current @@.
sub import
{
# Invoked by "use Try" to install the Try mechanism into a package.
#
my ($pkg, %opt) = @_;
# Install new "keywords" into caller's package.
#
my $stash = do { no strict 'refs'; \%{caller(0)."::"} };
map { ${$stash}{$_} = $::{"Try::"}{$_} }
qw( exception try catch finally );
# Process options given to "use Try".
#
defined $opt{debug} and $Try::Debug ||= $opt{debug};
# Run regression tests if requested.
#
$opt{regress} and _regress($opt{regress}, $opt{test});
}
sub _exception
{
# Declares a class that interits from Exception.
#
$Try::Trace and print "exception: ", join(", ", @_), "\n";
#--> Complex exceptions are not yet implemented.
do { no strict 'refs'; @{"${_[0]}::ISA"} = ('Exception'); };
}
sub _try
{
# Structured exception handling engine: process try statement.
#
my (@args) = @_;
$Try::Trace and print "try: ", join(", ", @args), "\n";
$_depth++ or @@ = (); # Danger???
# Evaluate the try clause trapping exceptions.
#
my (@Result, $result);
wantarray ? (@Result = _handle(shift @args))
: ($result = _handle(shift @args));
# Process the try's catch and finally clauses:
#
my $skipping = 0; # Skipping catches until next finally.
Clause: while (@args) {
my $arg = shift @args;
# Look after catch clauses...
#
if ($arg eq "_catch") {
my @cNames = (); my ($test, $closure);
# Pick off class name args up to next closure.
#
while (@args && ref $args[0] ne "CODE") {
$arg = shift @args;
if (ref $arg) {
&_error("Expecting string, found \"$arg\".");
last Clause;
}
push @cNames, $arg;
}
# Pick off the catch closure.
#
if (ref $args[0] eq "CODE") {
$closure = shift @args;
# If two closures and no @cNames: test closure.
#
if (!@cNames and ref $args[0] eq "CODE") {
$test = $closure; $closure = shift @args;
}
}
else {
&_error("Expecting sub but found \"" .
(@args ? $args[0] : "<nothing>") . "\".");
last Clause;
}
# We have a catch clause!
#
# Do nothing if not unwinding or skipping catches.
#
next Clause if @@ == 0 || $skipping;
# Otherwise, determine whether or not to invoke...
#
if (@cNames) { # Check isa relationships.
next Clause unless grep { $@[0]->isa($_) } @cNames;
}
if ($test) { # Check the test closure.
my $before = @@; # To see if $closure dies.
my $t = _handle($test);
@@ > $before and $skipping = 1;
next Clause if $skipping || ! $t;
}
# If we got this far, invoke the catch closure.
#
my $before = @@; # To see if $closure dies.
_handle($closure);
@@ == $before and @@ = (); # Cleanly Caught!
$skipping = 1; # Skip clauses 'till finally.
}
# Look after finally clauses...
#
elsif ($arg eq "_finally") {
$skipping = 0; # Stop catch clause skipping.
my $closure = shift @args;
unless (ref $closure eq "CODE") {
&_error("Expecting sub but found \"$closure\".");
last Clause;
}
# Invoke the finally closure, exceptions simply stacked.
#
_handle($closure);
}
# Right, anything else and we're out'a here.
#
else {
&_error("Expecting catch or finally but found \"$arg\".");
last Clause;
}
}
# The try statement is complete. Handle unwinding stuff...
#
$_depth -= 1;
@@ or $_stack = "";
# Unless the unwind stack is empty, we are to unwind.
#
if (@@) {
local $::SIG{__DIE__} = sub {};
die ($_stack = join("\n", @@) . "\n");
}
# Else we haven't unwound; return result of the try clause.
#
return wantarray ? @Result : $result;
}
sub _handle
{
# Invoke a closure and trap any unwinding thereunder.
#
my ($closure, @rest) = @_; my (@Result, $result);
$Try::Trace > 1 and print "_handle: ", join(", ", @_), "\n";
unless (ref $closure eq "CODE") {
&_error("Expecting closure but found \"$closure\".");
return;
}
# Evaluate closure trapping unwinding.
#
local $::SIG{__DIE__} = \&_diewrap;
wantarray ? (@Result = eval { &{$closure}(@rest) })
: ($result = eval { &{$closure}(@rest) });
# Wrap exceptions raised by "die" (but not by "throw").
#
$@ && "$@" ne $_stack
and
&_push(Exception::Try::Wrap::Die->new("$@", data => $@));
return wantarray ? @Result : $result;
}
sub _diewrap
{
# A $::SIG{__DIE__} that handles die seperate from throw.
#
my ($e) = @_; my @args = ();
$Try::Trace and print "_diewrap: ", join(", ", @_), "\n";
!ref $e && $e =~ s/ at (.*? line \d+)//s
and
push(@args, debug => $1);
throw Exception::Try::Wrap::Die "$e", @args;
}
sub _throwhook
{
# Used by Exception class's throw to die in a detectable way.
#
my ($e) = @_;
# Make a note of the exception being thrown (on the unwind stack).
#
&_push($e);
# And unwind.
#
local $::SIG{__DIE__} = sub {};
die ($_stack = join("\n", @@) . "\n");
}
sub _error
{
# Convenience routine used by try to wrap syntax errors.
#
$Try::Trace and print "_error: ", join(", ", @_), "\n";
&_push(Exception::Try::Syntax->new($_[0]));
};
sub _push
{
# Invoked by try whenever it wants to stack an exception.
#
my ($e) = @_;
$Try::Trace > 1 and print "_push: ", ref $e, " [$e]\n";
ref $e && $e->isa("Exception")
or
$e = Exception::Try::Wrap->new("$e", data => $e);
unshift @@, $e;
$e->{trace} or $e->snapshot;
}
sub _Hook
{
# Perl 5 interface to on_catch_enter et al hooks.
#
# --> Not yet implemented.
#
$Try::Trace and print "Hook: ", join(", ", @_), "\n";
}
# Implementation [ Exception ] ------------------------------------------
package Exception;
@Exception::Try::ISA = ('Exception');
@Exception::Try::Syntax::ISA = ('Exception::Try');
@Exception::Try::Wrap::ISA = ('Exception::Try');
@Exception::Try::Wrap::Die::ISA = ('Exception::Try::Wrap');
sub _construct
{
bless {message => @_[1..$#_]}, ref $_[0] || $_[0];
}
sub _throw
{
$Try::Trace and print "throw: ", join(", ", @_), "\n";
my $I = shift; my $e = ref $I ? $I : $I->new(@_);
&Try::_throwhook($e); # Die in a detectable way.
}
use overload '""' => sub
{
return "[" . (ref $_[0]) . "] " . $_[0]->{message};
};
sub snapshot
{
my ($I) = @_; $I->{trace} = "";
for (my $level = 0; ; $level += 1) {
my @F = caller($level); @F or last;
next if !$Try::Debug && $F[1] =~ /Try.pm$/;
$I->{trace} .= "$F[3] called from $F[1]\[$F[2]].\n";
}
}
# Implementation [ Regression Tests ] -----------------------------------
package Try;
sub _regress
{
my ($level, $which) = @_; my $count = 0;
print "Try.pm $Try::VERSION Regression Tests...\n\n";
!$Try::Force && -f $Try::Temp
and
die "Temp file \"$Try::Temp\" already exists,";
select STDERR; $| = 1; print STDERR "";
select STDOUT; $| = 1; print STDOUT "";
$Try::_Tests =~ s/#.*//mg;
foreach my $test ( split(/^!/m, $Try::_Tests) ) {
# Parse out the test input and expected result.
#
next unless $test =~/\S/; $count += 1;
$test =~ s/(.*)\n\s+=expect\s*\n(.*)/$1/s
or
die "=expect section missing in test:\n$test";
my ($input, $expect) = ($1, $2);
$input =~ s/^(.*?)\n//s or die; my $title = $1;
$title =~ s/^(\S+)\s+(.*)/$2/s or die; my $tag = $1;
next if $which && $which ne $tag;
# Wrap the test code into its own little package.
#
(my $package = $tag) =~ s/\W/_/g;
$input = "package Try::Test::$package; "
. "use strict; use Try; \$Try::Trace = 0;\n"
. $input;
# Run the test code collecting print output into temp file.
#
open(SAVEOUT, ">&STDOUT") or die;
open(SAVEERR, ">&STDERR") or die;
0 and *SAVEOUT = *SAVEERR; # Avoid used only once warnings.
open(STDOUT, ">$Try::Temp")
or
die "Can't write to \"$Try::Temp\", $!";
eval $input; $@ and die "Test $tag died.\n$@";
close(STDOUT); open(STDOUT, ">&SAVEOUT");
close(STDERR); open(STDERR, ">&SAVEERR");
# Read back the test's print output.
#
local *RESULT;
open(RESULT, $Try::Temp)
or
die "Can't read \"$Try::Temp\", $!";
my $result = do { local $/; <RESULT> }; close RESULT;
unlink $Try::Temp or die;
# Fixups so that tests match normally variable stuff.
#
foreach ($input, $expect, $result) {
s/^\s+|\s+$//sg; s/^\s+//mg; # White space.
s/\b0x[0-9a-f]+/0xcafebabe/g; # Addresses.
s/\[\d+\]/[?]/g; # Line numbers.
s/\(eval \d+\)/(eval ?)/g; # Eval depth.
s/^(Try::import called) from.*/$1./m; # perl -e.
}
# Format up the results of this test...
#
my $match = $result eq $expect;
printf "=== %-4s %-12s %s\n",
$match ? "Ok:" : "Bad:", $tag, $title;
$level >= 2
and
print "=== Test:\n$input\n";
$match
or
print "=== Expected:\n$expect\n=== Received:\n$result\n\n";
$match && $level >= 2
and
print "=== Result:\n$result\n\n";
}
print "\nTry.pm Regression Tests Done ($count tests).\n";
}
#- Regression Tests --#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#
$Try::_Tests = <<'_END_TESTS_';
!syntax-1 Basic syntax.
$Try::Trace = 1; # Show top-level statement "parsing".
exception 'Alarm';
try sub {};
try sub {}, catch sub {};
try sub {}, catch "Foo" => sub {};
try sub {}, catch "Foo", "Bar" => sub {};
try sub {}, catch sub {} => sub {};
try sub {}, finally sub {};
eval { throw Alarm "Can't foo."; }; print "$@\n";
=expect
exception: Alarm
try: CODE(0xcafebabe)
try: CODE(0xcafebabe), _catch, CODE(0xcafebabe)
try: CODE(0xcafebabe), _catch, Foo, CODE(0xcafebabe)
try: CODE(0xcafebabe), _catch, Foo, Bar, CODE(0xcafebabe)
try: CODE(0xcafebabe), _catch, CODE(0xcafebabe), CODE(0xcafebabe)
try: CODE(0xcafebabe), _finally, CODE(0xcafebabe)
throw: Alarm, Can't foo.
[Alarm] Can't foo.
!syntax-2 Basic syntax error.
eval { try "Foo"; }; print "$@\n";
=expect
[Exception::Try::Syntax] Expecting closure but found "Foo".
!syntax-3 Bad clause arguments.
eval { try sub {}, catch Foo => "Bar"; }; print "$@\n";
eval { try sub {}, catch [] => sub {}; }; print "$@\n";
eval { try sub {}, finally "Foo"; }; print "$@\n";
=expect
[Exception::Try::Syntax] Expecting sub but found "<nothing>".
[Exception::Try::Syntax] Expecting string, found "ARRAY(0xcafebabe)".
[Exception::Try::Syntax] Expecting sub but found "Foo".
!catch-1 Catch clause succeeds.
try sub {
try sub { throw Exception "1" },
catch sub { print "$@[0]\n"; };
},
catch sub {
print "BAD TEST: $@[0]\n";
};
=expect
[Exception] 1
!catch-2 Catch clause throws.
try sub {
try sub { throw Exception "1" },
catch sub { throw Exception "2" },
},
catch sub {
print join("\n", @@), "\n";
};
=expect
[Exception] 2
[Exception] 1
!die-1 Try clause dies.
try sub {
try sub { die "Exception 1" },
catch sub {
print "$@[0]", "\tContext: $@[0]->{debug}\n";
};
},
catch sub {
print "BAD TEST: $@[0]\n";
};
=expect
[Exception::Try::Wrap::Die] Exception 1.
Context: (eval ?) line 4
!die-2 Catch clause dies.
try sub {
try sub { die "Exception 1" },
catch sub { die "Exception 2" },
},
catch sub {
print join("\n", @@), "\n";
};
=expect
[Exception::Try::Wrap::Die] Exception 2.
[Exception::Try::Wrap::Die] Exception 1.
!cascade-1 Multiple catches, first is clean.
try sub { throw Exception "1"; },
catch sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
A: [Exception] 1
!cascade-2 Multiple catches, first throws.
try sub {
try sub { throw Exception "1"; },
catch sub { throw Exception "2"; },
catch sub { print "B: $@[0]\n"; };
},
catch sub {
print join("\n", @@), "\n";
};
=expect
[Exception] 2
[Exception] 1
!test-1 Conditional catches, first matches.
try sub {
throw Exception "1";
},
catch sub { 1 } => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
A: [Exception] 1
!test-2 Conditional catches, first doesn't match.
try sub {
throw Exception "1";
},
catch sub { 0 } => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
B: [Exception] 1
!test-3 Conditional catch, test throws.
try sub {
try sub {
throw Exception "1";
},
catch sub { throw Exception "2"; }
=> sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
},
catch sub {
print join("\n", @@), "\n";
};
=expect
[Exception] 2
[Exception] 1
!test-4 Conditional catch based on $@[0].
try sub {
my $x = 0; my $y = 1 / $x;
},
catch sub { $@[0] =~ /root of negative/ }
=> sub { print "A: $@[0]\n"; },
catch sub { $@[0] =~ /division by zero/ }
=> sub { print "B: $@[0]\n"; },
catch sub { print "C: $@[0]\n"; };
=expect
B: [Exception::Try::Wrap::Die] Illegal division by zero.
!isa-1 Catch by ISA matches.
try sub {
throw Exception "1";
},
catch "Exception" => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
A: [Exception] 1
!isa-2 Catch by ISA doesn't match.
try sub {
throw Exception "1";
},
catch "Foo" => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
B: [Exception] 1
!isa-3 Catch by ISA list matches.
try sub {
throw Exception "1";
},
catch "Foo", "Exception", "Bar" => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
A: [Exception] 1
!isa-4 Catch by ISA list doesn't match.
try sub {
throw Exception "1";
},
catch "Foo", "Bar", "Baz" => sub { print "A: $@[0]\n"; },
catch sub { print "B: $@[0]\n"; };
=expect
B: [Exception] 1
!isa-5 Catch by ISA, middle catch matches.
try sub {
throw Exception "1";
},
catch "Foo" => sub { print "A: $@[0]\n"; },
catch "Exception" => sub { print "B: $@[0]\n"; },
catch "Bar" => sub { print "C: $@[0]\n"; },
catch sub { print "D: $@[0]\n"; };
=expect
B: [Exception] 1
!finally-1 Basic finally clause.
try sub { print "Foo" }, finally sub { print ", Bar.\n" };
=expect
Foo, Bar.
!finally-2 Finally clause, try throws.
try sub {
try sub { throw Exception "1" },
finally sub { print "Finally\n"};
},
catch sub { print join("\n", @@), "\n"; };
=expect
Finally
[Exception] 1
!finally-3 Finally clause, finally throws.
try sub {
try sub { throw Exception "1" },
finally sub { throw Exception "2" };
},
catch sub { print join("\n", @@), "\n"; };
=expect
[Exception] 2
[Exception] 1
!finally-4 Multiple finally clauses.
try sub {
try sub { throw Exception "1" },
finally sub { throw Exception "2" },
finally sub { throw Exception "3" },
finally sub { throw Exception "4" };
},
catch sub { print join("\n", @@), "\n"; };
=expect
[Exception] 4
[Exception] 3
[Exception] 2
[Exception] 1
!finally-5 Finally resets catch skipping.
try sub {
try sub { throw Exception "1" },
catch sub { throw Exception "2" },
catch sub { throw Exception "BAD" },
finally sub { throw Exception "3" },
catch sub { throw Exception "4" };
},
catch sub { print join("\n", @@), "\n"; };
=expect
[Exception] 4
[Exception] 3
[Exception] 2
[Exception] 1
!result-1 Basic return value.
my $result = try sub { "Foo" };
print "result: $result\n";
=expect
result: Foo
!trace-1 Basic Perl stack traceback.
try sub { throw Exception "1" },
finally sub { throw Exception "2" },
catch sub {
print join("\n", @@), "\n--\n", $@[0]->{trace} , "\n";
};
=expect
[Exception] 2
[Exception] 1
--
Exception::throw called from (eval ?)[?].
Try::try called from (eval ?)[?].
Try::import called.
main::BEGIN called from (eval ?)[?].
(eval) called from (eval ?)[?].
!trace-2 Stack traceback with Try.pm internals.
$Try::Debug = 1;
try sub { throw Exception "1" },
finally sub { throw Exception "2" },
catch sub {
print join("\n", @@), "\n--\n", $@[0]->{trace} , "\n";
};
=expect
[Exception] 2
[Exception] 1
--
Exception::snapshot called from Try.pm[?].
Try::_push called from Try.pm[?].
Try::_throwhook called from Try.pm[?].
Exception::_throw called from Try.pm[?].
Exception::throw called from (eval ?)[?].
Try::Test::trace_2::__ANON__ called from Try.pm[?].
(eval) called from Try.pm[?].
Try::_handle called from Try.pm[?].
Try::_try called from Try.pm[?].
Try::try called from (eval ?)[?].
(eval) called from Try.pm[?].
Try::_regress called from Try.pm[?].
Try::import called.
main::BEGIN called from (eval ?)[?].
(eval) called from (eval ?)[?].
_END_TESTS_
1;#-#-#-#-#-#-#-#-#-#-#-#-#- End of Try.pm -#-#-#-#-#-#-#-#-#-#-#-#-#-#-#
