view release on metacpan or  search on metacpan

lib/Pragmatic.pm  view on Meta::CPAN

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__


=head1 NAME

Pragmatic - Adds pragmata to Exporter

=head1 SYNOPSIS

In module MyModule.pm:

  package MyModule;
  require Pragmatic;
  @ISA = qw (Pragmatic);

  %PRAGMATA = (mypragma => sub {...});

In other files which wish to use MyModule:

    use MyModule qw (-mypragma); # Execute pragma at import time
    use MyModule qw (-mypragma=1,2,3); # Pass pragma argument list