patches for Exporter.pm

I always thought that fiddling around with @ISA and various @EXPORTER arrays was quite ugly so here's a patch to let you do something much nicer, like this

  use Exporter (
    EXPORT => [qw( init )],
    TAGS => [
      base => [qw( open close )],
      read => [qw( read sysread readline )],
      write => [qw( print write writeline )],
      misc => [qw( select flush )],
      all => [qw( :base :read :write :misc)],
      no_misc => [qw( :all !:misc )],
    ],
    OK => [qw( some other stuff )],
    FAIL => [qw( dont use these )],
  );

This is the equivalent of

require Exporter;
use vars qw( @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS );
use base qw( Exporter );
@EXPORT = qw( init );
@EXPORT_OK = qw( some other stuff open close read sysread readline print write writeline select flush);
@EXPORT_FAIL => qw( dont use these );
%EXPORT_TAGS = (
      base => [qw( open close )],
      read => [qw( read sysread readline )],
      write => [qw( print write writeline )],
      misc => [qw( select flush )],
      all => [qw( open close read sysread readline print write writeline select flush)],
      no_misc => [qw( open close read sysread readline print write writeline)],
 );

Clean, quick and gets rid of any need for those tag helper functions and @EXPORT_OK fiddling.

Basically import now checks if it's being called as Exporter or as something else. If it's something else, it just proceeds as normal. If it's Exporter then we process all those arguments, push Exporter on to @ISA and automatically generate @EXPORT_OK

Here are two patches, they're against 5.8.0, I'm hoping nothing has changed since then as I'm on a modem connection and don't want to have to get a huge tar file.

The first is a fairly trivial, it's just to get Exporter.t using strict.

The second adds all the above functionality, including documentation changes (could be better) and tests. I've put the patches inline but I suspect my mailer is going to mangle them so they're also at

http://www.fergaldaly.com/computer/Exporter/

First patch

--- perl-5.8.0/lib/Exporter.t.orig	2003-02-10 18:47:31.000000000 +0000
+++ perl-5.8.0/lib/Exporter.t	2003-02-10 21:38:00.000000000 +0000
@@ -1,8 +1,10 @@
 #!./perl
 
+use strict;
+
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
+    @::INC = '../lib';
 }
 
 # Can't use Test::Simple/More, they depend on Exporter.
@@ -26,6 +28,8 @@
 ok( 1, 'Exporter compiled' );
 
 
