File Coverage

blib/lib/Devel/Init.pm

Criterion	Covered	Total	%
statement	136	187	72.7
branch	41	74	55.4
condition	8	14	57.1
subroutine	21	26	80.7
pod	4	4	100.0
total	210	305	68.8

package Devel::Init;
use strict;

use vars qw<
    $VERSION @EXPORT_OK @Predicates
    %Attribs @Inits $StackTrace $DefaultInit
>;
BEGIN {
    $VERSION= 0.001_002;
    $DefaultInit= 1;    # RunInits('default') at INIT-time?

    # Just in case somebody wants Exporter.pm-like information:
    @EXPORT_OK= (
        ':Init',            # Allows: sub foo :Init(...)
        ':NoDefault',       # Disables default initialization step
        'RegisterInit',     # RegisterInit(\&sub,@predicates)
        'RunInits',         # RunInits(@options,@predicates)
        'InitBlock',        # $single ||= InitBlock { ... return $init; };
        'InitSub',          # $single ||= InitSub( sub { ... return $init; } );
        '-StackTrace',      # Add a stack trace to a fatal error
        '-NoStackTrace',    # Restore default of no stack traces
        '@Predicates',      # Current list of predicates in RunInits()
    );
}

use constant {
    # Name of sub called when "sub foo :Init" code is compiled:
    AttrSetter => 'MODIFY_CODE_ATTRIBUTES',
    # Name of sub called by attributes::get() to retrieve sub attributes:
    AttrGetter => 'FETCH_CODE_ATTRIBUTES',
};

return 1;   # Only subroutine definitions to be found below this point


INIT {
    RunInits( 'default' )
        if  $DefaultInit;
}


sub import
{
    my( $us, @what )= @_;
    my $pkg= caller();

    local( $_ );
    for(  @what  ) {
        if(  /^:Init$/  ) {
            _exportInit( $pkg );
        } elsif(  /^:NoDefault$/  ) {
            $DefaultInit= 0;
        } elsif(  /^-(No)?StackTrace$/  ) {
            $StackTrace= ! $1;
        } elsif(  /^\@(Predicates)$/  ) {
            _export( $pkg, 'ARRAY', '@', $1 );
        } elsif(  /^&?(RunInits|RegisterInit|InitBlock|InitSub)$/  ) {
            my $sub= $1;
            $DefaultInit= 0
                if  'RunInits' eq $sub;
            _export( $pkg, 'CODE', '&', $sub );
        } else {
            _blameCaller( 1, __PACKAGE__, " does not export ($_)" );
        }
    }
}


sub _blameCaller
{
    my( $depth, @text )= @_;
    my( $pkg, $file, $line )= caller($depth);
    die @text, " at $file line $line\n";
}


sub _export
{
    my( $pkg, $type, $sig, $name )= @_;
    my $glob= _getGlob( $pkg, $name );
    my $src= *{ _getGlob( __PACKAGE__, $name ) }{$type};
    die $sig, __PACKAGE__, "::$name is not of type $type?!"
        if  $type ne ref($src);
    die __PACKAGE__, "::$name not defined?!"
        if  ! $src;
    if(  *{$glob}{$type}  ) {
        _blameCaller( 2, __PACKAGE__,
            " won't export $sig$name over existing definition" );
    }
    *{$glob}= $src;
}


sub _getGlob
{
    my( $pkg, $name )= @_;
    my $stash= do { no strict 'refs'; \%{$pkg.'::'} };
    my $glob= \$stash->{$name};
    if(  'GLOB' ne ref $glob  ) {
        # Must be 5.10 with its space optimization!
        # So we need to force a real glob to be created.
        # This means that that sub was actually defined as a constant, but
        # we'll let the likely *{$glob}= sub ...; code trigger the warning.
        # We only do this to prevent the completely unenlightening
        # but fatal "not a GLOB reference" error.
        {
            no strict 'refs';
            ${$pkg.'::'.$name}= undef;
        }
        $glob= \$stash->{$name};
        die "Can't coerce optimized STAB entry ($pkg\::$name) into real GLOB"
            if  'GLOB' ne ref $glob;
    }
    return $glob;
}


sub _exportInit
{
    my( $pkg )= @_;
    # Export a &MODIFY_CODE_ATTRIBUTES to the calling package

    my $glob= _getGlob( $pkg, AttrSetter() );
    my $prev= *{$glob}{CODE};
    if(  ! $prev  ) {
        *{$glob}= \&_newAttrib;
    } else {
        my $prevSetter= $prev;
        *{$glob}= sub {
            return _newAttrib( @_[0,1], $prevSetter->(@_) );
        };
    }

    $glob= _getGlob( $pkg, AttrGetter() );
    $prev= *{$glob}{CODE};
    if(  ! $prev  ) {
        *{$glob}= \&_getAttribs;
    } else {
        my $prevGetter= $prev;
        *{$glob}= sub {
            return( $prevGetter->(@_), _getAttribs(@_) );
        };
    }
}


sub _getAttribs
{
    my( $code )= @_;
    my $addr;
    if(  'CODE' eq ref $code  ) {
        $addr= 0 + $code;
    } else {
        die AttrGetter(), " given a non-code reference: $code";
    }
    return @{ $Attribs{ 0 + $code } || [] };
}


