X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSelfLoader.pm;h=5605c2574239a84a882aa81a0ede78bd95f72be3;hb=3182b11b46e28871b3a0e0b479b6cc939a4a90b1;hp=294b6bc6b076394a3135a217af4690429bc79df4;hpb=cca8f13b7a786baee2df1fba298a1923907c3bad;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm index 294b6bc..5605c25 100644 --- a/lib/SelfLoader.pm +++ b/lib/SelfLoader.pm @@ -1,20 +1,50 @@ package SelfLoader; -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(AUTOLOAD); -$VERSION = "1.0905"; -sub Version {$VERSION} -$DEBUG = 0; - -my %Cache; # private cache for all SelfLoader's client packages - +use 5.008; +use strict; +our $VERSION = "1.15"; + +# The following bit of eval-magic is necessary to make this work on +# perls < 5.009005. +use vars qw/$AttrList/; +BEGIN { + if ($] > 5.009004) { + eval <<'NEWERPERL'; +use 5.009005; # due to new regexp features +# allow checking for valid ': attrlist' attachments +# see also AutoSplit +$AttrList = qr{ + \s* : \s* + (?: + # one attribute + (?> # no backtrack + (?! \d) \w+ + (? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? + ) + (?: \s* : \s* | \s+ (?! :) ) + )* +}x; + +NEWERPERL + } + else { + eval <<'OLDERPERL'; # allow checking for valid ': attrlist' attachments # (we use 'our' rather than 'my' here, due to the rather complex and buggy # behaviour of lexicals with qr// and (??{$lex}) ) our $nested; $nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x; our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; -our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; +$AttrList = qr{ \s* : \s* (?: $one_attr )* }x; +OLDERPERL + } +} +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(AUTOLOAD); +sub Version {$VERSION} +sub DEBUG () { 0 } + +my %Cache; # private cache for all SelfLoader's client packages # in croak and carp, protect $@ from "require Carp;" RT #40216 @@ -22,7 +52,8 @@ sub croak { { local $@; require Carp; } goto &Carp::croak } sub carp { { local $@; require Carp; } goto &Carp::carp } AUTOLOAD { - print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG; + our $AUTOLOAD; + print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if DEBUG; my $SL_code = $Cache{$AUTOLOAD}; my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@ unless ($SL_code) { @@ -35,9 +66,12 @@ AUTOLOAD { if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/); croak "Undefined subroutine $AUTOLOAD" unless $SL_code; } - print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG; + print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if DEBUG; - eval $SL_code; + { + no strict; + eval $SL_code; + } if ($@) { $@ =~ s/ at .*\n//; croak $@; @@ -53,18 +87,27 @@ sub load_stubs { shift->_load_stubs((caller)[0]) } sub _load_stubs { # $endlines is used by Devel::SelfStubber to capture lines after __END__ my($self, $callpack, $endlines) = @_; + no strict "refs"; my $fh = \*{"${callpack}::DATA"}; + use strict; my $currpack = $callpack; my($line,$name,@lines, @stubs, $protoype); - print STDERR "SelfLoader::load_stubs($callpack)\n" if $DEBUG; + print STDERR "SelfLoader::load_stubs($callpack)\n" if DEBUG; croak("$callpack doesn't contain an __DATA__ token") - unless fileno($fh); + unless defined fileno($fh); + # Protect: fork() shares the file pointer between the parent and the kid + if(sysseek($fh, tell($fh), 0)) { + open my $nfh, '<&', $fh or croak "reopen: $!";# dup() the fd + close $fh or die "close: $1"; # autocloses, but be paranoid + open $fh, '<&', $nfh or croak "reopen2: $!"; # dup() the fd "back" + close $nfh or die "close after reopen: $1"; # autocloses, but be paranoid + } $Cache{"${currpack}::) and $line !~ m/^__END__/) { - if ($line =~ m/^sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$attr_list)?)/) { + if ($line =~ m/^\s*sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$AttrList)?)/) { push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); $protoype = $2; @lines = ($line); @@ -110,6 +153,7 @@ sub _load_stubs { } } push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); + no strict; eval join('', @stubs) if @stubs; } @@ -120,7 +164,7 @@ sub _add_to_cache { carp("Redefining sub $fullname") if exists $Cache{$fullname}; $Cache{$fullname} = join('', "package $pack; ",@$lines); - print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if $DEBUG; + print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if DEBUG; # return stub to be eval'd defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;" } @@ -318,4 +362,73 @@ will ensure that the packages 'foo' and 'baz' correctly have the B C method when the data after C<__DATA__> is first parsed. +=head1 AUTHOR + +C is maintained by the perl5-porters. Please direct +any questions to the canonical mailing list. Anything that +is applicable to the CPAN release can be sent to its maintainer, +though. + +Author and Maintainer: The Perl5-Porters + +Maintainer of the CPAN release: Steffen Mueller + +=head1 COPYRIGHT AND LICENSE + +This package has been part of the perl core since the first release +of perl5. It has been released separately to CPAN so older installations +can benefit from bug fixes. + +This package has the same copyright and license as the perl core: + + Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others + + All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either + the GNU General Public License or the Artistic License for more details. + + You should have received a copy of the Artistic License with this + Kit, in the file named "Artistic". If not, I'll be glad to provide one. + + You should also have received a copy of the GNU General Public License + along with this program in the file named "Copying". If not, write to the + Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307, USA or visit their web page on the internet at + http://www.gnu.org/copyleft/gpl.html. + + For those of you that choose to use the GNU General Public License, + my interpretation of the GNU General Public License is that no Perl + script falls under the terms of the GPL unless you explicitly put + said script under the terms of the GPL yourself. Furthermore, any + object code linked with perl does not automatically fall under the + terms of the GPL, provided such object code only adds definitions + of subroutines and variables, and does not otherwise impair the + resulting interpreter from executing any standard Perl script. I + consider linking in C subroutines in this manner to be the moral + equivalent of defining subroutines in the Perl language itself. You + may sell such an object file as proprietary provided that you provide + or offer to provide the Perl source, as specified by the GNU General + Public License. (This is merely an alternate way of specifying input + to the program.) You may also sell a binary produced by the dumping of + a running Perl script that belongs to you, provided that you provide or + offer to provide the Perl source as specified by the GPL. (The + fact that a Perl interpreter and your code are in the same binary file + is, in this case, a form of mere aggregation.) This is my interpretation + of the GPL. If you still have concerns or difficulties understanding + my intent, feel free to contact me. Of course, the Artistic License + spells all this out for your protection, so you may prefer to use that. + =cut