Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Re: How can I (safely) use packages of the same name but different versions?

by Animator (Hermit)
on Mar 12, 2008 at 20:19 UTC ( [id://673811]=note: print w/replies, xml ) Need Help??


in reply to How can I (safely) use packages of the same name but different versions?

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)

Let me try to explain the approach I used/was playing with:

  • at startup build a list of all the modules that are being used.
  • unshift @INC with a custom code ref:
    That code ref checked if the package that is being loaded is in the list of modules. If it is it does not load that file but instead loads a default file (LoadModule.pm) in which the name of the package (LoadModule) gets replaced with the name of the package that is being loaded.
  • The LoadModule file contains an AUTOLOAD subroutine which checks what version of the file should be loaded. (In my case it did this by looking at the initial caller.)
    Before loading it it changes the name of the package.
  • It loads that file (if it isn't loaded already) and dispatches all methods to the 'correct' version.

(I also used some code to make sure importing/exporting worked as expected.)

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;

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://673811]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (5)
As of 2024-03-29 09:09 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found