File Coverage

blib/lib/Pragmatic.pm

Criterion	Covered	Total	%
statement	27	36	75.0
branch	7	14	50.0
condition	2	2	100.0
subroutine	4	6	66.6
pod			n/a
total	40	58	68.9

package Pragmatic;

require 5.001; # ??
require Exporter;

use strict;
use vars qw (@ISA $VERSION);

@ISA = qw (Exporter);

# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = '1.7';
my $rcs = '$Id: Pragmatic.pm 164 2005-03-15 21:42:20Z binkley $' ;


sub import ($) {
  my $package = shift;

  return $package->export_to_level (1, $package, @_)
    if $package eq __PACKAGE__;

  my $warn = sub (;$) {
    require Carp;
    local $Carp::CarpLevel = 2; # relocate to calling package
    Carp::carp (@_);
  };

  my $die = sub (;$) {
    require Carp;
    local $Carp::CarpLevel = 2; # relocate to calling package
    Carp::croak (@_);
  };

  my @imports = grep /^[^-]/, @_;
  my @pragmata = map { substr($_, 1); } grep /^-/, @_;

  # Export first, for side-effects (e.g., importing globals, then
  # setting them with pragmata):
  $package->export_to_level (1, $package, @imports)
    if @imports;

  for (@pragmata) {
    no strict qw (refs);

    my ($pragma, $args) = split /=/, $_;
    my (@args) = split /,/, $args || '';

    exists ${"$package\::PRAGMATA"}{$pragma}
      or &$die ("No such pragma '$pragma'");

    if (ref ${"$package\::PRAGMATA"}{$pragma} eq 'CODE') {
      &{${"$package\::PRAGMATA"}{$pragma}} ($package, @args)
	or &$warn ("Pragma '$pragma' failed");

      # Let inheritance work for barewords:
    } elsif (my $ref = $package->can
	     (${"$package\::PRAGMATA"}{$pragma})) {
      &$ref ($package, @args)
	or &$warn ("Pragma '$pragma' failed");

    } else {
      &$die ("Invalid pragma '$pragma'");
    }
  }
}

1;


__END__