sub _newAttrib
{
    my( $pkg, $code, @attribs )= @_;
    my @left;

    local( $_ );
    for(  @attribs  ) {
        if(  /^Init\b/  ) {
            push @{ $Attribs{ 0 + $code } }, $_;
            s/^Init\(?//;
            s/\)$//;
            _registerInitFor( $pkg, $code, split /[,\s]+/, $_ );
        } else {
            push @left, $_;
        }
    }

    return @left;
}


sub _registerInitFor
{
    my( $pkg, $code, @conds )= @_;
    @conds= map {
        if(  /^(\\?)\@(\w+)$/  ) {
            my( $asRef, $name )= ( $1, $2 );
            my $av= *{ _getGlob( $pkg, $name ) }{ARRAY};
            if(  ! $av  ) {
                _blameCaller( 2,
                    "Undeclared array name, \@$pkg\::$name, in :Init(@conds)",
                );
            } elsif(  $asRef  ) {
                $av;
            } else {
                @$av;
            }
        } elsif(  ! /^\w[-.\w]*$/  ) {
            _blameCaller( 2,
                "Invalid predicate name, $_, in :Init(@conds)",
            );
        } else {
            $_;
        }
    } @conds;
    push @Inits, @conds ? [ $code, @conds ] : $code;
}


sub InitBlock(&)
{
    my( $code )= @_;
    return InitSub( $code, 1 );
}


{
    my %running;
    my @stack;


    sub InitSub
    {
        my( $code, $depth )= @_;
        my( $pkg, $file, $line, $sub )= caller( $depth || 0 );
        my $key= join ",", $pkg, $sub, $line, $file;
        for my $val (  $running{$key}  ) {
            if(  defined $val  ) {
                die _cycleReport( $val, $pkg, $sub, $line );
            }
            $val= @stack;
        }
        push @stack, $key;
        my @ret;
        if(  wantarray  ) {
            @ret= $code->();
        } else {
            $ret[0]= $code->();
        }
        delete $running{$key};
        pop @stack;
        return  wantarray  ?  @ret  :  $ret[0];
    }


    sub _cycleReport
    {
        my( $start, $pkg, $sub, $line )= @_;
        my $steps= @stack - $start;
        my $err= "Circular initialization dependency detected.\n";
        if(  $StackTrace  ) {
            require Carp;
            $err= Carp::longmess( $err );
        }
        $err .= join ' ',
            "The following initialization steps",
            "form the $steps-step cycle:\n";
        for my $i (  $start .. $#stack  ) {
            my( $pkg, $sub, $line, $file )= split /,/, $stack[$i];
            $err .= "    $pkg\::$sub() (line $line) calls\n";
        }
        $err .= "    $pkg\::$sub().\n";
        $err .= "$pkg\::$sub() indirectly calls itself!\n";
        return $err;
    }

}


sub RegisterInit
{
    # my( $code, @conds )= @_;
    my $pkg= caller();
    _registerInitFor( $pkg, @_ );
}


sub _runOneInit
{
    my( $code, $svFail )= @_;
    my $error;
    my $okay= do {
        my $prev= $SIG{__DIE__};
        local $SIG{__DIE__}= sub {
            if(  ! $StackTrace  ) {
                $error= $_[0];
            } else {
                require Carp;
                $error= Carp::longmess( $_[0] );
            }
            die @_
                if  ! $prev;
            $prev->( @_ );
        };

        eval { $code->(); 1 };
    };
    if(  ! $okay  ) {
        $$svFail=
            $StackTrace  &&  $error
                ?   $error
                :   $@ || $error || "Unknown failure initializing";
    }
}


sub _rankConds
{
    my( @conds )= @_;
    return map {
        if(  s/^not_//  ) {
            ( $_, -1 );
        } elsif(  s/^only_//  ) {
            ( $_, 2 );
        } else {
            ( $_, 1 );
        }
    } @conds;
}


sub _skipInit
{
    my( $code, $hvHave, $svFail )= @_;
    my @need;
    ( $code, @need )= @$code
        if  'ARRAY' eq ref($code);

    my %need= _rankConds( @need );
    for my $cond (  keys %need, keys %$hvHave  ) {
        return 1    # We skipped this init; keep it around to run later
            if  1 < abs( ($need{$cond}||0) - ($hvHave->{$cond}||0) );
    }

    _runOneInit( $code, $svFail );
    return 0;   # We didn't skip this init; don't run it again
}


sub RunInits
{
    local( $StackTrace )= $StackTrace;
    while(  @_  &&  $_[0] =~ /^-/  ) {
        local $_= shift @_;
        if(  /^-(No)StackTrace$/i  ) {
            $StackTrace= ! $1;
        } else {
            _blameCaller( 1, "Unknown RunInits() option, $_" );
        }
    }
    local( @Predicates )= @_;
    my %have= _rankConds( @_ );
    my $inits= 0+@Inits;

    my $fail;
    @Inits= grep {
        $fail  ||  _skipInit( $_, \%have, \$fail );
    } @Inits;
    die $fail
        if  $fail;

    return $inits;
}


__END__