File Coverage

blib/lib/mods.pm

Criterion	Covered	Total	%
statement	49	67	73.1
branch	12	26	46.1
condition	3	6	50.0
subroutine	10	10	100.0
pod	0	1	0.0
total	74	110	67.2

# $Id: mods.pm 1.11 Fri, 12 Sep 1997 23:21:20 -0400 jesse $

package mods;
use strict;
use integer;
use vars qw($VERSION);

# $Format: "$VERSION='$modsRelease$';"$
$VERSION='0.004';

# $list: undef ~ use Foo; [] ~ use Foo(); [...] ~ use Foo (...)
sub sim_use($$;$$) {
  my ($callpack, $pkg, $un, $list)=@_;
  my $filename=$pkg;
  $filename =~ s!::!/!g;
  require "$filename.pm";
  unless ($list and not @$list) { # Null import: use Foo ();
    # Black magic commencing. Yes there is a reason for all this fuss...
    my $meth=($un ? 'unimport' : 'import');
    no strict qw(refs);
    local (*{"${callpack}::__FNORD__"})=
      eval "package $callpack; sub {\$pkg->\$meth(\@\$list)}";
    &{"${callpack}::__FNORD__"}();
  }
}

sub import {
  my ($class, @in)=@_;
  if (@in==1 and $in[0] !~ /[^0-9.]/) {
    if ($VERSION < $in[0]) {
      require Carp;
      Carp::croak "mods $in[0] requested, only have $VERSION";
    } else {
      return;
    }
  }
  my $callpack=caller;
  my $in=join "\n", @in;
  unless ($in =~ s/^\s*~//) {
    # Defaults.
    sim_use $callpack, q(strict);
    sim_use $callpack, q(integer);
    sim_use $callpack, q(vars), 0,
    [qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @EXPORT_FAIL $AUTOLOAD $VERSION)];
  }
  # Custom.
  $in =~ s/(^|\s)\#.*$/$1/gm;	# Comments.
  while ($in =~ m{
		  (		# Import directive
		   (!)?		# Unimport?
		   \s*
		   ([\w:]+)	# Package name
		   \s*
		   (		# Import list, maybe none
		    \(
		    ( [^()]* )	# Imports themselves
		    \)
		   )?
		  ) |
		  (		# BEGIN directive
		   \{
		   ([^{}]*)	# Actual code
		   \}
		  ) |
		  (		# Export directive
		   <
		   ([^<>]*)	# Exportables
		   >
		  ) |
		  (		# Inherit
		   \[
		   ([^][]*)	# Superclasses
		   \]
		  ) |
		  (
		   [\$\@\%] \w+	# Variable
		  )
		 }sgx) {
    if ($1) {
      # Importation
      my ($un, $pack, $list, $sublist)=($2, $3, $4, $5);
      sim_use $callpack, $pack, $un, ($list ? [$sublist =~ /([^\s,]+)/g] : undef);
    } elsif ($6) {
      # Compile code
      no strict;
      no integer;
      eval "package $callpack; $7";
    } elsif ($8) {
      # Exporting
      my @what=($9 =~ /([^\s,]+)/g);
      sim_use $callpack, q(Exporter), 0, [];
      no strict qw(refs);
      push @{"${callpack}::ISA"}, q(Exporter)
	unless grep {$_ eq q(Exporter)} @{"${callpack}::ISA"};
      foreach (@what) {
	my $where=(s/!$// ? 'EXPORT' : 'EXPORT_OK');
	push @{"${callpack}::$where"}, $_;
      }
      sim_use $callpack, q(vars), 0, [grep {/^[\$\@\%]/} @what];
    } elsif ($10) {
      # Inheritance
      no strict qw(refs);
      push @{"${callpack}::ISA"}, ($11 =~ /([\w:]+)/g);
    } elsif ($12) {
      # Variable
      sim_use $callpack, q(vars), 0, [$12];
    }				# Else comment.
  }
}

1;
__END__