package dbLoader;
use Carp;
use Data::Dumper;
use DBI;
use English qw(-no_match_vars);
use Fcntl qw(:flock);
use Scalar::Util qw(blessed);
use strict;
use warnings;
my ($BUFFER,$LOGNAME,$VFH);
# Default prefix (preference) order
my $PREFIX_ORDER_AREF=['Deployed'];
sub import {
my $self=shift;
# set up $PREFIX_ORDER_AREF
$PREFIX_ORDER_AREF=[@_]
if (@_);
return;
}; # import:
my $KNOWN_PACKAGES_HREF;
my ($DBH,$STH);
{ # INTERNALS:
# Yes, you can use caller in a @INC coderef!
sub _dbLoader { # warn Data::Dumper->Dump([\[caller(0)]],[qw(*call
+er)]),' ';
print $VFH "Seeking '$_[1]'.\n";
return # unless there's a prefix order sequence
unless (@{$PREFIX_ORDER_AREF});
print $VFH Data::Dumper->Dump([\@_],[qw(*_)]);
my (undef,$path_S)=@_;
s{[/\\]}{::}g, s{\.pm$}{}
for (my $package_s=$path_S);
print $VFH Data::Dumper->Dump([\$path_S,\$package_s],[qw(*path
+_S *package_s)]);
return # unless the package is in the this library && we have
+a prefix match
unless (exists $KNOWN_PACKAGES_HREF->{$package_s} && grep {
+ exists $KNOWN_PACKAGES_HREF->{$package_s}{$_} } @{$PREFIX_ORDER_AREF
+});
#my $body_sref;
my $body_s;
eval {
print $VFH Data::Dumper->Dump([\$PREFIX_ORDER_AREF],[qw(*P
+REFIX_ORDER_AREF)]);
for my $prefix_s (@{$PREFIX_ORDER_AREF}) {
if (exists $KNOWN_PACKAGES_HREF->{$package_s}{$prefix_
+s}) {
# Found one ... get its body and stash a reference
+ to that body
print $VFH Data::Dump([\$prefix_s],[qw(*prefix_s)]
+);
$STH->execute($package_s,$prefix_s);
my $value_aref=$STH->fetchrow_arrayref();
$body_s=$value_aref->[0];
#print $VFH Data::Dumper->Dump([\$body_s],[qw(*bod
+y_s)]);
# Mark it as this rather than as CODE()
$INC{$path_S}="DBI:Pg:$prefix_s:$path_S";
# And our work is done
last;
};
};
};
if (my $error=$@) {
Carp::confess $@;
};
## Each of the following will work!
return \$body_s;
##
## or
#open my $fh,'<',\$body_s
# or die "Couldn't open '\$body_ref' for reading. $!";
#return $fh;
##
## or
#open my $fh,'<',\$body_s
# or Carp::confess "Couldn't open string for reading! $!+";
#return (
# sub {
# if ($_=<$fh>) {
# return 1;
# }
# else {
# return 0;
# };
# } # Anonymous sub:
# );
##
}; # _dbLoader:
} # INTERNALS:
BEGIN { # warn Data::Dumper->Dump([\[caller()]],[qw(*caller)]),' ';
#NB: $INC{"$LOGNAME.pm"} will be defined only when the package is
+use'd.
($LOGNAME=__PACKAGE__)=~ s{::}{/}g;
$LOGNAME=qq{$INC{"$LOGNAME.pm"}.log};
# warn Data::Dumper->Dump([\$LOGNAME],[qw(*LOGNAME)]),' ';
};
UNITCHECK { # warn Data::Dumper->Dump([\[caller()]],[qw(*caller)]),' '
+;
local $Data::Dumper::Terse=1;
local $Data::Dumper::Indent=1;
# Pre-allocate
vec($BUFFER,64*1_024,8)=0;
$BUFFER = "";
open $VFH,'>',\$BUFFER
or die "Couldn't open in-memory-file for writing. $!";
my $configuration_href;
# Load the configuration
$ENV{HOME}//="$ENV{HOMEDRIVE}$ENV{HOMEPATH}";
my $filename;
# The preference is an eval and a Data::Dumper .dmp file
# otherwise use Config::General and save the configuration to a Da
+ta::Dumper .dmp for subsequent uses
if (-f ($filename="$ENV{HOME}/config.dmp")) { # We can use eval.
my $string=do {open my $fh,'<',$filename or die "Couldn't open
+ '$filename' for reading. $!"; local $/; <$fh>; };
print $VFH Data::Dumper->Dump([\$string],[qw(*string)]);
$configuration_href=eval $string
or die "Deserialization failed: $@";
}
elsif (-f ($filename="$ENV{HOME}/config.ini")) { # Needs Config::G
+eneral.
require Config::General;
$configuration_href={Config::General->new($filename)->getall};
my $fh;
open $fh,'>',$filename="$ENV{HOME}/config.dmp"
and do {
require Data::Dumper;
print {$fh} Data::Dumper->Dump([$configuration_href]);
close $fh;
}
or warn "Couldn't open '$filename' for writing. $!";
}
else { # WTF
die "There is neither a config.dmp nor an config.ini file.";
};
print $VFH Data::Dumper->Dump([\$configuration_href],[qw(*configur
+ation_href)]);
my $db='pg';
print $VFH Data::Dumper->Dump([\$db],[qw(*db)]);
eval {
$DBH=DBI->connect(
@{$configuration_href->{db}{$db}}{qw(dsn username pass
+word)}
,{ PrintError=>1, RaiseError=>1 }
);
# Create a (global) hashref of packages/prefixes
$STH=$DBH->prepare(<<"__SQL__");
SELECT package,prefix 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}}{$_h{prefix}}=undef;
};
$STH->finish();
print $VFH Data::Dumper->Dump([\$KNOWN_PACKAGES_HREF],[qw(*KNO
+WN_PACKAGES_HREF)]);
# Statement handle for fetching source(s)
$STH=$DBH->prepare(<<"__SQL__");
SELECT body FROM packages WHERE package = ? and prefix = ?
+;
__SQL__
print $VFH "SELECT prepared.\n";
# prepend the loader
unshift @INC,\&_dbLoader;
print $VFH "Prepended \@INC.\n";
};
die $@
if ($@);
}; # UNITCHECK:
#CHECK { # warn Data::Dumper->Dump([\[caller()]],[qw(*caller)]),' ';
# }; # CHECK:
#INIT { # warn Data::Dumper->Dump([\[caller()]],[qw(*caller)]),' ';
# }; # INIT:
END { # warn Data::Dumper->Dump([\[caller()]],[qw(*caller)]),' ';
# Modules loaded by _dbLoader
printf $VFH ("%40s\t%s\n",$_,$INC{$_})
for (sort grep { $INC{$_}=~ m{DBI:Pg:} } keys %INC);
return # if there's nothing to do.
unless (tell $VFH);
# Open our log
open(my $fh,'>>',$LOGNAME)
or die "Could not open '$LOGNAME' for appending. $!";
# Get lock
flock($fh,LOCK_EX)
or die "Could not lock '$LOGNAME'. $!";
# and write $BUFFER to the log file
print $fh "\n<< $PROCESS_ID\n",
substr($BUFFER,0,tell $VFH),
"\n$PROCESS_ID >>\n";
# and close
close $fh
or die "Could not write '$LOGNAME' - $!";
}; END;
1;
__END__
| 