view release on metacpan or  search on metacpan

lib/AutoReloader.pm  view on Meta::CPAN

=item checksub ($coderef)

set the checking subroutine. Class and object method. This subroutine will be
invoked with a subroutines source filename (full path) every time the sub for
which it is configured - but only if check for that subroutine is true -, and
should return some value special to that file.
Default is 'sub { (stat $_[0]) [9] }', i.e. mtime.

=back

=head1 SEE ALSO

 AutoLoader, AutoSplit, DBIx::VersionedSubs

=head1 BUGS

AutoReloader subroutines are always reported as __ANON__ (e.g. with Carp::cluck),
even if they are assigned to a symbol table entry. Which might not be a bug.

There might be others.

=head1 Author

 shmem <shmem@cpan.org>

=head1 CREDITS

Many thanks to thospel, Corion, diotalevi, tye and chromatic (these are their
http://perlmonks.org nicks) for review and most valuable hints.

=head1 COPYRIGHT

Copyright 2007 - 2021 by shmem <shmem@cpan.org>

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

package AutoReloader;

use strict;
use warnings;
use Scalar::Util;
use File::Spec;

our $VERSION   = 0.03;

use vars qw($Debug %AL);
$Debug = 0;

sub new {
    my $class  = shift;
    my $caller = caller;
    my $sub    = gensub ($caller,@_);

    bless $sub, $class;
}

sub auto {
    shift if __PACKAGE__ || $_[0] eq (caller(0))[0];
    $AL {'auto'} = shift if @_;
    $AL {'auto'};
}

sub check {
    my $self = shift;
    if(ref($self)) {
        ${ $AL {'Sub'} -> {Scalar::Util::refaddr ($self)} -> {'check'} }
	    = shift if @_;
        ${ $AL {'Sub'} -> {Scalar::Util::refaddr ($self)} -> {'check'} };
    }
    else {
        $AL {'check'}  = shift;
        $AL {'check'};
    }
}

sub checksub {
    my $self = shift;
    if(ref($self)) {
        ${ $AL {'Sub'} -> {Scalar::Util::refaddr ($self)} -> {'checksub'} }
	    = shift if @_;
	${ $AL {'Sub'} -> {Scalar::Util::refaddr ($self)} -> {'checksub'} };
    }
    else {
        $AL {'checksub'} = shift if @_;
        $AL {'checksub'};
    }
}
sub suffix {
    shift if __PACKAGE__ || $_[0] eq (caller(0))[0];
    $AL {'suffix'} = shift if @_;
    $AL {'suffix'};
} 
# default check subroutine
checksub ( __PACKAGE__, sub { (stat $_[0]) [9] } );
# default is not checking
check    ( __PACKAGE__,  0);

# gensub - returns an anonymous subroutine.
# Parameters:
# if one:  filename (full path)
# if more: package, filename [, checkfuncref [, auto ]]

sub gensub {
    my $package = scalar(@_) == 1 ? caller : shift;
    my $file    = shift;
    my $chkfunc = shift || $AL {'checksub'};
    my $auto    = shift || $AL {'auto'} || 'auto';
    my $function;

    {
        ($function = pop (@{[ File::Spec->splitpath($file) ]}) ) =~ s/\..*//;
        
        $file .= $AL {'suffix'} || '.al' unless $file =~ /\.\w+$/;
        unless (-e $file) {
	    my ($filename, $seen);
	    {
		$filename = File::Spec -> catfile ($auto, $package, $file);
		foreach my $d ('.',@INC) { # check current working dir first
		    my $f = File::Spec -> catfile ($d,$filename);
		    if (-e $f) {
			$file = $f;
			last;
		    }
		}
		last if $seen;
		unless (-e $file) {
		    # redo the search with a truncated filename
		    $file =~ s/(\w{12,})(\.\w+)$/substr($1,0,11).$2/e;
		    $seen++;
		    redo;
		}
	    } 
	    die
	      "Can't locate function file '$filename' for package '$package'\n"
		unless -e $file;
	}
    }

    if (my $addr = $AL {'Inc'} -> {"$package\::$function"} ) {
        return $AL {Sub} -> {$addr} -> {'outer'};
    }
    else {
        # file not known yet
        my $inner;
        my $h        = {};
        my $cr       = $chkfunc -> ($file);
        my $subname  = "$package\::$function";

        $h = {