Class::C3 - 0.07 release;

diff --git a/ChangeLog b/ChangeLog
index bb69c86..9c211f2 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,15 @@
 Revision history for Perl extension Class::C3.
 
-0.06 - 
+0.07 - Wed, Nov 23, 2005
+    * all bugs found by, and fixes provided by Matt S. Trout *
+    - fixed issue caused when module is imported more than once
+    - fixed subtle bug in how next::method is calculated
+        - added test for this
+        
+    - added util/visualize_c3.pl tool, which visualizes C3 
+      dispatch order using GraphViz
+
+0.06 - Tues, Nov 15, 2005
     - added Sub::Name to dependencies (even though it is
       just for the tests)
     - removed OS X resource fork which slipped into the tar.gz

diff --git a/MANIFEST b/MANIFEST
index eff3a5b..749dc2a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -10,6 +10,7 @@ t/02_MRO.t
 t/03_MRO.t
 t/04_MRO.t
 t/05_MRO.t
+t/06_MRO.t
 t/10_Inconsistent_hierarchy.t
 t/20_reinitialize.t
 t/21_C3_with_overload.t
@@ -25,3 +26,4 @@ t/lib/C.pm
 t/lib/D.pm
 t/lib/E.pm
 t/lib/F.pm
+util/visualize_c3.pl

diff --git a/Makefile.PL b/Makefile.PL
index 8df0ff9..ab808e4 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -6,6 +6,7 @@ WriteMakefile(
         'Test::More'      => 0.47,
         'Test::Exception' => 0.15,
         'Scalar::Util'    => 1.10,
-        'Sub::Name'       => 0
+        'Sub::Name'       => 0,
+        'NEXT'            => 0,
                }
 );

diff --git a/README b/README
index bb4f26e..e2886be 100644 (file)
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Class::C3 version 0.06
+Class::C3 version 0.07
 ===========================
 
 INSTALLATION

diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm
index 6ca3999..3055c17 100644 (file)
--- a/lib/Class/C3.pm
+++ b/lib/Class/C3.pm
@@ -6,7 +6,7 @@ use warnings;
 
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.06';
+our $VERSION = '0.07';
 
 # this is our global stash of both 
 # MRO's and method dispatch tables
@@ -22,7 +22,7 @@ our $VERSION = '0.06';
 #      has_overload_fallback => (1 | 0)
 #   }
 #
-my %MRO;
+our %MRO;
 
 # use these for debugging ...
 sub _dump_MRO_table { %MRO }
@@ -36,7 +36,7 @@ sub import {
     return if $TURN_OFF_C3;
     # make a note to calculate $class 
     # during INIT phase
-    $MRO{$class} = undef;
+    $MRO{$class} = undef unless exists $MRO{$class};
 }
 
 ## initializers
@@ -205,7 +205,7 @@ use warnings;
 
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.03';
+our $VERSION = '0.04';
 
 our %METHOD_CACHE;
 
@@ -228,6 +228,8 @@ sub method {
       no strict 'refs';
       my $found;
       foreach my $class (@MRO) {
+          next if (defined $Class::C3::MRO{$class} && 
+                   defined $Class::C3::MRO{$class}{methods}{$label});          
           last if (defined ($found = *{$class . '::' . $label}{CODE}));
       }
 

diff --git a/t/06_MRO.t b/t/06_MRO.t
new file mode 100644 (file)
index 0000000..8cfadd5
--- /dev/null
+++ b/t/06_MRO.t
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN {
+    use_ok('Class::C3');
+    # uncomment this line, and re-run the
+    # test to see the normal p5 dispatch order
+    #$Class::C3::TURN_OFF_C3 = 1;    
+}
+
+=pod
+
+This tests a strange bug found by Matt S. Trout 
+while building DBIx::Class. Thanks Matt!!!! 
+
+   <A>
+  /   \
+<C>   <B>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    use Class::C3; 
+
+    sub foo { 'Diamond_A::foo' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+    use Class::C3;     
+
+    sub foo { 'Diamond_B::foo => ' . (shift)->next::method }
+}
+{
+    package Diamond_C;
+    use Class::C3;    
+    use base 'Diamond_A';     
+
+}
+{
+    package Diamond_D;
+    use base ('Diamond_C', 'Diamond_B');
+    use Class::C3;    
+    
+    sub foo { 'Diamond_D::foo => ' . (shift)->next::method }    
+}
+
+is_deeply(
+    [ Class::C3::calculateMRO('Diamond_D') ],
+    [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo, 
+   'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', 
+   '... got the right next::method dispatch path');

diff --git a/util/visualize_c3.pl b/util/visualize_c3.pl
new file mode 100644 (file)
index 0000000..7a328d7
--- /dev/null
+++ b/util/visualize_c3.pl
@@ -0,0 +1,83 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+=pod
+
+This is a visualization tool to help with 
+understanding large MI hierarchies. It will
+output a DOT file for rendering with Graphviz.
+
+NOTE:
+This program is currently very primative, and 
+may break under some circumstances. If you 
+encounter one of those circumstances, please
+email me about it so that I can improve this 
+tool. 
+
+GRAPH LEGEND:
+In the graphs the green arrows are the ISA, 
+and the red arrows are the C3 dispatch order.
+
+=cut
+
+use Class::C3 ();
+
+@ARGV || die "usage : visualize_c3.pl <class-to-visualize> | <file-to-load> <class-to-visualize> <file-to-output>";
+
+my ($class, $OUT);
+if (scalar @ARGV == 1) {
+    $class = shift @ARGV;
+    eval "use $class";
+    die "Could not load '$class' :\n$@" if $@;
+}
+else {
+    my $file = shift @ARGV;
+    $class = shift @ARGV;    
+    $OUT = shift @ARGV;
+    do $file;
+    die "Could not load '$file' :\n$@" if $@;    
+}
+
+Class::C3->initialize();
+
+my @MRO = Class::C3::calculateMRO($class);
+
+sub get_class_str {
+    my $class = shift;
+    (join "_" => (split '::' => $class));    
+}
+
+my $output = "graph test {\n";
+
+my $prev;
+foreach my $class (@MRO) {
+    my $class_str = get_class_str($class);
+    $output .= "node_${class_str} [ label = \"" . $class . "\" ];\n";
+    {
+        no strict 'refs';
+        foreach my $super (@{"${class}::ISA"}) {
+            $output .= "node_" . get_class_str($super) . 
+                       " -- node_${class_str}" .
+                       " [ dir = back, color = green ];\n";
+        }
+    }
+    if ($prev) {
+        $output .= "node_${class_str} -- node_${prev}  [ dir = back, color = red ];\n";
+    }    
+    $prev = $class_str;
+}
+
+$output .= "}\n";
+
+warn $output;
+
+if ($OUT) {
+    open OUT, ">", $OUT || die "could not open '$OUT' for output";
+    print OUT $output;
+    close OUT;
+}
+else {
+    print $output;
+}
\ No newline at end of file