--- lib/Exception/Class.pm.orig 2008-11-20 17:56:18.000000000 +0300
+++ lib/Exception/Class.pm 2008-11-20 18:00:18.000000000 +0300
@@ -18,89 +18,147 @@
local $Exception::Class::Caller = caller();
- my %c;
+ # a reachability matrix for the directed acyclic
+ # graph reflecting classes inheritance.
+ # It is later used in topological ordering to
+ # determine the right order of subclassing.
+ my %graph;
- my %needs_parent;
+ my %class_def;
while (my $subclass = shift)
{
my $def = ref $_[0] ? shift : {};
$def->{isa} = $def->{isa} ? ( ref $def->{isa} ? $def->{isa} : [$def->{isa}] ) : [];
- $c{$subclass} = $def;
- }
-
- # We need to sort by length because if we check for keys in the
- # Foo::Bar:: stash, this creates a "Bar::" key in the Foo:: stash!
- MAKE_CLASSES:
- foreach my $subclass ( sort { length $a <=> length $b } keys %c )
- {
- my $def = $c{$subclass};
+ # create graph edges reflecting $subclass dependence
+ # on its ancestors existence
+ $graph{ $subclass } = +{ map { $_ => 1 } @{ $def->{isa} } };
- # We already made this one.
- next if $CLASSES{$subclass};
+ $class_def{$subclass} = $def;
+ }
+ # detect typos and create graph nodes for explicitly specified immediate
+ # ancestors. If any class specified as an ancestor for some other class
+ # is only mentioned in the 'isa' param, it must exist. Otherwise it's
+ # a typo.
+ for my $vertex ( sort keys %graph )
{
- no strict 'refs';
- foreach my $parent (@{ $def->{isa} })
+ for my $adjacent ( sort keys %{ $graph{ $vertex } } )
{
- unless ( keys %{"$parent\::"} )
+ if ( exists $graph{ $adjacent } )
{
- $needs_parent{$subclass} = { parents => $def->{isa},
- def => $def };
- next MAKE_CLASSES;
- }
- }
+ next;
}
+ die
+ "Class $adjacent appears to be a typo as it is only"
+ . " specified in the 'isa' param for $vertex\n"
+ unless
+ exists $CLASSES{$adjacent}
+ or do { no strict 'refs'; keys %{"$adjacent\::"}; };
- $class->_make_subclass( subclass => $subclass,
- def => $def || {},
- );
+ # so $adjacent is not a subject to subclassing.
+ # we explicitly add it to an inheritance graph
+ # as one of the topmost ancestors.
+ $graph{ $adjacent } = +{};
}
-
- foreach my $subclass (keys %needs_parent)
- {
- # This will be used to spot circular references.
- my %seen;
- $class->_make_parents( \%needs_parent, $subclass, \%seen );
}
-}
-sub _make_parents
-{
- my $class = shift;
- my $needs = shift;
- my $subclass = shift;
- my $seen = shift;
- my $child = shift; # Just for error messages.
+ # @order is the result of topological ordering.
+ # It consists of class names to be brought into
+ # existence one after another, in sequence.
+ my @order;
- no strict 'refs';
+ my @vertices = sort keys %graph;
- # What if someone makes a typo in specifying their 'isa' param?
- # This should catch it. Either it's been made because it didn't
- # have missing parents OR it's in our hash as needing a parent.
- # If neither of these is true then the _only_ place it is
- # mentioned is in the 'isa' param for some other class, which is
- # not a good enough reason to make a new class.
- die "Class $subclass appears to be a typo as it is only specified in the 'isa' param for $child\n"
- unless exists $needs->{$subclass} || $CLASSES{$subclass} || keys %{"$subclass\::"};
+ # a set of vertices remaining for sorting
+ my %remaining = map { $_ => 1 } @vertices;
+ my $n = scalar @vertices;
+ while ( @order < $n )
+ {
+ my @vertices = sort keys %remaining;
- foreach my $c ( @{ $needs->{$subclass}{parents} } )
+ # looking for a class which is not dependant on
+ # any other classes forming @vertices
+ my $vertex = undef;
+ foreach my $i ( @vertices )
{
- # It's been made
- next if $CLASSES{$c} || keys %{"$c\::"};
+ if ( not keys %{ $graph{ $i } } )
+ {
+ $vertex = $i;
+ last;
+ }
+ }
- die "There appears to be some circularity involving $subclass\n"
- if $seen->{$subclass};
+ # if we did not find one, this means the inheritance
+ # graph has some cycles, so its vertices cannot be
+ # ordered.
+ if ( not defined $vertex )
+ {
+ # The Floyd-Warshall algorithm is used for building
+ # a transitive closure of our inheritance graph, which
+ # in turn is used to easily determine any circular
+ # dependencies.
+ #
+ # This algorithm has a computational complexity cubical
+ # proportional to a size of @vertices.
+ # Hopefully, it won't get called way too often. After all,
+ # that's just error reporting occurring in import()
+ # method, which means it is usually get called during
+ # compilation phase, which usually means as early as
+ # possible.
+ for my $k ( @vertices )
+ {
+ for my $i ( @vertices )
+ {
+ for my $j ( @vertices )
+ {
+ if (
+ not $graph{ $i }{ $j }
+ and $graph{ $i }{ $k }
+ and $graph{ $k }{ $j }
+ )
+ {
- $seen->{$subclass} = 1;
+ $graph{ $i }{ $j } = 1;
+ }
+ }
+ }
+ }
+ my ( $vertex ) = grep { exists $graph{ $_ }{ $_ } } @vertices;
+ if ( defined $vertex )
+ {
+ die 'Circular dependency involving ' . $vertex;
+ }
- $class->_make_parents( $needs, $c, $seen, $subclass );
+ # a safety watermark
+ die 'Circular dependencies involving ' . join( ', ' => @vertices );
+ }
+ push @order, $vertex;
+ delete $remaining{ $vertex };
+ foreach my $i ( @vertices )
+ {
+ delete $graph{ $i }{ $vertex };
+ }
}
- return if $CLASSES{$subclass} || keys %{"$subclass\::"};
+ # do the subclassing
+ foreach my $subclass ( @order )
+ {
+ my $def = $class_def{$subclass};
+
+ # skipping occasional existing classes - the ones
+ # which don't need populating with exceptions-related
+ # methods.
+ next if $CLASSES{$subclass};
+ next if
+ do { no strict 'refs'; keys %{"$subclass\::"}; }
+ and not exists $class_def{$subclass};
$class->_make_subclass( subclass => $subclass,
- def => $needs->{$subclass}{def} );
+ def => $def || {},
+ );
+ }
+ return;
}
sub _make_subclass
@@ -148,9 +206,23 @@
{
@fields = UNIVERSAL::isa($fields, 'ARRAY') ? @$fields : $fields;
- $code .=
- "sub Fields { return (\$_[0]->SUPER::Fields, " .
- join(", ", map { "'$_'" } @fields) . ") }\n\n";
+ $code .= <<'EOPERL';
+sub Fields
+{
+ return Exception::Class::_unify(
+EOPERL
+ $code .= join(", ", map { "'$_'" } @fields);
+ $code .= <<'EOPERL';
+ , Exception::Class::_walk_ancestors(
+ sub {
+ return $_[0]->Fields if $_[0]->can('Fields');
+ return ();
+ }
+ , $_[0]
+ )
+ );
+}
+EOPERL
foreach my $field (@fields)
{
@@ -186,6 +258,41 @@
sub Classes { sort keys %Exception::Class::CLASSES }
+sub _unify { return sort keys %{ +{ map { $_ => 1 } @_ } } }
+
+sub _walk_ancestors(&$)
+{
+ my @result;
+ my ( $callback, $start ) = @_;
+ $start = ref( $start ) || $start;
+ if ( !defined( $start ) or !length( $start ) ) {
+ return;
+ }
+ my @stack;
+ {
+ no strict 'refs';
+ push @stack, @{ "$start\::ISA" };
+ }
+ my %seen = ( $start => 1 );
+ while ( my $invocant = shift @stack ) {
+ $invocant = ref( $invocant ) || $invocant;
+ if ( !defined( $invocant ) or !length( $invocant ) ) {
+ next;
+ }
+ if ( '::' eq substr( $invocant, 0, 2 ) ) {
+ substr( $invocant, 0, 2 ) = 'main::';
+ }
+ next if exists $seen{ $invocant };
+ {
+ no strict 'refs';
+ unshift @stack, @{ "$invocant\::ISA" };
+ }
+ push @result, $callback->( $invocant );
+ $seen{ $invocant }++;
+ }
+ return @result;
+}
+
package Exception::Class::Base;
use Class::Data::Inheritable;
