1#+##############################################################################
2#                                                                              #
3# File: No/Worries/Export.pm                                                   #
4#                                                                              #
5# Description: symbol exporting without worries                                #
6#                                                                              #
7#-##############################################################################
8
9#
10# module definition
11#
12
13package No::Worries::Export;
14use strict;
15use warnings;
16our $VERSION  = "1.6";
17our $REVISION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
18
19#
20# used modules
21#
22
23use Params::Validate qw(validate_with :types);
24
25#
26# simple yet powerful export control
27#
28
29sub export_control ($$$@) {
30    my($callpkg, $pkg, $exported, @names) = @_;
31    my($name, $regexp, $ref);
32
33    validate_with(
34        params => \@_,
35        spec => [ { type => SCALAR }, { type => SCALAR }, { type => HASHREF } ],
36        allow_extra => 1,
37    );
38    while (@names) {
39        $name = shift(@names);
40        # special case for * and /.../ and x.y
41        if ($name eq "*") {
42            unshift(@names, grep(!ref($exported->{$_}), keys(%{ $exported })));
43            next;
44        } elsif ($name =~ /^\/(.*)\/$/) {
45            $regexp = $1;
46            unshift(@names, grep(/$regexp/, grep(!ref($exported->{$_}),
47                                                 keys(%{ $exported }))));
48            next;
49        } elsif ($name =~ /^\d/) {
50            # version checking via UNIVERSAL
51            $pkg->VERSION($name);
52            next;
53        }
54        die("\"$name\" is not exported by the $pkg module\n")
55            unless defined($exported->{$name});
56        $ref = ref($exported->{$name});
57        if ($ref eq "") {
58            # normal symbol
59            if ($name =~ /^(\w+)$/) {
60                # function
61                no strict qw(refs);
62                no warnings qw(once prototype);
63                *{"${callpkg}::${1}"} = \&{"${pkg}::${1}"};
64            } elsif ($name =~ /^\$(\w+)$/) {
65                # scalar
66                no strict qw(refs);
67                *{"${callpkg}::${1}"} = \${"${pkg}::${1}"};
68            } elsif ($name =~ /^\@(\w+)$/) {
69                # array
70                no strict qw(refs);
71                *{"${callpkg}::${1}"} = \@{"${pkg}::${1}"};
72            } elsif ($name =~ /^\%(\w+)$/) {
73                # hash
74                no strict qw(refs);
75                *{"${callpkg}::${1}"} = \%{"${pkg}::${1}"};
76            } else {
77                die("unsupported export by the $pkg module: $name\n");
78            }
79        } elsif ($ref eq "CODE") {
80            # special symbol
81            $exported->{$name}->($name);
82        } else {
83            die("unsupported export by the $pkg module: $name=$ref\n");
84        }
85    }
86}
87
88#
89# export control
90#
91
92sub import : method {
93    my($pkg, %exported);
94
95    $pkg = shift(@_);
96    grep($exported{$_}++, qw(export_control));
97    export_control(scalar(caller()), $pkg, \%exported, @_);
98}
99
1001;
101
102__DATA__
103
104=head1 NAME
105
106No::Worries::Export - symbol exporting without worries
107
108=head1 SYNOPSIS
109
110  use No::Worries::Export qw(export_control);
111
112  sub foo () { ... }
113
114  our $bar = 42;
115
116  sub import : method {
117      my($pkg, %exported);
118      $pkg = shift(@_);
119      grep($exported{$_}++, qw(foo $bar));
120      export_control(scalar(caller()), $pkg, \%exported, @_);
121  }
122
123=head1 DESCRIPTION
124
125This module eases symbol exporting by providing a simple yet powerful
126alternative to the L<Exporter> module.
127
128The symbols that can be imported are defined in a hash (the third
129argument of export_control()), the key being the symbol name and the
130value being:
131
132=over
133
134=item * a scalar: indicating a normal symbol
135
136=item * a code reference: to be called at import time
137
138=back
139
140The normal symbols can be functions (such as C<foo>), scalars
141(<$foo>), arrays (<@foo>) or hashes (<%foo>).
142
143All the normal symbols can be imported at once by using an asterisk in
144the import code:
145
146  use Foo qw(*);
147
148Alternatively, a regular expression can be given to filter what to
149import:
150
151  # import "foo" and all the normal symbols starting with "bar"
152  use Foo qw(foo /^bar/);
153
154The special symbols can be used to execute any code. For instance:
155
156  # exporting module
157  our $backend = "stdout";
158  sub import : method {
159      my($pkg, %exported);
160      $pkg = shift(@_);
161      $exported{syslog} = sub { $backend = "syslog" };
162      export_control(scalar(caller()), $pkg, \%exported, @_);
163  }
164
165  # importing code
166  use Foo qw(syslog);
167
168Finally, anything looking like a number will trigger a version check:
169
170  use Foo qw(1.2);
171  # will trigger
172  Foo->VERSION(1.2);
173
174See L<UNIVERSAL> for more information on the VERSION() mthod.
175
176=head1 FUNCTIONS
177
178This module provides the following function (not exported by default):
179
180=over
181
182=item export_control(CALLERPKG, PKG, EXPORT, NAMES...)
183
184control the symbols exported by the module; this should be called from
185an C<import> method
186
187=back
188
189=head1 SEE ALSO
190
191L<Exporter>,
192L<No::Worries>.
193
194=head1 AUTHOR
195
196Lionel Cons L<http://cern.ch/lionel.cons>
197
198Copyright (C) CERN 2012-2019
199