1#!/usr/bin/perl
2BEGIN { require $_.".pm" && $_->import for qw(strict warnings) }
3# vim=:SetNumberAndWidth
4=encoding utf-8
5
6=head1 NAME
7
8Xporter - Alternative Exporter with persistant defaults & auto-ISA
9
10=head1 VERSION
11
12Version "0.1.1"
13
14=cut
15
16{ package Xporter;
17	BEGIN { require $_.".pm" && $_->import for qw(strict warnings) }
18	our $VERSION='0.1.2';
19	our @CARP_NOT;
20	use mem(@CARP_NOT=(__PACKAGE__));
21	# 0.1.2	 - Bad version check found in self-testing;
22	#          Added test against 4 version formats
23	# 0.1.1  - Bad use of modern proptype (_) for old perls
24	# 0.1.0  - Bugfix: only match user input after stripping sigels or "nots" (!^-)
25	#        - Feature addition, in addition to a global, (solo) 'not'
26	#          at the beginning of a list to zero the default exports,
27	#          individual items in EXPORTS can be excluded by prefixing them
28	#          with a negating prefix (!^-);
29	#        - Added new test case for specific exclusion
30	#        - NOTE: blocking an export will ignore type as will asking for a non-dflt
31	# 0.0.14 - Documentation update
32	# 0.0.13 - Bug fix in string version compare -- didn't add leading
33	#          zeros for numeric compares;
34	# 0.0.12 - Add version tests to test 3 forms of version: v-string,
35	# 				 numeric version, and string-based version.
36	# 				 If universal method $VERSION doesn't exist, call our own
37	# 				 method.
38	# 0.0.11 - Add a Configure_depends to see if that satisfies the one
39	#          test client that is broken (sigh)
40	# 0.0.10 - Remove P from another test (missed one);  Having to use
41	#         replacement lang features is torture  on my RSI
42	# 0.0.9 - add alternate version format for ExtMM(this system sucks)
43	#       - remove diagnostic messages from tests (required P)
44	# 0.0.8 - add current dep for BUILD_REQ of ExtMM
45	# 0.0.7 - 'require' version# bugfix
46	# 0.0.6 - comment cleanup; Change CONFIGURE_REQUIRES to TEST_REQUIRES
47	# 0.0.5 - export inheritance test written to highlight a problem area
48	# 			- problem area addessed; converted to use efficient jump table
49	#	0.0.4 - documentation additions;
50	#				- added tests & corrected any found problems
51	#	0.0.3 - added auto-ISA-adding (via push) when this mod is used.
52	#	      - added check for importing 'import' to disable auto-ISA-add
53	# 0.0.2	- Allow for "!" as first arg to import to turn off default export
54	# 				NOTE: defaults are defaults when using EXPORT_OK as well;
55	# 							One must specifically disable defaults to turn them off.
56	# 0.0.1	- Initial split of code from iomon
57	#
58	#require 5.8.0;
59
60	# Alternate export-import method that doesn't undefine defaults by
61	# default
62
63	sub add_to_caller_ISA($$) {
64		my ($pkg, $caller) = @_;
65
66		if ($pkg eq __PACKAGE__) { no strict 'refs';
67			unshift @{$caller."::ISA"}, $pkg unless grep /$pkg/, @{$caller."::ISA"};
68		}
69	}
70
71	# adapted from Core::Types to avoid circular include
72	sub _EhV($*) {	my ($arg, $field) = @_;
73		(ref $arg && 'HASH' eq ref $arg) &&
74			defined $field && exists $arg->{$field} ?  $arg->{$field} : undef
75	}
76
77	sub cmp_ver($$) {
78		my ($v1, $v2) = @_;
79		for (my $i=0; $i<@$v2 && $i<@$v1; ++$i) {
80			my ($v1p, $v1_num, $v1s) = ($v1->[$i] =~ /^([^\d]*)(\d+)([^\d]*)$/);
81			my ($v2p, $v2_num, $v2s) = ($v2->[$i] =~ /^([^\d]*)(\d+)([^\d]*)$/);
82			my $maxlen = $v1_num > $v2_num ? $v1_num : $v2_num;
83			my $r =	sprintf("%s%0*d%s", $v1p||"", $maxlen, $v1_num, $v1s||"") cmp
84							sprintf("%s%0*d%s", $v2p||"", $maxlen, $v2_num, $v2s||"");
85			return -1 if $r<0;
86			return 0 if $r>0;
87		}
88		return 0;
89	}
90
91
92	sub _version_specified($$;$) {
93		my ($pkg, $requires) = @_;
94		my $pkg_ver;
95		{	no strict 'refs';
96			$pkg_ver = ${$pkg."::VERSION"} || '(undef)';
97		}
98		my @v1=split /_|\./, $pkg_ver;
99		my @v2=split /_|\./, $requires;
100		if (@v1>2 || @v2>2) {
101			return if cmp_ver(\@v1, \@v2) >= 0;
102		} else {
103			return if $pkg_ver && ($pkg_ver cmp $requires)>=0;
104			return if $pkg_ver ne '(undef)' && $pkg_ver >= $requires;
105		}
106		require Carp;
107		Carp::croak(sprintf "module %s %s required. This is only %s",
108												$pkg, $requires, $pkg_ver);
109	}
110
111
112	our %exporters;
113
114
115	our $tc2proto = {'&' => '&', '$'	=> '$', '@' => '@', '%'	=> '%',
116									 '*' => '*', '!'	=> '!', '-' => '!', '^'	=> '!'};
117
118	sub list(;*) { return  @_ }
119
120	sub op_prefix;
121	sub op_prefix {
122		return ($_, undef) unless $_;
123		my $type = substr $_, 0, 1;
124		my $mapped_op = _EhV $tc2proto, $type;
125		if ($mapped_op) {
126			$_ = substr($_,1);
127			if ($mapped_op eq '!') {
128				($_, $type, undef ) = op_prefix()  }
129		} elsif ($type =~ /\w/) { $mapped_op=$type='&' }
130		($_, $type, $mapped_op);
131
132	}
133	sub import {
134		my $pkg			= shift;
135		my ($caller, $fl, $ln)	= (caller);
136		no strict 'refs';
137
138
139		#*{$caller."::import"}=
140		#\&{__PACKAGE__."::import"} if !exists ${$caller."::import"}->{CODE};
141
142		if (@_ && $_[0] && $_[0] =~ /^(v?[\d\._]+)$/) {
143			my @t=split /\./, $_[0];
144			no warnings;
145			if ($pkg->can("VERSION") && @t<3 && $1 ) {
146				$pkg->VERSION($1) }
147			else {
148				_version_specified($pkg, $1); }
149			shift;
150		}
151
152		if ($pkg eq __PACKAGE__) {		# we are exporting
153			if (@_ && $_[0] eq q(import)) {
154				no strict q(refs);
155				*{$caller."::import"} = \*{$pkg."::import"};
156			} else {
157				add_to_caller_ISA($pkg, $caller);
158			}
159			$exporters{$caller} = 1;
160			return 1;
161		}
162
163		my ($export, $exportok, $exporttags);
164
165		{ no strict q(refs);
166			$export = \@{$pkg."::"."EXPORT"} || [];
167			$exportok = \@{$pkg."::"."EXPORT_OK"} || [];
168			$exporttags = \%{$pkg."::"."EXPORT_TAGS"};
169		}
170
171		my @allowed_exports = (@$export, @$exportok);
172
173		if (@_ and $_[0] and  $_[0] eq '!' 	|| $_[0] eq '-' ) {
174			printf("Export RESET\n");
175			$export=[];
176			shift @_;
177		}
178
179		for my $pat (@_) { 															# filter individual params
180			$_ = $pat;																		# passed to op_prefix
181			my ($name, $type, $mapped_op ) = op_prefix();
182			if ($mapped_op eq '!') {
183				if (grep /$name/,  @$export) {
184					my @new_export = grep { !/$name/ } @$export;
185					$export=\@new_export;
186				}
187			} elsif (grep /$name/,  @allowed_exports) {
188				#printf("allowing export of %s\n", $pat);
189				push @$export, $pat ;
190			}
191		}
192
193
194		for(@$export) {
195			my ($type, $mapped_op);
196			#printf("_=%s:", $_||"undef");
197			($_, $type, $mapped_op) = op_prefix;
198			#printf("_=%s, t=%s, mapped=%s\n", $_||"undef", $type||"undef", $mapped_op||"undef");
199			if ($mapped_op) {
200				print "skip exp of $_\n" if $mapped_op eq '!';
201				next if $mapped_op eq '!';
202			} else {
203				require Carp;
204				Carp::croak("Unknown type ". ($type||"(undef)") . " in " . ($_||"(undef)"));
205			}
206			my $colon_name	= "::" . $_ ;
207			my ($exf, $imf)	= ( $pkg . $colon_name, $caller . $colon_name);
208			no strict q(refs);
209			my $case = {
210				'&'	=>	\&$exf,
211				'$'	=>	\$$exf,
212				'@' =>	\@$exf,
213				'%' =>	\%$exf,
214				'*'	=>	 *$exf};
215			*$imf = $case->{$type};
216		}
217	}
2181}
219
220
221=head1 SYNOPIS
222
223In the "Exporting" module:
224
225  { package module_adder [optional version];
226	  use warnings; use strict;
227    use mem;			# to allow using module in same file
228    our (@EXPORT, @EXPORT_OK);
229    our $lastsum;
230    our @lastargs;
231    use Xporter(@EXPORT=qw(adder $lastsum @lastargs),
232            		@EXPORT_OK=qw(print_last_result));
233
234    sub adder($$) {@lastargs=@_; $lastsum=$_[0]+$_[1]}
235    sub print_last_result () {
236      use P;    # using P allows answer printed or as string
237      if (@lastargs && defined $lastsum){
238        P "%s = %s\n", (join ' + ' , @lastargs), $lastsum;
239      }
240    }
241  }
242
243In C<use>-ing module (same or different file)
244
245  package main;  use warnings; use strict;
246  use module_adder qw(print_last_result);
247
248  adder 4,5;
249
250Printing output:
251
252  print_last_result();
253
254  #Result:
255
256  4 + 5 = 9
257
258(Or in a test:)
259
260  ok(print_last_result eq "4 + 5 = 9", "a pod test");
261
262=head1 DESCRIPTION
263
264C<Xporter>  provides  C<EXPORT>  functionality similar to  L<Exporter>  with
265some different rules to simplify common cases.
266
267The primary difference, in  C<Xporter>  is that the default  C<EXPORT>  list
268remains the default  C<EXPORT>  list unless the user specifically asks for it
269to not be included, whereas in L<Exporter>, asking for any additional
270exports from the  C<EXPORT_OK>  list, clears the default  C<EXPORT>  list.
271
272C<Xporter>  makes it easy to reset or clear the default so that choice
273is left to the user.
274
275To reset the default  C<EXPORT>  list to empty, a bare I<minus> ('-') or
276I<logical-not> sign ('!') is placed as the first parameter in the client's import
277list.
278
279=head3 Example
280
281Suppose a module has exports:
282
283  our (@EXPORT, @EXPORT_OK);
284  use Xporter(@EXPORT=qw(one $two %three @four),
285              @EXPORT_OK=qw(&five));
286
287In the using module, to only import symbols 'two' and 'five',
288one would use:
289
290=head3 Example
291
292  use MODULENAME qw(! $two five);
293
294That negates the default C<EXPORT> list, and allows selective import
295of the values wanted from either,  the default  C<EXPORT>  or the
296C<EXPORT_OK> lists.  I<Note:>  modules in the default list don't need
297to be reiterated in the OK list as they are already assumed to be
298"OK" to export having been in the default list.
299
300(New in 0.1) It is also possible to negate only 1 item from the
301default C<EXPORT> list, as well as import optional symbols in
3021 statement.
303
304=head3 Example
305
306  use MODULENAME qw(!$two five);      #or
307  use MODULENAME qw(!two five);
308
309Only export C<two> from the default export list will be
310excluded.  Whereas export C<five> will be added to the list
311of items to import.
312
313Other functions of Exporter are not currently implemented, though
314certainly requests and code donations made via the CPAN issue database
315will be considered if possible.
316
317=head2 Types and Type Export
318
319Listing the EXPORT and EXPORT_OK assignments as params to Xporter will
320allow their types to be available to importing modules at compile time.
321the L<mem> module was provided as a generic way to force declarations
322into memory during Perl's initial BEGIN phase so they will be in effect
323when the program runs.
324
325=head2 Version Strings
326
327Version strings in the form of a decimal fraction, (0.001001), a
328V-String (v1.2.1 with no quotes), or a version string
329('1.1.1' or 'v1.1.1') are supported, though note, versions in
330different formats are not interchangeable.  The format specified
331in a module's documentation should be used.
332
333
334
335
336
337
338