+my @Exporter_Methods;
+
 BEGIN {
     # Methods which Exporter says it implements.
     @Exporter_Methods = qw(import
@@ -38,10 +42,12 @@
 
 package Testing;
 require Exporter;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT @EXPORT_OK $VERSION);
 @ISA = qw(Exporter);
 
 # Make sure Testing can do everything its supposed to.
-foreach my $meth (@::Exporter_Methods) {
+foreach my $meth (@Exporter_Methods) {
     ::ok( Testing->can($meth), "subclass can $meth()" );
 }
 
@@ -151,6 +157,7 @@
 
 
 package More::Testing;
+use vars qw(@ISA $VERSION);
 @ISA = qw(Exporter);
 $VERSION = 0;
 eval { More::Testing->require_version(0); 1 };
@@ -158,6 +165,7 @@
 
 
 package Yet::More::Testing;
+use vars qw(@ISA $VERSION);
 @ISA = qw(Exporter);
 $VERSION = 0;
 eval { Yet::More::Testing->require_version(10); 1 };
@@ -168,6 +176,7 @@
 BEGIN {
     $SIG{__WARN__} = sub { $warnings = join '', @_ };
     package Testing::Unused::Vars;
+use vars qw(@ISA @EXPORT);
     @ISA = qw(Exporter);
     @EXPORT = qw(this $TODO that);


second patch
 
--- perl-5.8.0/lib/Exporter.pm.orig	2003-02-10 18:47:20.000000000 +0000
+++ perl-5.8.0/lib/Exporter.pm	2003-02-10 22:41:05.000000000 +0000
@@ -27,36 +27,163 @@
 
 sub import {
   my $pkg = shift;
+
   my $callpkg = caller($ExportLevel);
 
-  # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
-  my($exports, $export_cache, $fail)
-    = (\@{"$pkg\::EXPORT"}, \%{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
-  return export $pkg, $callpkg, @_
-    if $Verbose or $Debug or @$fail > 1;
-  my $args = @_ or @_ = @$exports;
-
-  local $_;
-  if ($args and not %$export_cache) {
-    s/^&//, $export_cache->{$_} = 1
-      foreach (@$exports, @{"$pkg\::EXPORT_OK"});
-  }
-  my $heavy;
-  # Try very hard not to use {} and hence have to  enter scope on the foreach
-  # We bomb out of the loop with last as soon as heavy is set.
-  if ($args or $fail) {
-    ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
-               or @$fail and $_ eq $fail->[0])) and last
-                 foreach (@_);
-  } else {
-    ($heavy = /\W/) and last
-      foreach (@_);
-  }
-  return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
-  local $SIG{__WARN__} = 
-	sub {require Carp; &Carp::carp};
-  # shortcut for the common case of no type character
-  *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
+	if ($pkg eq 'Exporter')
+	{
+		my %args = @_;
+		push(@{"$callpkg\::ISA"}, "Exporter");
+
+		my @ok;
+
+		if (my $tags = $args{'TAGS'})
+		{
+			die "TAGS must be a reference to an array" unless ref($tags) eq 'ARRAY';
+
+			my $all_tags = _build_all_tags($tags);
+			%{"$callpkg\::EXPORT_TAGS"} = %$all_tags;
+			push(@ok, map {@$_} values %$all_tags);
+		}
+
+		if (my $export = $args{'EXPORT'})
+		{
+			die "EXPORT must be a reference to a array"
+				unless ref($export) eq 'ARRAY';
+
+			@{"$callpkg\::EXPORT"} = @$export;
+		}
+
+		if (my $fail = $args{'FAIL'})
+		{
+			die "EXPORT must be a reference to a array" unless ref($fail) eq 'ARRAY';
+			@{"$callpkg\::EXPORT_FAIL"} = @$fail;
+		}
+
+		if (my $ok = $args{'OK'})
+		{
+			die "OK must be a reference to a array" unless ref($ok) eq 'ARRAY';
+
+			push(@ok, @$ok);
+		}
+
+		# uniquify the OK symbols
+		@ok = do{my %o;@{o}{@ok} = (); keys %o};
+
+		@{"$callpkg\::EXPORT_OK"} = @ok;
+	}
+	else
+	{
+	  # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
+	  my($exports, $export_cache, $fail)
+	    = (\@{"$pkg\::EXPORT"}, \%{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
+
+		# warn "import ".join(", ", @$exports)." from $pkg into $callpkg";
+	  return export $pkg, $callpkg, @_
+	    if $Verbose or $Debug or @$fail > 1;
+	  my $args = @_ or @_ = @$exports;
+
+	  local $_;
+	  if ($args and not %$export_cache) {
+	    s/^&//, $export_cache->{$_} = 1
+	      foreach (@$exports, @{"$pkg\::EXPORT_OK"});
+	  }
+	  my $heavy;
+	  # Try very hard not to use {} and hence have to  enter scope on the foreach
+	  # We bomb out of the loop with last as soon as heavy is set.
+	  if ($args or $fail) {
+	    ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
+	               or @$fail and $_ eq $fail->[0])) and last
+	                 foreach (@_);
+	  } else {
+	    ($heavy = /\W/) and last
+	      foreach (@_);
+	  }
+	  return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
+	  local $SIG{__WARN__} = 
+		sub {require Carp; &Carp::carp};
+	  # shortcut for the common case of no type character
+	  *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
+	}
+}
+
+sub _build_all_tags($)
+{
+	# this takes the tags data and creates a hash
+	my $tags = shift;
+
+	my %tags_so_far;
+
+	my @tags = @$tags;
+	while (@tags)
+	{
+		my $tag_name = shift @tags || die "No name for tag";
+		die "Tag name cannot be a reference, maybe you left out a comma"
+			if (ref $tag_name);
+
+		die "Tried to redefine tag '$tag_name'"
+			if (exists $tags_so_far{$tag_name});
+
+		my $tag_list = shift @tags || die "No values for tag '$tag_name'";
+
+		die "Tag values for '$tag_name' is not a reference to an array"
+			unless ref($tag_list) eq 'ARRAY';
+
+		$tags_so_far{$tag_name} = [_build_a_tag($tag_name, $tag_list, \%tags_so_far)];
+	}
+
+	return \%tags_so_far;
+}
+
+sub _build_a_tag($$$)
+{
+	# this takes a list of symbols and uses it to build another list of
+	# symbols
+
+	# if the name of the tag is preceded by : then it is take to be a tag
+	# itself and expanded
+	
+	# if the tag begins with ! then this symbol (or list of symbols) will be
+	# deleted from the list
+	
+	my ($tag_name, $tag_list, $so_far) = @_;
+
+	my %this_tag;
+
+	foreach my $sym (@$tag_list)
+	{
+		my @symbols;
+		my $remove = 0;
+
+		if ($sym =~ s/^!//)
+		{
+			$remove = 1;
+		}
+
+		if ($sym =~ s/://)
+		{
+			my $sub_tag = $so_far->{$sym};
+			die "Trying to use non existent tag '$sym' while building tag '$tag_name'"
+				unless defined($sub_tag);
+
+			@symbols = @{$sub_tag};
+		}
+		else
+		{
+			@symbols = ($sym);
+		}
+
+		if ($remove)
+		{
+			delete @this_tag{@symbols};
+		}
+		else
+		{
+			@this_tag{@symbols} = ();
+		}
+	}
+
+	return keys %this_tag;
 }
 
 # Default methods
@@ -98,6 +225,13 @@
 In module YourModule.pm:
 
   package YourModule;
+  use Exporter (
+    OK => [ 'munge', 'frobnicate' ] # symbols to export on request
+  );
+
+or the old way
+
+  package YourModule;
   require Exporter;
   @ISA = qw(Exporter);
   @EXPORT_OK = qw(munge frobnicate);  # symbols to export on request
@@ -123,6 +257,12 @@
 
 =head2 How to Export
 
+There are two ways to export you can set C<@EXPORT>, C<EXPORT_OK> and so on
+by hand use C<require Exporter> or you can use C<use Expoerter (ARGS)> to
+avoid setting the variables by hand.
+
+=head3 How to Export with variables
+
 The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
 symbols that are going to be exported into the users name space by
 default, or which they can request to be exported, respectively.  The
@@ -136,6 +276,77 @@
 If you are only exporting function names it is recommended to omit the
 ampersand, as the implementation is faster this way.
 
+=head3 How to Export with use
+
+When you C<use Exporter> you don't have worry about setting C<@ISA> or
+setting arrays or hashes, you simply pass in an array of key-value pairs.
+These will be used to set up the C<@EXPORT>, C<@EXPORT_OK>, C<%EXPORT_TAGS>
+and C<@EXPORT_FAIL> variables. You can also define your tags in terms of
+previous other tags. For example
+
+  use Exporter (
+  	EXPORT => [qw( init )],
+  	TAGS => [
+  		base => [qw( open close )],
+  		read => [qw( read sysread readline )],
+  		write => [qw( print write writeline )],
+  		misc => [qw( select flush )],
+  		all => [qw( :base :read :write :misc)],
+  		no_misc => [qw( :all !:misc )],
+  	],
+  	OK => [qw( some other stuff )],
+  );
+
+The following keys are available.
+
+=over 4
+
+=item EXPORT
+
+The value should be a reference to a list of symbol names. These symbol
+names will be placed in the C<@EXPORT> array in your package.
+
+=item FAIL
+
+The value should be a reference to a list of symbol names. These symbol
+names will be placed in the C<@EXPORT_FAIL> array in your package.
+
+=item TAGS
+
+The value should be a reference to a list that goes like (TAG_NAME,
+TAG_VALUE, TAG_NAME, TAG_VALUE, ...), where TAG_NAME is a string and
+TAG_VALUE is a reference to an array of symbols and tags. For example
+
+  TAGS => [
+    file => [ 'open', 'close', 'read', 'write'],
+    string => [ 'length', 'substr', 'chomp' ],
+    hash => [ 'keys', 'values', 'each' ],
+    all => [ ':file', ':string', ':hash' ],
+    some => [':all', '!open', ':hash'],
+  ]
+
+This is used to fill the C<%EXPORT_TAGS> in your package. You can build tags
+from other tags - in the example above the tag C<all> will contain all the
+symbols from C<file>, C<string> and C<hash>. You can also subtract symbols
+and tags - in the example above, C<some> contains the symbols from all but
+with C<open> removed and all the symbols from C<hash> removed.
+
+The rule is that any symbol starting with a ':' is taken to be a tag which
+has been defined previously (if it's not defined you'll get an error). If a
+symbol is preceded by a '!' it will be subtracted from the list, otherwise
+it is added.
+
+If you try to redefine a tag you will also get an error.
+
+All the symbols which occur while building the tags are automatically added
+your package's C<@EXPORT_OK> array.
+
+=item OK
+
+The value should be a reference to a list of symbols names. These symbol
+names (along with any that occur in the C<TAGS> will be places in the
+C<@EXPORT_OK> array in your package.
+
 =head2 Selecting What To Export
 
 Do B<not> export method names!
@@ -334,6 +545,8 @@
 
 =head2 Tag Handling Utility Functions
 
+NOTE: these are only needed if you used the old "require" way of using Exporter.
+
 Since the symbols listed within %EXPORT_TAGS must also appear in either
 @EXPORT or @EXPORT_OK, two utility functions are provided which allow
 you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
@@ -350,6 +563,8 @@
 
 =head2 Generating combined tags
 
+NOTE: these are only needed if you used the old "require" way of using Exporter.
+
 If several symbol categories exist in %EXPORT_TAGS, it's usually
 useful to create the utility ":all" to simplify "use" statements.
 
--- perl-5.8.0/lib/Exporter.t.orig	2003-02-10 21:38:00.000000000 +0000
+++ perl-5.8.0/lib/Exporter.t	2003-02-10 21:42:16.000000000 +0000
@@ -22,8 +22,27 @@
     return $ok;
 }
 
+sub cmp_array ($$)
+{
+	my ($a1, $a2) = @_;
+
+	if ($#$a1 != $#$a2)
+	{
+		print "Different lengths, $#$a1 vs $#$a2\n";
+		return 0;
+	}
+	for (my $i=0; $i <= $#$a1; $i++)
+	{
+		if ($a1->[$i] ne $a2->[$i])
+		{
+			print "difference at $i '$a1->[$i]' ne '$a2->[$i]'\n";
+			return 0;
+		}
+	}
+	return 1;
+}
 
-print "1..24\n";
+print "1..43\n";
 require Exporter;
 ok( 1, 'Exporter compiled' );
 
@@ -187,3 +206,133 @@
 ::ok( !$warnings, 'Unused variables can be exported without warning' ) ||
   print "# $warnings\n";
 
+::ok(
+	::cmp_array(
+		[sort (Exporter::_build_a_tag("tag1", [qw( a b c)], {})) ],
+		[qw( a b c)],
+	),
+	"simple _build_a_tag"
+);
+
+::ok(
+	::cmp_array(
+		[sort (Exporter::_build_a_tag("tag1", [qw( a b c !b)], {})) ],
+		[qw( a c )],
+	),
+	"simple _build_a_tag with remove"
+);
+
+::ok(
+	::cmp_array(
+		[
+			sort (
+				Exporter::_build_a_tag(
+					"tag1",
+					[qw( a b c :tag2 )],
+					{
+						tag2 => [ qw( d e ) ] ,
+					}
+				)
+			)
+		],
+		[qw( a b c d e )],
+	),
+	"_build_a_tag with tag"
+);
+
+::ok(
+	::cmp_array(
+		[
+			sort (
+				Exporter::_build_a_tag(
+					"tag1",
+					[qw( a b c d f !:tag2 )],
+					{
+						tag2 => [ qw( d e ) ] ,
+					}
+				)
+			)
+		],
+		[qw( a b c f )],
+	),
+	"_build_a_tag with remove tag"
+);
+
+my $tags = Exporter::_build_all_tags(
+	[
+		tag1 => [qw( a b c d )],
+		tag2 => [qw( c d e )],
+		tag3 => [qw( :tag1 !:tag2 d !a )],
+	]
+);
+
+::ok(::cmp_array([sort @{$tags->{tag1}}], [qw( a b c d )]), "_build_all_tags tag1");
+::ok(::cmp_array([sort @{$tags->{tag2}}], [qw( c d e )]), "_build_all_tags tag2");
+::ok(::cmp_array([sort @{$tags->{tag3}}], [qw( b d )]), "_build_all_tags tag3");
+::ok(keys(%$tags) == 3, "use TAGS count");
+
+package Test::The::Use1;
+
+use Exporter (
+	OK => [qw( o_1 o_2) ],
+);
+
+use vars qw( @EXPORT @EXPORT_FAIL @EXPORT_OK @EXPORT_TAGS );
+
+::ok(::cmp_array([sort @EXPORT_OK], [sort qw( o_1 o_2 )]), "simple use OK");
+
+package Test::The::Use2;
+
+use Exporter (
+	EXPORT => [ qw( e_1 e_2 ) ],
+	FAIL => [qw( f_1 f_2) ],
+	OK => [qw( o_1 o_2) ],
+);
+
+use vars qw( @EXPORT @EXPORT_FAIL @EXPORT_OK @EXPORT_TAGS );
+
+::ok(::cmp_array([sort @EXPORT], [sort qw( e_1 e_2)]), "use EXPORT");
+::ok(::cmp_array([sort @EXPORT_FAIL], [sort qw( f_1 f_2)]), "use FAIL");
+::ok(::cmp_array([sort @EXPORT_OK], [sort qw( e_1 e_2 o_1 o_2 )]), "use OK with EXPORT");
+::ok(::cmp_array(\@EXPORT_TAGS, []), "use without TAGS");
+
+package Test::The::Use3;
+
+use Exporter (
+	EXPORT => [ qw( e_1 e_2 ) ],
+	TAGS => [
+		tag1 => [qw( a b c d e f )],
+		tag2 => [qw( b d f )],
+		tag3 => [qw( :tag1 !:tag2 )],
+	],
+	OK => [qw( o_1 o_2) ],
+);
+
+use vars qw( @EXPORT @EXPORT_OK %EXPORT_TAGS );
+
+::ok(::cmp_array([sort @EXPORT], [sort qw( e_1 e_2)]), "use EXPORT with tags");
+::ok(
+	::cmp_array(
+		[sort @EXPORT_OK],
+		[sort qw( e_1 e_2 a b c d e f o_1 o_2 )]
+	),
+	"use OK with EXPORT and TAGS"
+);
+
+my %e = %EXPORT_TAGS;
+
+::ok(::cmp_array([sort @{$e{tag1}}], [qw( a b c d e f  )]), "use TAGS tag1");
+::ok(::cmp_array([sort @{$e{tag2}}], [qw( b d f )]), "use TAGS tag2");
+::ok(::cmp_array([sort @{$e{tag3}}], [qw( a c e )]), "use TAGS tag3");
+::ok(keys(%e) == 3, "use TAGS count");
+
+package Test::The::Use4;
+
+use Exporter (
+	TAGS => [
+		tag1 => [qw( tag1_1 tag1_2 )],
+		tag2 => [qw( tag2_1 tag2_2 )],
+		tag3 => [qw( tag1_1 tag2_2 )],
+	],
+	OK => [qw( o_1 o_2) ],
+);




-- 
Do you need someone with lots of Unix sysadmin and/or lots of OO software 
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html

• patches for Exporter.pm by Fergal Daly