view release on metacpan or  search on metacpan

lib/DBIx/VersionedSubs/AutoLoad.pm  view on Meta::CPAN

=head2 C<< __PACKAGE__->init_code >>

Overridden to just install the AUTOLOAD handler.

=cut

sub init_code {
    my ($package) = @_;
    no strict 'refs';
    if (! defined &{"$package\::AUTOLOAD"}) {
        *{"$package\::AUTOLOAD"} = sub {
            use vars qw($AUTOLOAD);
            if ($AUTOLOAD !~ /::(\w+)$/) {
                croak "Undecipherable subroutine '$AUTOLOAD' called";
            };
            my $name = $1;
            $package->install_and_invoke($name,@_);
        };
    } else {
        carp "$package->init_code called, but there already is an AUTOLOAD handler installed.";
    };

    my $begin = $package->retrieve_code('BEGIN');
    if (defined $begin) {
        eval "{ $begin }";
        carp "$package\::BEGIN: $@" if $@
    };
};

=head2 C<< __PACKAGE__->install_and_invoke NAME, ARGS >>

Loads code from the database, installs it
into the namespace and immediately calls it
with the remaining arguments via C<< goto &code; >>.

If no row with a matching name exists, an
error is raised.

=cut

sub install_and_invoke {
    my ($package,$name) = splice @_,0,2;

    my $code = $package->load_code($name);
    if (defined $code) {
        goto &$code;
    } else {
        croak "Undefined subroutine $package\::$name called";
    };
};

=head2 C<< __PACKAGE__->update_code >>

Overridden to do lazy updates. It wipes all code that
is out of date from the namespace and lets the AUTOLOAD
handler sort out the reloading.

=cut

sub update_code {
    my ($package) = @_;

    my $version = $package->code_version || 0;
    my $sth = $package->dbh->prepare_cached(sprintf <<'SQL', $package->code_history);
        SELECT distinct name,version FROM %s
            WHERE version > ?
            ORDER BY version DESC
SQL

    $sth->execute($version);

    # If update is needed, wipe the touched elements:
   my %seen;

    my $current_version = $version || 0;
    while (my ($name,$new_version) = $sth->fetchrow()) {
        next if $seen{$name}++;
        
        $current_version = $current_version < $new_version 
                         ? $new_version
                         : $current_version;

        delete $package->code_source->{$name};

        # This manual AUTOLOAD is less than ideal
        no strict 'refs';
        no warnings 'redefine';
        *{"$package\::$name"} = sub {
            local *AUTOLOAD = "$package\::$name";
            goto &{"$package\::AUTOLOAD"};
        };
        # = sub { $package->install_and_invoke( $name, @_ ); };
    }
    $package->code_version($current_version);
};

=head2 C<< __PACKAGE__->load_code NAME >>

Retrieves the code for the subroutine C<NAME>
from the database and calls
C<< __PACKAGE__->install_code $name,$code >>
to install it.

=cut

sub load_code {
    my ($package,$name) = @_;

    my $code = $package->retrieve_code($name);
    if (! defined $code) {
        # let caller decide whether to croak or to ignore
        return;
    };
    $package->create_sub($name,$code);
};

=head2 C<< __PACKAGE__->retrieve_code NAME >>

Retrieves the code for the subroutine C<NAME>
from the database and returns it as a string.