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