#!/usr/bin/env perl
use Carp;
use DBI;
use strict;
use warnings;
eval {
my $DBH=DBI->connect('dbi:SQLite:Library.sqlite','','',{ PrintError=>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__
####
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;
##
##
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 *package)]),' ';
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','','',{ PrintError=>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_PACKAGES)]),' ';
# 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;
##
##
#!/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;
##
##
#!/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;
##
##
... 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 to 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.
##
##
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:
);