File Coverage

lib/load.pm

Criterion	Covered	Total	%
statement	76	156	48.7
branch	32	122	26.2
condition	5	17	29.4
subroutine	10	14	71.4
pod	0	1	0.0
total	123	310	39.6

package load;

$VERSION= '0.25';

#-------------------------------------------------------------------------------
# No, we're NOT using strict here.  There are several reasons, the most
# important being that strict bleeds into the string eval's that load.pm
# is doing, causing compilation errors in all but the most simple modules.
# If you _do_ want stricture as a developer of load.pm, simply de-activate
# the lines of the BEGIN block below here
#-------------------------------------------------------------------------------
BEGIN { # We're fooling the Kwalitee checker into thinking we're strict
use strict;
}

# do this at compile time
my $now;
BEGIN {

    # make sure we have warnings or dummy warnings for older Perl's
    eval { require warnings } or do { $INC{'warnings.pm'} = '' };

    # set flag indicating whether everything should be loaded immediately
    $now= $ENV{'LOAD_NOW'} || 0;   # environment var undocumented for now

    # "ifdef" is loaded, can we use it?
    if (defined $ifdef::VERSION) {
        die "Must have 'ifdef' version 0.07 or higher to handle on demand loading\n"
          if $ifdef::VERSION < 0.07;
        *IFDEF= sub () { 1 };
    }

    # ifdef not loaded
    else {
        *IFDEF= sub () { 0 };
    }

    # we're supposed to trace
    if ($ENV{'LOAD_TRACE'}) {
        *TRACE= sub () { 1 };
        eval <<'EOD'; # only way to ensure it isn't there when we're not tracing
sub _trace {
    my $tid = $threads::VERSION ? ' ['.threads->tid.']' : '';
    warn "load$tid: ",$_[0],$/;
} #_trace
EOD
    }

    # we're not supposed to trace
    else {
        *TRACE= sub () { 0 };
    }

    # make sure we intercept ->can
    no warnings 'redefine';
    my $can= \&UNIVERSAL::can;
    *UNIVERSAL::can= sub {
        &{$can}( @_ ) || (ref( $_[0] ) ? undef : _can( @_ ))
    };
} #BEGIN

# hash with modules that should be used extra, keyed to package
my %use;

# satisfy -require-
1;

#-------------------------------------------------------------------------------
#
# Class Methods
#
#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 package for which to add additional use-s
#      3 additional module to be used

sub register { $use{ $_[1] }= ( $use{ $_[1] } || '' ) . "use $_[2];" } #register

#-------------------------------------------------------------------------------
#
# Standard Perl Features
#
#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2..N various parameters

sub import {
    my $class  = shift;
    my ($module,undef,$lineno) = caller();

    # need to check / handle parameters specified
    if (@_) {
        my $inmain=   ( $module eq 'main' );
        my $autoload= !$inmain;
        my $scan=     1;
        my $thisnow=  $now;

        # check each parameter separately
        foreach (@_) {

            # handle "now"
            if ( $_ eq 'now' ) {
                ( $inmain ? $now= $thisnow : $thisnow )= $scan= 1;
            }

            # handle "ondemand"
            elsif ( $_ eq 'ondemand' ) {
                ( $inmain ? $now= $thisnow : $thisnow )= 0;
                $scan= 1;
            }

            # want to export AUTOLOAD sub (AUTOLOAD = AutoLoader compatible)
            elsif ( m#^(?:autoload|AUTOLOAD)$# ) {
                die "Can not $_ in main namespace" if $inmain;
                $autoload= 1;
            }

            # don't want to scan now
            elsif ( $_ eq 'dontscan' ) {
                ( $inmain ? $now= $thisnow : $thisnow )= $scan= 0;
            }

            # want to inherit AUTOLOAD
            elsif ( $_ eq 'inherit' ) {
                die "Can not inherit in main namespace" if $inmain;
                $autoload= 0;
            }

            # want to enable AutoLoader mode
            elsif ( $_ eq 'AutoLoader' ) {
                die "Can only activate AutoLoader emulation mode from script"
                  if !$inmain;

                # did not emulate AutoLoader before
                if ( !$INC{'AutoLoader.pm'} or
                      $INC{'AutoLoader.pm'} ne $INC{__PACKAGE__.'.pm' } ) {
                    *AutoLoader::import=   \&import;
                    *AutoLoader::AUTOLOAD= \&AUTOLOAD;

                    # mark as loaded now, owned by us
                    $INC{'AutoLoader.pm'}= $INC{__PACKAGE__.'.pm'};
                }
            }

            # huh?
            else {
                die "Don't know how to handle $_";
            }
        }

        # in a module, scan it if necessary
        if ( !$inmain ) {
            _scan( $module, $thisnow ) if $scan;
            no strict 'refs';
            *{$module.'::AUTOLOAD'}= \&AUTOLOAD if $autoload;
        }
    }

    # called from a script / command line, huh?
    elsif ( $module eq 'main' ) {
       die "Does not make sense to just 'use $class;' from your script"
         if $lineno;
    }

    # no parameters, scan the source
    else {
        _scan( $module );

        # export AUTOLOAD if called here
        if ( $class eq __PACKAGE__ ) {
            no strict 'refs';
            *{$module.'::AUTOLOAD'}= \&AUTOLOAD;
        }
    }
} #import

