Coderefs and @INC
Greetings!
I'm attempting to "load" modules from a database using a coderef prepended onto @INC but I'm having problems. It fails when a module loaded via the coderef requires another module which will be loaded via the coderef.
I've tried various incantations of the coderef without success and am hoping that the monastery can shed light on my error(s)
To illustration the problem we will need to create a small database containing our modules. We'll use SQLite.
populate.pl
#!/usr/bin/env perl
use Carp;
use DBI;
use strict;
use warnings;
eval {
my $DBH=DBI->connect('dbi:SQLite:Library.sqlite','','',{ PrintErro
+r=>1, RaiseError=>1 });
$DBH->do("DROP TABLE IF EXISTS packages;");
$DBH->do("CREATE TABLE packages (
package text,
body text,
unique (package)
);");
my $STH=$DBH->prepare("INSERT INTO packages (package,body) VALUES
+(?,?);");
print "Inserting package 'A'\n";
$STH->execute('A',<<'__A__');
package A;
use Carp;
use strict;
use warnings;
use A::B;
sub sub_a {
Carp::cluck '...';
A::B::sub_b();
}
1;
__A__
print "Inserting package 'A::B'\n";
$STH->execute('A::B',<<'__A::B__');
package A::B;
use Carp;
use strict;
use warnings;
sub sub_b {
Carp::cluck '...';
};
1;
__A::B__
$STH->finish;
$DBH->disconnect;
};
if (my $error=$@) {
Carp::confess $error;
};
print "$0 completed."
__END__
This database contains the following modules:
package A;
use Carp;
use strict;
use warnings;
use A::B;
sub sub_a {
Carp::cluck '...';
A::B::sub_b();
}
1;
package A::B;
use Carp;
use strict;
use warnings;
sub sub_b {
Carp::cluck '...';
};
1;
Note that module 'A' requires module 'A::B'.
Here's the code that unshifts the coderef onto @INC.
package dbLoader;
use Carp;
use Data::Dumper;
use DBI;
use Scalar::Util;
use strict;
use warnings;
use feature 'state';
sub import {
my $self=shift;
return;
}; # import:
my $KNOWN_PACKAGES_HREF;
my ($DBH,$STH);
{ # INTERNALS:
sub _dbLoader {
my (undef,$path_S)=@_;
s{[/\\]}{::}g, s{\.pm$}{}
for (my $package_s=$path_S);
return # unless the package is in the this library
unless (exists $KNOWN_PACKAGES_HREF->{$package_s});
warn Data::Dumper->Dump([\$path_S,\$package_s],[qw(*path *pack
+age)]),' ';
my $body_sref;
eval {
$STH->execute($package_s);
if(my $value_aref=$STH->fetchrow_arrayref()) {
chomp($value_aref->[0]);
$body_sref=\$value_aref->[0];
warn "fetched - ",Data::Dumper->Dump([\$body_sref],[qw
+(*body)]),'';
$INC{$path_S}="DBI:Pg:$path_S";
};
};
if (my $error=$@) {
Carp::confess $@;
}
elsif (!defined $body_sref) {
return;
}
else {
open my $fh,'<',$body_sref
or Carp::confess "Couldn't open string for reading! $!
+";
return (
sub { #Carp::cluck 'In anonymous sub';
if ($_=<$fh>) {
warn Data::Dumper->Dump([\$_],[qw(*_)]),'
+';
return 1;
}
else {
return 0;
};
} # Anonymous sub:
);
};
}; # _dbLoader:
} # INTERNALS:
BEGIN {
eval {
$DBH=DBI->connect('dbi:SQLite:Library.sqlite','','',{ PrintErr
+or=>1, RaiseError=>1 });
# Create a (global) hashref of packages/prefixes
$STH=$DBH->prepare(<<"__SQL__");
SELECT package FROM packages;
__SQL__
$STH->execute();
my $field_aref=$STH->{NAME_lc};
while (my $value_aref=$STH->fetchrow_arrayref()) {
my %_h;
@_h{@$field_aref}=@$value_aref;
$KNOWN_PACKAGES_HREF->{$_h{package}}=undef;
};
$STH->finish();
warn Data::Dumper->Dump([\$KNOWN_PACKAGES_HREF],[qw(*KNOWN_PAC
+KAGES)]),' ';
# Statement handle for fetching source(s)
$STH=$DBH->prepare(<<"__SQL__");
SELECT body FROM packages WHERE package = ?;
__SQL__
warn "SELECT prepared";
unshift @INC,\&_dbLoader;
warn "Prepended \&_dbLoader to \@INC";
};
if (my $error=$@) {
Carp::confess $@;
};
}; # BEGIN:
END {
print STDERR sprintf("%40s\t%s\n",$_,$INC{$_})
for (sort grep { $INC{$_} !~ m{^([A-Za-z]:|/)}} keys %INC);
}; # END:
1;
The following which explicitly requires A::B prior to requiring A runs successfully.
perl -MdbLoader works.pl#!/usr/bin/env perl
use strict;
use warnings;
# Note the order ... "A::B", "A" - this works!
use A::B;
use A;
A::sub_a();
A::B::sub_b();
exit;
While this which merely requires A (thus implicitly requiring A::B) does not.
perl -MdbLoader worksnot.pl#!/usr/bin/env perl
use strict;
use warnings;
# Note the order ... "A" with the implicit requir'ing of "A::B" by "A"
+ - this does NOT work
use A;
A::sub_a();
A::B::sub_b();
exit;
It produces
... at DBI:Pg:A.pm line 8.
require A.pm called at WorksNot.plx line 6
main::BEGIN() called at DBI:Pg:A.pm line 0
eval {...} called at DBI:Pg:A.pm line 0
Can't locate object method "b_b" via package "1" (perhaps you forgot t
+o load "1"?) at DBI:Pg:A.pm line 7.
Compilation failed in require at WorksNot.plx line 6.
BEGIN failed--compilation aborted at WorksNot.plx line 6.
NB: I've played with various returns ranging from
return (
$body_sref
);
return (
$fh,
);
return (
sub { #Carp::cluck 'In anonymous sub';
if ($_=<$fh>) {
warn Data::Dumper->Dump([\$_],[qw(*_)]),'
+';
return 1;
}
else {
return 0;
};
} # Anonymous sub:
);
and while they do NOT return the list as specified by the require docs they work on 'works.pl' and fail similarly on 'worksnot.pl'.
PS: I've chased down and read most of the "coderef"/"@INC" posts on perlmonks and stackoverflow and still
I'm clueless
