Dual-life Devel::SelfStubber

2 files changed, 435 insertions, 0 deletions

diff --git a/dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm b/dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm
new file mode 100644
index 0000000000..e55018e44c
--- /dev/null
+++ b/dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm
@@ -0,0 +1,152 @@
+package Devel::SelfStubber;
+use File::Spec;
+require SelfLoader;
+@ISA = qw(SelfLoader);
+@EXPORT = 'AUTOLOAD';
+$JUST_STUBS = 1;
+$VERSION = 1.03;
+sub Version {$VERSION}
+
+# Use as
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
+# (LIB defaults to '.') e.g.
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
+# would print out stubs needed if you added a __DATA__ before the subs.
+# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
+# module with the stubs entered just before the __DATA__
+
+sub _add_to_cache {
+    my($self,$fullname,$pack,$lines, $prototype) = @_;
+    push(@DATA,@{$lines});
+    if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
+    '1;';
+}
+
+sub _package_defined {
+    my($self,$line) = @_;
+    push(@DATA,$line);
+}
+
+sub stub {
+    my($self,$module,$lib) = @_;
+    my($line,$end_data,$fh,$mod_file,$found_selfloader);
+    $lib ||= File::Spec->curdir();
+    ($mod_file = $module) =~ s,::,/,g;
+    $mod_file =~ tr|/|:| if $^O eq 'MacOS';
+
+    $mod_file = File::Spec->catfile($lib, "$mod_file.pm");
+    $fh = "${module}::DATA";
+    my (@BEFORE_DATA, @AFTER_DATA, @AFTER_END);
+    @DATA = @STUBS = ();
+
+    open($fh,$mod_file) || die "Unable to open $mod_file";
+    local $/ = "\n";
+    while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
+	push(@BEFORE_DATA,$line);
+	$line =~ /use\s+SelfLoader/ && $found_selfloader++;
+    }
+    (defined ($line) && $line =~ m/^__DATA__/)
+      || die "$mod_file doesn't contain a __DATA__ token";
+    $found_selfloader ||
+	print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
+    if ($JUST_STUBS) {
+        $self->_load_stubs($module);
+    } else {
+        $self->_load_stubs($module, \@AFTER_END);
+    }
+    if ( fileno($fh) ) {
+	$end_data = 1;
+	while(defined($line = <$fh>)) {
+	    push(@AFTER_DATA,$line);
+	}
+    }
+    close($fh);
+    unless ($JUST_STUBS) {
+	print @BEFORE_DATA;
+    }
+    print @STUBS;
+    unless ($JUST_STUBS) {
+	print "1;\n__DATA__\n",@DATA;
+	if($end_data) { print "__END__ DATA\n",@AFTER_DATA; }
+	if(@AFTER_END) { print "__END__\n",@AFTER_END; }
+    }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Devel::SelfStubber - generate stubs for a SelfLoading module
+
+=head1 SYNOPSIS
+
+To generate just the stubs:
+
+    use Devel::SelfStubber;
+    Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+or to generate the whole module with stubs inserted correctly
+
+    use Devel::SelfStubber;
+    $Devel::SelfStubber::JUST_STUBS=0;
+    Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
+NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.
+
+MY_LIB_DIR defaults to '.' if not present.
+
+=head1 DESCRIPTION
+
+Devel::SelfStubber prints the stubs you need to put in the module
+before the __DATA__ token (or you can get it to print the entire
+module with stubs correctly placed). The stubs ensure that if
+a method is called, it will get loaded. They are needed specifically
+for inherited autoloaded methods.
+
+This is best explained using the following example:
+
+Assume four classes, A,B,C & D.
+
+A is the root class, B is a subclass of A, C is a subclass of B,
+and D is another subclass of A.
+
+                        A
+                       / \
+                      B   D
+                     /
+                    C
+
+If D calls an autoloaded method 'foo' which is defined in class A,
+then the method is loaded into class A, then executed. If C then
+calls method 'foo', and that method was reimplemented in class
+B, but set to be autoloaded, then the lookup mechanism never gets to
+the AUTOLOAD mechanism in B because it first finds the method
+already loaded in A, and so erroneously uses that. If the method
+foo had been stubbed in B, then the lookup mechanism would have
+found the stub, and correctly loaded and used the sub from B.
+
+So, for classes and subclasses to have inheritance correctly
+work with autoloading, you need to ensure stubs are loaded.
+
+The SelfLoader can load stubs automatically at module initialization
+with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
+avoid having the stub loading overhead associated with your
+initialization (though note that the SelfLoader::load_stubs method
+will be called sooner or later - at latest when the first sub
+is being autoloaded). In this case, you can put the sub stubs
+before the __DATA__ token. This can be done manually, but this
+module allows automatic generation of the stubs.
+
+By default it just prints the stubs, but you can set the
+global $Devel::SelfStubber::JUST_STUBS to 0 and it will
+print out the entire module with the stubs positioned correctly.
+
+At the very least, this is useful to see what the SelfLoader
+thinks are stubs - in order to ensure future versions of the
+SelfStubber remain in step with the SelfLoader, the
+SelfStubber actually uses the SelfLoader to determine which
+stubs are needed.
+
+=cut
diff --git a/dist/Devel-SelfStubber/t/Devel-SelfStubber.t b/dist/Devel-SelfStubber/t/Devel-SelfStubber.t
new file mode 100644
index 0000000000..4d69090474
--- /dev/null
+++ b/dist/Devel-SelfStubber/t/Devel-SelfStubber.t
@@ -0,0 +1,283 @@
+#!./perl -w
+
+use strict;
+use Devel::SelfStubber;
+use File::Spec::Functions;
+
+my $runperl = $^X;
+
+# ensure correct output ordering for system() calls
+
+select STDERR; $| = 1; select STDOUT; $| = 1;
+
+print "1..12\n";
+
+my @cleanup;
+
+END {
+  foreach my $file (reverse @cleanup) {
+    unlink $file or warn "unlink $file failed: $!" while -f $file;
+    rmdir $file or warn "rmdir $file failed: $!" if -d $file;
+  }
+}
+
+my $inlib = "SSI-$$";
+mkdir $inlib, 0777 or die $!;
+push @cleanup, $inlib;
+
+while (<DATA>) {
+  if (/^\#{16,}\s+(.*)/) {
+    my $f = $1;
+    my $file = catfile(curdir(),$inlib,$f);
+    push @cleanup, $file;
+    open FH, ">$file" or die $!;
+  } else {
+    print FH;
+  }
+}
+close FH;
+
+{
+  my $file = "A-$$";
+  push @cleanup, $file;
+  open FH, ">$file" or die $!;
+  select FH;
+  Devel::SelfStubber->stub('xChild', $inlib);
+  select STDOUT;
+  print "ok 1\n";
+  close FH or die $!;
+
+  open FH, $file or die $!;
+  my @A = <FH>;
+
+  if (@A == 1 && $A[0] =~ /^\s*sub\s+xChild::foo\s*;\s*$/) {
+    print "ok 2\n";
+  } else {
+    print "not ok 2\n";
+    print "# $_" foreach (@A);
+  }
+}
+
+{
+  my $file = "B-$$";
+  push @cleanup, $file;
+  open FH, ">$file" or die $!;
+  select FH;
+  Devel::SelfStubber->stub('Proto', $inlib);
+  select STDOUT;
+  print "ok 3\n"; # Checking that we did not die horribly.
+  close FH or die $!;
+
+  open FH, $file or die $!;
+  my @B = <FH>;
+
+  if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
+    print "ok 4\n";
+  } else {
+    print "not ok 4\n";
+    print "# $_" foreach (@B);
+  }
+
+  close FH or die $!;
+}
+
+{
+  my $file = "C-$$";
+  push @cleanup, $file;
+  open FH, ">$file" or die $!;
+  select FH;
+  Devel::SelfStubber->stub('Attribs', $inlib);
+  select STDOUT;
+  print "ok 5\n"; # Checking that we did not die horribly.
+  close FH or die $!;
+
+  open FH, $file or die $!;
+  my @C = <FH>;
+
+  if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/
+      && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) {
+    print "ok 6\n";
+  } else {
+    print "not ok 6\n";
+    print "# $_" foreach (@C);
+  }
+
+  close FH or die $!;
+}
+
+# "wrong" and "right" may change if SelfLoader is changed.
+my %wrong = ( xParent => 'xParent', xChild => 'xParent' );
+my %right = ( xParent => 'xParent', xChild => 'xChild' );
+if ($^O eq 'VMS') {
+    # extra line feeds for MBX IPC
+    %wrong = ( xParent => "xParent\n", xChild => "xParent\n" );
+    %right = ( xParent => "xParent\n", xChild => "xChild\n" );
+}
+my @module = qw(xParent xChild)
+;
+sub fail {
+  my ($left, $right) = @_;
+  while (my ($key, $val) = each %$left) {
+    # warn "$key $val $$right{$key}";
+    return 1
+      unless $val eq $$right{$key};
+  }
+  return;
+}
+
+sub faildump {
+  my ($expect, $got) = @_;
+  foreach (sort keys %$expect) {
+    print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
+  }
+}
+
+# Now test that the module tree behaves "wrongly" as expected
+
+foreach my $module (@module) {
+  my $file = "$module--$$";
+  push @cleanup, $file;
+  open FH, ">$file" or die $!;
+  print FH "use $module;
+print ${module}->foo;
+";
+  close FH or die $!;
+}
+
+{
+  my %output;
+  foreach my $module (@module) {
+    print "# $runperl \"-I$inlib\" $module--$$\n";
+    ($output{$module} = `$runperl "-I$inlib" $module--$$`)
+      =~ s/\'s foo//;
+  }
+
+  if (&fail (\%wrong, \%output)) {
+    print "not ok 7\n", &faildump (\%wrong, \%output);
+  } else {
+    print "ok 7\n";
+  }
+}
+
+my $lib="SSO-$$";
+mkdir $lib, 0777 or die $!;
+push @cleanup, $lib;
+$Devel::SelfStubber::JUST_STUBS=0;
+
+undef $/;
+foreach my $module (@module, 'Data', 'End') {
+  my $file = catfile(curdir(),$lib,"$module.pm");
+  my $fileo = catfile(curdir(),$inlib,"$module.pm");
+  open FH, $fileo or die "Can't open $fileo: $!";
+  my $contents = <FH>;
+  close FH or die $!;
+  push @cleanup, $file;
+  open FH, ">$file" or die $!;
+  select FH;
+  if ($contents =~ /__DATA__/) {
+    # This will die for any module with no  __DATA__
+    Devel::SelfStubber->stub($module, $inlib);
+  } else {
+    print $contents;
+  }
+  select STDOUT;
+  close FH or die $!;
+}
+print "ok 8\n";
+
+{
+  my %output;
+  foreach my $module (@module) {
+    print "# $runperl \"-I$lib\" $module--$$\n";
+    ($output{$module} = `$runperl "-I$lib" $module--$$`)
+      =~ s/\'s foo//;
+  }
+
+  if (&fail (\%right, \%output)) {
+    print "not ok 9\n", &faildump (\%right, \%output);
+  } else {
+    print "ok 9\n";
+  }
+}
+
+# Check that the DATA handle stays open
+system "$runperl -w \"-I$lib\" \"-MData\" -e \"Data::ok\"";
+
+# Possibly a pointless test as this doesn't really verify that it's been
+# stubbed.
+system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\"";
+
+# But check that the documentation after the __END__ survived.
+open FH, catfile(curdir(),$lib,"End.pm") or die $!;
+$_ = <FH>;
+close FH or die $!;
+
+if (/Did the documentation here survive\?/) {
+  print "ok 12\n";
+} else {
+  print "not ok 12 # information after an __END__ token seems to be lost\n";
+}
+
+__DATA__
+################ xParent.pm
+package xParent;
+
+sub foo {
+  return __PACKAGE__;
+}
+1;
+__END__
+################ xChild.pm
+package xChild;
+require xParent;
+@ISA = 'xParent';
+use SelfLoader;
+
+1;
+__DATA__
+sub foo {
+  return __PACKAGE__;
+}
+__END__
+################ Proto.pm
+package Proto;
+use SelfLoader;
+
+1;
+__DATA__
+sub bar ($$) {
+}
+################ Attribs.pm
+package Attribs;
+use SelfLoader;
+
+1;
+__DATA__
+sub baz : locked {
+}
+sub lv : lvalue : method {
+  my $a;
+  \$a;
+}
+################ Data.pm
+package Data;
+use SelfLoader;
+
+1;
+__DATA__
+sub ok {
+  print <DATA>;
+}
+__END__ DATA
+ok 10
+################ End.pm
+package End;
+use SelfLoader;
+
+1;
+__DATA__
+sub lime {
+  print "ok 11\n";
+}
+__END__
+Did the documentation here survive?