dslinux/user/perl/lib/Devel SelfStubber.pm SelfStubber.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:31 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/Devel
In directory antilope:/tmp/cvs-serv17422/lib/Devel

Added Files:
	SelfStubber.pm SelfStubber.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: SelfStubber.pm ---
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", at DATA;
    	if($end_data) { print "__END__ DATA\n", at AFTER_DATA; }
    	if(@AFTER_END) { print "__END__\n", at 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

--- NEW FILE: SelfStubber.t ---
#!./perl -w

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use strict;
use Devel::SelfStubber;
use File::Spec::Functions;

my $runperl = "$^X \"-I../lib\"";
$runperl =~ s|../lib|::lib:| if $^O eq 'MacOS';

# 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('Child', $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+Child::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 = ( Parent => 'Parent', Child => 'Parent' );
my %right = ( Parent => 'Parent', Child => 'Child' );
if ($^O eq 'VMS') {
    # extra line feeds for MBX IPC
    %wrong = ( Parent => "Parent\n", Child => "Parent\n" );
    %right = ( Parent => "Parent\n", Child => "Child\n" );
}
my @module = qw(Parent Child)
;
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__
################ Parent.pm
package Parent;

sub foo {
  return __PACKAGE__;
}
1;
__END__
################ Child.pm
package Child;
require Parent;
@ISA = 'Parent';
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?




More information about the dslinux-commit mailing list