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(*caller)]),' '; 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(*PREFIX_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(*body_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 Data::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::General. 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(*configuration_href)]); my $db='pg'; print $VFH Data::Dumper->Dump([\$db],[qw(*db)]); eval { $DBH=DBI->connect( @{$configuration_href->{db}{$db}}{qw(dsn username password)} ,{ 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(*KNOWN_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__