#-------------------------------------------------------------------------------

sub AUTOLOAD {

    # go execute intended AUTOLOAD if possible
    $load::AUTOLOAD =~ m#^(.*)::(.*?)$#;
    goto &{$load::AUTOLOAD} if _can( $1, $2 );

    # nothing to do if unknown DESTROY
    return if $2 eq 'DESTROY';

    # huh?
    my ( $package, $filename, $line )= caller;
    die "Undefined subroutine &$load::AUTOLOAD called at $filename line $line\n";
} #AUTOLOAD

#-------------------------------------------------------------------------------
#
# Internal Subroutines
#
#-------------------------------------------------------------------------------
# _scan
#
# Set up / load given module
#
#  IN: 1 module to scan (AAA::BBB)
#      2 optional: flag to load everything now

sub _scan {
    my $module=  shift;
    my $loadnow= defined( $_[0] ) ? shift : $now;

    # make sure we won't clobber sensitive system vars
    local $_= \my $foo; # make sure $_ is localized properly
    local( $!, $@ );

    # open the file to read
    my $file= _filename( $module )
      or die "Could not find file for '$module'";
    open( VERSION, "<$file" ) # use VERSION as glob to save memory
      or die "Could not open file '$file' for '$module': $!";
    binmode VERSION # needed for Windows systems, apparently
      or die "Could not set binmode on '$file': $!";

    # initializations
    my $line=    0;
    my $pod=     0;
    my $package= '';
    &ifdef::reset if IFDEF; # should get optimized away if not needed

    # look through all lines
    while ( readline VERSION ) {
        &ifdef::oneline if IFDEF; # should get optimized away if not needed
        $line++;

        # inside pod
        $pod= !m#^=cut#, next if m#^=\w#;
        next if $pod or m#^\s*\##;

        # we're done
        last if m#^__END__#;

        # not a package
        next if !m#^package\s+([\w:]+)\s*;#;

        # found a package
        die "Found package '$1' after '$package'" if $package;
        $package= $1;
    }

    # huh?
    die "Could not find package name"           if !$package;
    die "Found package $package inside '$file'" if $package ne $module;

    # initializations
    my $endline=  $line+1;
    my $endstart= tell VERSION;

    # loading now
    if ($loadnow) {
        _trace( "now $module, line $endline (offset $endstart, onwards)" )
         if TRACE;

        # load the source
        my $source= <<"SRC";
package $module;
no warnings;
#line $endline "$file (loaded now from offset $endstart)"
SRC
        $source .= do { local $/; readline(VERSION) =~ m#^(.*)$#s; $1 };
        eval ( IFDEF ? ifdef::process($source) : $source );
        die "Error evaluating source: $@" if $@;
    }

    # loading on demand
    else {
        my $start;
        my $sub= '';
        my $subline;
        my $length;

        # process all lines
        while ( readline VERSION ) {
            $length= length if IFDEF;
            &ifdef::oneline if IFDEF;
            $line++;

            # inside pod
            $pod= !m#^=cut#, next if m#^=\w#;
            next if $pod or m#^\s*\##;

            # we're done
            last if m#^__END__#;

            # huh?
            die "Only one package per file: found '$1' after '$package'"
              if m#^package\s+([\w:]+)\s*;#;

            # not at next sub yet
            next unless m#^sub\s+([\w:]+)#;

            # remember where previous sub starts, if any
            my $seek= tell(VERSION) - ( IFDEF ? $length : length );
            _store( $module, $sub, $subline, $start, $seek - $start ) if $sub;

            # set up for next iteration
            $sub= $1;
            die "Cannot handle fully qualified subroutine '$sub'\n"
              if $sub =~ m#::#;
            $subline= $line;
            $start=   $seek;
        }

        # store rest as a sub, if any
        _store(
          $module,
          $sub,
          $subline,
          $start,
          ( defined() ? tell(VERSION) - length() : -s VERSION ) - $start
        ) if $sub;
    }

    # we're done
    $load::AUTOLOAD{$module}= undef;
    close VERSION;

    return;
} #_scan

#-------------------------------------------------------------------------------
# _filename
#
# Return filename of module
#
#  IN: 1 module name (AAA::BBB)
# OUT: 1 filename (/..../AAA/BBB.pm) or undef if not known

sub _filename {

    # return filename from %INC
    ( my $key= $_[0] ) =~ s#::#/#g;
    my $filename= $INC{"$key.pm"};
    return $filename if !ref $filename;

    # return result of call instead
    return $filename->("$key.pm");
} #_filename

#-------------------------------------------------------------------------------
# _store
#
# Store information about subroutine in memory for later usage
#
#  IN: 1 module name
#      2 subroutine name (not fully qualified)
#      3 line number where sub starts
#      4 offset where sub starts
#      5 number of bytes to read

sub _store {
    _trace( "store $_[0]::$_[1], line $_[2] (offset $_[3], $_[4] bytes)" )
      if TRACE;

    # huh?
    eval "package $_[0]; sub $_[1]";
    die "Could not create stub: $@\n" if $@;

    # store the data
    $load::AUTOLOAD{ $_[0], $_[1] }= pack( 'w3', $_[2], $_[3], $_[4] )
} #_store

#-------------------------------------------------------------------------------
# _can
#
# Our version of ->can
#
#  IN: 1 module to load subroutine from
#      2 subroutine to load
# OUT: 1 reference to subroutine (if exists and loaded, else undef)

sub _can {
    my ( $module, $sub )= @_;

    # nothing to do here
    return if $module eq 'main';

    # scan file if we need to
    _scan( $module ) unless exists $load::AUTOLOAD{$module};

    # huh?  unknown sub?
    my ( $subline, $start, $length )=
      unpack( 'w3', $load::AUTOLOAD{ $module, $sub } || '' );
    return if !$start;

    # seek in the file where the source lives
    local( $!, $@ );
    my $file= _filename( $module )
      or die "Could not find file for '$module.pm'";
    open( VERSION, "<$file" ) # use VERSION glob to conserve memory
      or die "Could not open file '$file' for '$module.pm': $!";
    binmode VERSION # needed for Windows systems, apparently
      or die "Could not set binmode on '$file': $!";
    seek( VERSION, $start, 0 )
      or die "Could not seek to $start for $module\::$sub";

    # set up evallable pre-amble
    _trace( "ondemand ${module}::$sub, line $subline (offset $start, $length bytes)" ) if TRACE;
    my $use=    $use{$module} || '';
    my $source= <<"SRC";
package $module;
no warnings;$use
#line $subline "$file (loaded on demand from offset $start for $length bytes)"
SRC

    # get the stuff
    my $read= read( VERSION, $source, $length, length($source) );
    die "Error reading source: only read $read bytes instead of $length"
      if $read != $length;
    close VERSION;

    # initializations
    &ifdef::reset if IFDEF; # make sure "ifdef" starts afresh
    my $original= $source;

    # eval untainted copy
    $source =~ m#^(.*)$#s;
    $source= IFDEF ? ifdef::process($1) : $1;
    eval $source;
    die "load: $@\n$original====================\n$source" if $@;

    # done this one
    delete $load::AUTOLOAD{ $module, $sub };

    return \&{ $module . '::' . $sub };
} #_can

#-------------------------------------------------------------------------------

__END__