view release on metacpan or  search on metacpan

t/Data/File/Package.pm  view on Meta::CPAN

######
#
#
sub load_package
{

     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
     local @import;

     (my $program_module, @import) = @_;
     return  "# The package name is empty. There is no package to load.\n"
         unless ($program_module); 

     my $packages = $import[-1] && ref($import[-1]) eq 'ARRAY' ? pop @import : [$program_module];
        
     my $error = '';
     my $restore_warn = $SIG{__WARN__};
     my $restore_croak = \&Carp::croak;
     my $restore_carp = \&Carp::crap;
     unless (File::Package->is_package_loaded( $program_module )) {

         #####
         # Load the module
         #
         # On error when evaluating "require $program_module" only the last
         # line of STDERR, at least on one Perl, is return in $@.
         # Save the entire STDERR to a memory variable by using eval_str
         #
         $error = eval_str ("require $program_module;");
         return "Cannot load $program_module\n\t" . $error if $error;

         #####
         # Verify the package vocabulary is present
         #
         my @package_names = ();
         foreach (@$packages) { 
             push @package_names, $_ unless File::Package->is_package_loaded($_, $program_module );
         }
         return "# $program_module file but package(s) " . (join ',',@package_names) . " absent.\n"
              if @package_names;
     }

     ####
     # Import flagged symbols from load package into current package vocabulary.
     #
     if( @import ) {

         ####
         # Import does not work correctly when running under eval. Import
         # uses the caller stack to determine way to stuff the symbols.
         # The eval messes with the stack. Since not using an eval, need
         # to double check to make sure import does not die.
         
         ####
         # Poor man's eval where trap off the Carp::croak function.
         # The Perl authorities have Core::die locked down tight so
         # it is next to impossible to trap off of Core::die. Lucky 
         # must everyone uses Carp::croak instead of just dieing.
         #
         # Anyway, get the benefit of a lot of stack gyrations to
         # formulate the correct error msg by Exporter::import.
         # 
         $error = '';
         no warnings;
         *Carp::carp = sub {
             $error .= (join '', @_);
             $error .= "\n" unless substr($error,-1,1) eq "\n";
         };
         *Carp::croak = sub {
             $error .= Carp::longmess (join '', @_) if $error;
             $error .= "\n" unless substr($error,-1,1) eq "\n";
             goto IMPORT; # once croak can not continue
         };
         use warnings;
         local $Exporter::ExportLevel = 1;
         if(@import == 1 && defined $import[0] && $import[0] eq '') {
             $program_module->import( );
         }
         else {
             $program_module->import( @import );
         }
         no warnings;
IMPORT:  
         *Carp::croak = $restore_croak;
         *Carp::carp= $restore_carp;

     }
     $SIG{__WARN__} = ref( $restore_warn ) ? $restore_warn : '';
     return $error;
}




#####
# Many times, all the warnings do not get into the $@ string
#
sub eval_str
{
     shift @_ if UNIVERSAL::isa($_[0],__PACKAGE__);
     my ($str) = @_;

     my $restore_warn = $SIG{__WARN__};
     my $error_msg = '';
     $SIG{__WARN__} = sub { $error_msg .= join '', @_; };
     eval $str;
     $SIG{__WARN__} = ref( $restore_warn ) ? $restore_warn : '';

     $error_msg = $@ . $error_msg if $@;
     $error_msg =~ s/\n/\n\t/g if $error_msg;
     $error_msg;
}


######
#