2.5 years ago I was thinking about a similar approach to solve a particular problem. (I eventually walked away from it.) (This was for a mod_perl envirnoment)
Attached you can find the code I used. Big note: that code is/was not complety finished and tested. The codes posted is just as is. I did not test it, nor did I clean it up. (Nor do I fully remember how it worked)
$ cat startup.pl
#!/usr/bin/perl
use strict;
use warnings;
BEGIN {
chdir "/home/bram/libnew";
my %Modules = ();
my %Export = ();
opendir DIR, "." or die "Can't open dir: $!";
while (my $dir = readdir (DIR)) {
next, if ($dir =~ m/^\.*$/);
next, if ($dir =~ m/^Axoni/);
next, if ($dir =~ m/^Development/);
next, if ($dir =~ m/^Site/);
my @files = qx/find $dir -name '*.pm'/;
for my $file (@files) {
chomp $file;
my $f = $file;
$f =~ s#^$dir/##g;
$Modules{$f} = 1;
open FH, "<", $file or die $!;
while (<FH>) {
# Looking for @EXPORT = qw(...) or @EXPORT = () ... (broken!
+for example: @EXPORT = qw// or push @EXPORT, "")
if (m/^\s*\@EXPORT\s*=\s*(?:qw)?\(\s*(.+?)\s*\);/) {
push @{ $Export{$f} }, $1;
}
}
close FH;
}
}
closedir DIR;
#use Data::Dumper;
#print Dumper \%Modules;
#die;
unshift @INC, sub {
my ($s, $f) = @_;
my $f2 = $f;
$f2 =~ s#/#::#g;
$f2 =~ s#\.pm$##g;
if (defined $Modules{$f}) {
# Laad AutoLoad module
print STDERR "SETUPING UP AUTOLOAD MODULE FOR $$ : $f\n";
open my $fh, "<", "/home/bram/libnew/Development/LoadModule.pm"
+or die "Unable to load file (LoadModule.pm): $!";
return ($fh, sub {
s/^\s*package\s*LoadModule;/package $f2;/g;
if ($_ eq "### \@EXPORT_ALL placeholder ###\n" and exists $Exp
+ort{$f}) {
$_ = 'push @EXPORT_ALL, qw/' . join(" ", @{ $Export{$f} }) .
+ '/;';
}
# print;
return length $_;
});
}
return undef;
}
}
1;
$ cat Development/LoadModule.pm
package LoadModule;
use strict;
use warnings;
use Development::Tie::Scalar;
use Development::Tie::Array;
use Development::Tie::Hash;
use Development::Tie::Handle;
use Carp;
our @EXPORT_ALL = qw//;
### @EXPORT_ALL placeholder ###
sub AUTOLOAD {
our $AUTOLOAD;
my $c = __find_class();
my $p = __PACKAGE__;
print STDERR "AUTOLOADING: $p & $c & $AUTOLOAD & @_\n";
if (defined $c) {
if ( my ($function) = $AUTOLOAD =~ m/^${p}::(.*)$/ ) {
my $p = $c . "::" . $function;
if ($p eq 'Frame::Services::Data::Menu::field') {
print STDERR "SKIPPING GOTO: $p\n";
return;
}
print STDERR "GOTO: $p\n";
goto &$p;
}
}
else {
warn "No clue about the calling module so we need to handle things
+ ourself...";
}
}
sub import {
my $self = shift;
# print STDERR "IMPORT " . scalar(caller(0)) . "\n";
my $c = __find_class();
# print STDERR "IMPORT-2: $c\n";
if (defined $c) {
my $x = $c->can("import");
if ($x) {
unshift @_, $c;
goto &$x;
}
}
else {
my $dest = caller(0);
no strict qw/refs/;
my @list = @_;
@list = @EXPORT_ALL, unless (@list);
for (@list) {
# print;
my $v = $dest . "::" . substr($_, 1);
if (substr ($_, 0, 1) eq '&') {
#CODE
my $f = __PACKAGE__ . "::" . substr($_, 1);
*{ $v } = sub { goto &$f; };
}
elsif (substr ($_, 0, 1) eq '$') {
my $scalar;
tie $scalar, "Development::Tie::Scalar", __PACKAGE__, substr($
+_, 1);
*{ $v } = \$scalar;
}
elsif (substr ($_, 0, 1) eq '@') {
my @array;
tie @array, "Development::Tie::Array", __PACKAGE__, substr($_,
+ 1);
*{ $v } = \@array;
}
elsif (substr ($_, 0, 1) eq '%') {
my %hash;
tie %hash, "Development::Tie::Hash", __PACKAGE__, substr($_, 1
+);
*{ $v } = \%hash;
}
elsif (substr ($_, 0, 1) eq '*') {
# EXPORT HANDLE
}
else {
my $f = __PACKAGE__ . "::" . substr($_, 1);
*{ $v } = sub { goto &$f; };
}
}
warn "No clue about the calling module when importing!";
}
1;
}
sub DESTROY { }
sub __find_caller {
my $i = 0;
while (defined scalar(caller($i)) and scalar(caller($i)) !~ m/^Site:
+:/) {
$i++;
}
return scalar(caller($i));
}
sub __find_class {
my $c = __find_caller();
my $Site = "";
if (defined $c and $c =~ m/^Site::([^:]+)::/) {
$Site = $1;
}
if ($Site) {
my $p = __PACKAGE__;
my $p2 = $p;
$p2 =~ s#::#/#g;
Load($Site . "/" . $p2 .".pm", $p, $Site . "::" . $p);
return $Site . "::" . $p;;
}
else {
my $p = __PACKAGE__;
if ((caller(1))[3] ne $p . '::import') {
croak "(Error:) Caller ($c) is unknown.";
}
else {
# carp "(Warning:) Caller ($c) is unknown.";
}
}
return undef;
}
sub Load {
my $file = shift;
my $old_package = shift;
my $new_package = shift;
return, if (exists $INC{$file});
print STDERR "LOADING FILE ($$): $file: " . scalar (caller(0)) . " :
+ " . scalar (caller(1)) ." \n";
# print STDERR "TESTEKE: $INC{$file}\n";
# $INC{$file} = "/home/bram/libnew/" . $file;
# print STDERR "TESTEKE-2: $INC{$file}\n";
open FH, "<", "/home/bram/libnew/$file" or warn "Error opening file:
+ $file : $!";
local $/;
my $code = <FH>;
close FH;
$INC{$file} = "/home/bram/libnew/" . $file;
{
no strict;
no warnings;
$code =~ s/^(\s*package\s+)$old_package/${1}$new_package/g;
eval $code;
warn $file . ": " . $@ if $@;
}
}
1;
$ cat Development/Tie/Array.pm
package Development::Tie::Array;
use strict;
no strict qw/refs/;
use warnings;
use Carp;
sub __get_class {
my ($package, $var) = @{ +shift };
my $class = $package->__find_class();
return $class . "::" . $var;
}
sub TIEARRAY {
my $class = shift;
my $package = shift;
my $var = shift;
croak "Arguments missing: package and/or var" unless (defined $packa
+ge and defined $var);
return bless [ $package, $var ] , $class;
}
sub FETCHSIZE {
return scalar ( @{ __get_class(@_) } );
}
sub FETCH {
return __get_class(@_)->[$_[1]];
}
sub CLEAR {
@{ __get_class(@_) } = ();
}
sub EXTEND { }
sub STORESIZE {
$#{ __get_class(@_) } = $_[1] - 1;
}
sub STORE {
__get_class(@_)->[$_[1]] = $_[2];
}
sub SHIFT {
shift @{ __get_class(@_) };
}
sub UNSHIFT {
unshift @{ __get_class(shift) }, @_;
}
sub POP {
pop @{ __get_class(@_) };
}
sub PUSH {
push @{ __get_class(shift) }, @_;
}
sub SPLICE {
my $self = shift;
my $class = __get_class($self);
my $sz = @{ $class };
my $off = @_ ? shift : 0;
$off += $sz if $off < 0;
my $len = @_ ? shift : $sz-$off;
return splice(@{ $class }, $off, $len, @_);
}
sub EXISTS {
exists __get_class(@_)->[$_[1]];
}
sub DELETE {
delete __get_class(@_)->[$_[1]];
}
1;
$ cat Development/Tie/Hash.pm
package Development::Tie::Hash;
use strict;
no strict qw/refs/;
use warnings;
use Carp;
sub __get_class {
my ($package, $var) = @{ +shift };
my $class = $package->__find_class();
return $class . "::" . $var;
}
sub TIEHASH {
my $class = shift;
my $package = shift;
my $var = shift;
croak "Arguments missing: package and/or var" unless (defined $packa
+ge and defined $var);
return bless [ $package, $var ] , $class;
}
sub STORE {
__get_class(@_)->{$_[1]} = $_[2];
}
sub FETCH {
__get_class(@_)->{$_[1]};
}
sub FIRSTKEY {
my $a = scalar keys %{ __get_class(@_) };
each %{ __get_class(@_) };
}
sub NEXTKEY {
each %{ __get_class(@_) };
}
sub EXISTS {
exists __get_class(@_)->{$_[1]};
}
sub DELETE {
delete __get_class(@_)->{$_[1]};
}
sub CLEAR {
%{ __get_class(@_) } = ()
}
sub SCALAR {
scalar %{ __get_class(@_) };
}
1;
$ cat Development/Tie/Handle.pm
package Development::Tie::Handle;
use strict;
no strict qw/refs/;
use warnings;
use Carp;
#sub AUTOLOAD {
# our $AUTOLOAD;
# print "Function $AUTOLOAD not yet implemented.";
#}
sub DESTROY { }
sub __get_class {
my ($package, $var) = @{ +shift };
my $class = $package->__find_class();
return $class . "::" . $var;
}
sub TIEHANDLE {
my $class = shift;
my $package = shift;
my $var = shift;
croak "Arguments missing: package and/or var" unless (defined $packa
+ge and defined $var);
return bless [ $package, $var ] , $class;
}
sub EOF {
eof( *{ __get_class(@_) } );
}
sub TELL {
tell( *{ __get_class(@_) } );
}
sub FILENO {
fileno( *{ __get_class(@_) } );
}
sub SEEK {
seek( *{ __get_class(@_) }, $_[1], $_[2]);
}
sub CLOSE {
close( *{ __get_class(@_) } );
}
sub BINMODE {
@_ == 2 ? binmode( *{ __get_class(@_) }, $_[1]) : binmode( *{ __g
+et_class(@_) } );
}
sub OPEN {
@_ == 2 ? open( *{ __get_class(@_) }, $_[1]) : open( *{ __get_clas
+s(@_) }, $_[1], $_[2] );
}
sub READ {
@_ == 3 ? read( *{ __get_class(@_) }, $_[1], $_[2]) : read( *{ __g
+et_class(@_) }, $_[1], $_[2], $_[3] );
}
sub READLINE {
readline *{ __get_class(@_) };
}
sub GETC {
getc *{ __get_class(@_) };
}
sub WRITE {
my $fh = __get_class(@_);
print $fh substr($_[1], 0, $_[2]);
}
=kkkkkkkk
sub WRITE
{
my $fh = $_[0];
print $fh substr($_[1],0,$_[2])
}
=cut
1;
$ cat Development/Tie/Scalar.pm
package Development::Tie::Scalar;
use strict;
no strict qw/refs/;
use warnings;
use Carp;
sub TIESCALAR {
my $class = shift;
my $package = shift;
my $var = shift;
croak "Arguments missing: package and/or var" unless (defined $packa
+ge and defined $var);
return bless [ $package, $var ] , $class;
}
sub FETCH {
return ${ __get_class(@_) };
}
sub STORE {
my $self = shift;
my $value = shift;
return ( ${ __get_class($self) } = $value );
}
sub __get_class {
my ($package, $var) = @{ +shift };
my $class = $package->__find_class();
return $class . "::" . $var;
}
1;