File Coverage

blib/lib/Object/Import.pm
Criterion Covered Total %
statement 123 127 96.8
branch 44 56 78.5
condition 29 30 96.6
subroutine 21 21 100.0
pod 0 4 0.0
total 217 238 91.1


line stmt bran cond sub pod time code
1             package Object::Import;
2 14     14   892782 use warnings;
  14         137  
  14         1706  
3             our $VERSION = 1.005;
4              
5              
6             =head1 NAME
7              
8             Object::Import - import methods of an object as functions to a package
9              
10             =head1 SYNOPSIS
11              
12             use Object::Import $object;
13             foo(@bar); # now means $object->foo(@bar);
14              
15             =head1 DESCRIPTION
16              
17             This module lets you call methods of a certain object more easily by
18             exporting them as functions to a package. The exported functions are
19             not called as methods and do not receive an object argument, but instead
20             the object is fixed at the time you import them with this module.
21              
22             You use the module with the following syntax:
23              
24             use Object::Import $object, %options;
25              
26             Here, C<$object> is the object from which you want to import the methods.
27             This can be a perl object (blessed reference), or the name of a package
28             that has class methods.
29              
30             As usual, a C statement is executed in compile time, so you should
31             take care not to use values that you compute only in run-time, eg.
32              
33             my $object = Foo::Bar->new();
34             use Object::Import $object; # WRONG: $object is not yet initialized
35              
36             Instead, you have to create the object before you import, such as
37              
38             use Object::Import Foo::Bar->new();
39              
40             You can also call import in run-time, eg.
41              
42             use Object::Import ();
43             my $object = Foo::Bar->new();
44             import Object::Import $object;
45              
46             but in that case, you can't call the imported functions without parenthesis.
47              
48             If you don't give an explicit list of methods to export, Object::Import
49             tries to find out what callable methods the object has and import
50             all of them. Some methods are excluded from exporting in this case,
51             namely any methods where exporting would overwrite a function existing
52             in the target package or would override a builtin function, also
53             any methods with names that are special to perl, such as C,
54             and any methods whose name starts with an underscore. This automatic
55             search for methods is quite fragile because of the way perl OO works,
56             so it can find subroutines that shouldn't actually be called as methods,
57             or not find methods that can actually be called. In particular, even
58             if you import an object from a purely object oriented module, it can
59             find non-method subs imported from other (non-OO) modules.
60              
61             If you do give a list of methods to export, Object::Import trusts you
62             know what you mean, so it exports all those subs even if it has to
63             replace existing subs or break something else.
64              
65             =head1 OPTIONS
66              
67             The following import options can be passed to the module.
68              
69             =over
70              
71             =item C<< list => >> I<$arrayref>
72              
73             Sets the list of methods to export, instead of the module deciding automatically.
74             I<$arrayref> must be a reference to an array containing method names. Eg.
75              
76             use Object::Import LWP::UserAgent->new, list =>
77             [qw"get post head mirror request simple_request"];
78              
79             =item C<< target => >> I<$package_name>
80              
81             Export the sub names to the given namespace. Default is the package
82             from where you call import.
83              
84             =item C<< deref => 1 >>
85              
86             Signals that the first import argument, instead of being the object
87             itself, is a reference to a scalar that contains the object.
88              
89             The content of this scalar may later be changed, and the imported
90             functions will be called on the new contents. (The scalar may even be
91             filled with undef, as long as you don't call the functions at that time.)
92             If you don't pass the list of methods explicitly, the content of the
93             scalar at the time of the import is used for determining the methods as
94             a template to determine the methods. If, however, you give the list
95             of methods, the content of the scalar is not examined at the time of
96             the import.
97              
98             =item C<< prefix => >> I<$string>
99              
100             Prepends a string to the names of functions imported. This is useful if
101             some of the method names are the same as existing subs or builtins. Eg.
102              
103             use Object::Import $object, prefix => "foo";
104             foo_bar(); # calls $object->bar();
105              
106             =item C<< suffix => >> I<$string>
107              
108             Like the prefix option, only the string is appended.
109              
110             =item C<< underscore => 1 >>
111              
112             Consider a method for automatic inclusion even if its name starts with
113             an underscore. Such methods are normally excluded, because they are
114             usually used as private subs.
115              
116             =item C<< exclude_methods => >> I<$hashref>
117              
118             Sets a list of additional methods that are not automatically imported.
119             The argument must be a reference to a hash whose keys are potential
120             method names. Ignored if you use the C option.
121              
122             =item C<< exclude_imports => >> I<$hashref>
123              
124             Sets a list of additional sub names which the module must never use as
125             names of imported subs. These names are thus compared not with the
126             original method names, but the names possibly transformed by adding
127             prefixes and suffixes. This applies even if you give an explicit C
128             of methods to import.
129              
130             =item C<< savenames => >> I<$hashref>
131              
132             Save the (unqualified) names of the functions exported by adding them
133             as a key to a hash (the value is incremented with the ++ operator).
134             This could be useful if you wanted to reexport them with Exporter.
135             I<$arrayref> must be a real reference to a hash, not an undef.
136              
137             =item C<< nowarn_redefine => 1 >>
138              
139             Do not warn when an existing sub is redefined. That is currently only
140             possible if you give the list of methods to be exported explicitly with
141             the C option, because if the module chooses automatically then it
142             will not redefine subs.
143              
144             =item C<< nowarn_nomethod => 1 >>
145              
146             Suppress the warning when you try to import methods from an object you
147             might have passed in by mistake. Namely the object could be the name
148             of a nonexistent package, a string that is not a valid package name,
149             an unblessed object, or undef. Such values either don't currently have
150             any methods, or calling methods on them is impossible. That warning
151             often indicates that you passed the wrong value to Object::Import or
152             forgot to require a package.
153              
154             =item C<< debug => 1 >>
155              
156             Print debugging messages about what the module exports.
157              
158             =back
159              
160             =head1 NOTES
161              
162             =head2 Importing from IO handles
163              
164             It is possible to use an IO handle as the object to export methods from.
165             If you do this, you should require IO::Handle first so that the handle
166             actually has methods. You should probably also use the prefix or suffix
167             option in such a case, because many methods of handles have the same name
168             as a builtin function.
169              
170             The handle must not be a symbolic reference, whether qualified or
171             unqualified, eg.
172              
173             open FOO, "<", "somefile" or die;
174             use Object::Import "FOO"; # WRONG
175              
176             You can pass a handle as a glob, reference to glob, or an IO::Handle
177             object, so any of these would work as the object after the above open
178             statement: C<*FOO>, C<\*FOO>, C<*FOO{IO}>. Another way to pass an
179             IO::Handle object would be like this:
180              
181             use IO::File;
182             use Object::Import IO::File->new("somefile", "<");
183              
184             =head2 Changing the object
185              
186             The C<< deref >> option deserves special mention.
187             This option adds a level of indirection to the imported functions:
188             instead of them calling methods on an object passed to import,
189             the methods are called on the object currently contained by a scalar
190             to which a reference is passed in to import.
191             This can be useful for various reasons:
192             operating on multiple objects throughout the course of the program,
193             being able to import the functions at compile time before you create the object,
194             or being able to destroy the object.
195             The first of this use is straightforward,
196             but you may need to know the following for the other two uses.
197              
198             The list of methods imported is decided at the time you call import,
199             and will not be changed later,
200             no matter how the object is changed or methods the object supports are changed.
201             You thus have to do extra loops if you want to call import
202             before the object is available.
203             The simplest solution is to pass the list of methods you want explicitly
204             using the I<< list >> option.
205             If for some reason you don't want to do this,
206             you need to fill the scalar with a suitable prototype object
207             that has all the methods of the actual object you want to use.
208             In many cases,
209             the package name the object will be blessed to is a suitable prototype,
210             but note that if you do not control the module implementing the object,
211             then that module may not guarantee
212             what package the object will actually be blessed to:
213             the package may depend on some run-time parameters
214             and the details about this could change in future versions of the module.
215             This is, of course, not specific to the deref option,
216             but true to a lesser extent to any case when you're using
217             Object::Import without an explicit list of methods:
218             a future version of the module could create the methods of the class
219             in runtime or AUTOLOAD them without declaring them,
220             or it could add new private methods that will clash with function names you're using.
221             Nevertheless, using the classname as a prototype can be a useful trick
222             in quick and dirty programs,
223             or if you are in control of the implementation of the object.
224              
225             Now let's hear about destroying an object that may hold resources you want to free.
226             Object::Import guarantees that if you use the I<< deref >> option,
227             it does not hold references to the object other than through the one scalar,
228             so if undef the contents of that scalar,
229             the object will be freed unless there are references from somewhere else.
230              
231             Finally, there's one thing you don't want to know but I must document it for completeness:
232             if a method called through Object::Import changes its invocant (zeroth argument),
233             that will also change the object the imported functions refer to,
234             whether you use the deref option or not,
235             and will change the contents of the scalar if you use the deref option.
236              
237             =head1 EXAMPLES
238              
239             Our examples assume the following declarations:
240              
241             use feature "say";
242              
243             =head2 Basic usage
244              
245             First a simple example of importing class methods.
246              
247             use Math::BigInt;
248             use Object::Import Math::BigInt::;
249             say new("0x100");
250              
251             This prints 256, because Math::BigInt->new("0x100") creates a big integer equal to 256.
252              
253             Now let's see a simple example of importing object methods.
254              
255             use Math::BigInt;
256             use Object::Import Math::BigInt->new("100");
257             say bmul(2);
258             say as_hex();
259              
260             This prints 200 (2 multiplied by 100), then 0xc8 (100 as hexadecimal).
261              
262             =head2 Multiple imports
263              
264             Now let's see a more complicated example. This prints the leading news from the English
265             Wikinews website.
266              
267             use warnings; use strict;
268             use LWP::UserAgent;
269             use XML::Twig;
270             use Object::Import LWP::UserAgent->new;
271             my $response = get "http://en.wikinews.org/wiki/Special:Export?".
272             "pages=Template:Lead_article_1&limit=1";
273             import Object::Import $response;
274             if (is_success()) {
275             use Object::Import XML::Twig->new;
276             parse content();
277             for my $parmname (qw"title summary") {
278             first_elt("text")->text =~ /\|\s*$parmname\s*=([^\|\}]+)/ or die;
279             print $1;
280             }
281             } else {
282             die message();
283             }
284              
285             For example, as I am writing this (2010-09-05), this outputs
286              
287             =over
288              
289             Magnitude 7.0 earthquake hits New Zealand
290              
291             An earthquake with magnitude 7.0 occurred near South Island, New
292             Zealand at Saturday 04:35:44 AM local time (16:35:44 UTC). The
293             earthquake occurred at a depth of 16.1 kilometers (10.0 miles). The
294             earthquake was reported to have caused widespread damage and power
295             outages. Several aftershocks were also reported.
296              
297             =back
298              
299             In this, C refers to the useragent object; C, C
300             and C refers to the response object (and these must be called
301             with a parenthesis); while C and C refer to the
302             twig object. This is not a good example to follow: it's quite fragile,
303             and not only because of the simple regex used to parse out the right
304             parts, but because if a new sub is added to a future version of the
305             L or L classes, they might suddenly get
306             imported and would shadow the methods we're supposed to import later.
307              
308             =head2 Suffix
309              
310             Now let's see an example of using a suffix.
311              
312             use File::Temp;
313             use Object::Import scalar(File::Temp->new()), suffix => "temp";
314             printtemp "hello, world\nhidden";
315             seektemp 0, 0;
316             print getlinetemp;
317             say filenametemp;
318              
319             Here we need the suffix because print and seek are names of builtin
320             functions.
321              
322             =head2 Creating the object later
323              
324             Let's see how we can import methods before we create an object.
325              
326             use Math::BigInt;
327             our $number;
328             use Object::Import \$number, deref => 1, list => ["bmul"];
329             sub double { bmul 2 }
330             $number = Math::BigInt->new("100");
331             say double;
332              
333             This will output 200.
334             Notice how here we're using the bmul function without parenthesis,
335             so we must import it compile time for the code to parse correctly,
336             but the object is not created till later.
337              
338             =head2 Prototype object
339              
340             This code is the same as above,
341             except that instead of supplying a list of methods,
342             we use a prototype object, namely the Math::BigInt package.
343             At least one of the two is needed, for otherwise Object::Import
344             would have no way to know what methods to import.
345              
346             use Math::BigInt;
347             our $number;
348             use Object::Import \($number = Math::BigInt::), deref => 1;
349             sub double { bmul 2 }
350             $number = Math::BigInt->new("100");
351             say double;
352              
353             =head2 Exporting to other package
354              
355             This example shows how to export to a different namespace.
356             This is useful if you want to write your own
357             sugar module that provides a procedural syntax:
358              
359             package My::Object::DSL;
360             use Object::Import;
361             use My::Object;
362              
363             sub import {
364             my ($class, %options);
365             if (@_ == 2) {
366             ($class, $options{ name }) = @_;
367             } else {
368             ($class, %options) = @_;
369             };
370             my $target = delete $options{ target } || caller;
371             my $name = delete $options{ name } || '$obj';
372             my $obj = My::Object->new(%options);
373              
374             $name =~ s/^[\$]//
375             or croak 'Variable name must start with $';
376             {
377             no strict 'refs';
378             *{"$target\::$name"} = \$obj;
379             # Now install in $target::
380             import Object::Import \${"$target\::$name"},
381             deref => 1,
382             target => $target;
383             }
384             }
385              
386             You can use the module C<< My::Object::DSL >> as follows:
387              
388             use My::Object::DSL '$obj';
389              
390             If you want to pass more options, you can use
391              
392             use My::Object::DSL name => '$obj', foo => 'bar';
393              
394             Implementing a small C<::DSL> module instead of using
395             C directly has the advantage that you can add defaults
396             in C.
397              
398             =head1 SEE ALSO
399              
400             L, L, L, L
401              
402             =head1 BUGS
403              
404             Please report bugs using the CPAN bug tracker (under the distribution
405             name Object-Import), or, failing that, to C.
406              
407             =head1 CREDITS
408              
409             The primary author and maintainer of this module is Zsban Ambrus
410             C. Some of the code was written by Max Maischein, who
411             also gave the motivation to turn a prototype to the full module you see.
412             Thanks to exussum0 for the original inspiration.
413              
414             The module is maintained by Max Maischein since 2018.
415              
416             =head1 COPYING
417              
418             Copyright (C) Zsban Ambrus 2010
419              
420             This program is free software: you can redistribute it and/or modify
421             it under the terms of either the GNU General Public License version 3,
422             as published by the Free Software Foundation; or the "Artistic License"
423             which comes with perl.
424              
425             This program is distributed in the hope that it will be useful,
426             but WITHOUT ANY WARRANTY; without even the implied warranty of
427             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
428             GNU General Public License for more details.
429              
430             A copy of the GNU General Public License can be found in the
431             source tree of this module under the name "GPL", or else see
432             "http://www.gnu.org/licenses/". A copy of the Artistic License can
433             be found in the source tree under the name "ARTISTIC", or else see
434             "http://search.cpan.org/~rjbs/perl-5.16.1/pod/perlartistic.pod".
435              
436             =cut
437              
438              
439 14     14   103 use strict;
  14         36  
  14         321  
440 14     14   322 use 5.007;
  14         61  
441 14     14   88 use Scalar::Util qw"blessed reftype";
  14         33  
  14         7936  
442 14     14   5882 eval "
  14         19219  
  14         319  
443             use MRO::Compat;
444             ";
445             if (my $use_mro_compat_error = $@) {
446             eval "
447             use mro;
448             ";
449             my $use_mro_error = $@;
450             $use_mro_error and
451             die "$use_mro_compat_error\n$use_mro_error\nerror: could not use either of modules MRO::Compat or mro";
452             }
453              
454              
455             # Methods must not be exported automatically if their original name is in %special_source
456             # or if the name of the exported sub is in %special_target.
457             our %special_source;
458             our %special_target;
459              
460             # Any name starting with a character other than a letter or underscore are forced to
461             # package main. Such names in other packages may only be accessed with an explicit
462             # package name. Most of these are special or reserved to be special by the core, though
463             # none of their function slots are used. We do not export these because the user could
464             # not call them easily unless exported to main. Note that names starting with unicode
465             # non-letter characters or names that start with invalid utf-8 also seem to be forced
466             # to main (these may only be accessed through symbolic references).
467             # The following names are also forced to main like above.
468             $special_source{$_}++, $special_target{$_}++ for
469             qw"ENV INC ARGV ARGVOUT SIG STDIN STDOUT STDERR _";
470             # The following names are called by the core on some occasions.
471             $special_source{$_}++, $special_target{$_}++ for qw"
472             AUTOLOAD BINMODE CLEAR CLEARERR CLONE CLONE_SKIP CLOSE DELETE DESTROY
473             EOF ERROR EXISTS EXTEND FDOPEN FETCH FETCHSIZE FILENO FILL FIRSTKEY
474             FLUSH GETC NEXTKEY OPEN POP POPPED PRINT PRINTF PUSH PUSHED READ READLINE
475             SCALAR SEEK SETLINEBUF SHIFT SPLICE STORE STORESIZE SYSOPEN TELL TIEARRAY
476             TIEHANDLE TIEHASH TIESCALAR UNREAD UNSHIFT UNTIE UTF8 WRITE";
477             # Names starting with "(" are used by the overload mechanism, even as functions in some
478             # cases. We do not touch such subs.
479             # Names starting with "_<" are used for something related to source files,
480             # but the sub slot is not used, so we don't care.
481             # The following names are called by use/no, so they definitely should not be exported.
482             $special_source{$_}++, $special_target{$_}++ for qw"import unimport";
483             # The following should not occur as subs, but we exclude them for good measure.
484             $special_source{$_}++, $special_target{$_}++ for
485             qw"BEGIN UNITCHECK CHECK INIT END";
486             # The following names could override a builtin function if exported to a module
487             $special_target{$_}++ for qw"
488             abs accept alarm atan2 bind binmode bless break caller chdir chmod
489             chomp chop chown chr chroot close closedir connect continue cos
490             crypt dbmclose dbmopen default defined delete die do dump each
491             else elsif endgrent endhostent endnetent endprotoent endpwent
492             endservent eof eval exec exists exit exp fcntl fileno flock for
493             foreach fork format formline getc getgrent getgrgid getgrnam
494             gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr
495             getnetbyname getnetent getpeername getpgrp getppid getpriority
496             getprotobyname getprotobynumber getprotoent getpwent getpwnam
497             getpwuid getservbyname getservbyport getservent getsockname
498             getsockopt given glob gmtime goto grep hex if index int
499             ioctl join keys kill last lc lcfirst length link listen local
500             localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd
501             my next no not oct open opendir ord our pack package pipe pop
502             pos print printf prototype push quotemeta rand read readdir
503             readline readlink readpipe recv redo ref rename require reset
504             return reverse rewinddir rindex rmdir say scalar seek seekdir
505             select semctl semget semop send setgrent sethostent setnetent
506             setpgrp setpriority setprotoent setpwent setservent setsockopt
507             shift shmctl shmget shmread shmwrite shutdown sin sleep socket
508             socketpair sort splice split sprintf sqrt srand stat state
509             study sub substr symlink syscall sysopen sysread sysseek system
510             syswrite tell telldir tie tied time times truncate uc ucfirst
511             umask undef unless unlink unpack unshift untie until use utime
512             values vec wait waitpid wantarray warn when while write
513             fc evalbytes __SUB__ __FILE__ __LINE__ __PACKAGE__
514             ";
515             # The following four are UNIVERSAL functions.
516             $special_source{$_}++, $special_target{$_}++ for qw"can isa DOES VERSION";
517             # The following keywords cannot be overriden this way, so are safe to export,
518             # though you may have to use tricky syntax to call some of them:
519             0 for qw "and cmp eq ge gt le lt m ne or q qq qr qw qx s tr x xor y";
520             # The old aliases LT etc are removed from core at perl 5.8 and do not count
521             # as special anymore.
522             # Some of the above long list might also not be overridable, eg. "if".
523             # The following are special, but are not functions and not forced to main.
524             0 for qw"a b DATA OVERLOAD";
525             # The following names are English aliases for special variables so they could
526             # be aliased to special names, eg. if the module imports English
527             # then &ARG and &::_ are the same. The function slot of none of these is special.
528             # Exporting to such names would be a bad idea because they could overwrite
529             # a function in main.
530             $special_source{$_}++, $special_target{$_}++ for qw"
531             ACCUMULATOR ARG ARRAY_BASE BASETIME CHILD_ERROR COMPILING DEBUGGING
532             EFFECTIVE_GROUP_ID EFFECTIVE_USER_ID EGID ERRNO EUID EVAL_ERROR
533             EXCEPTIONS_BEING_CAUGHT EXECUTABLE_NAME EXTENDED_OS_ERROR FORMAT_FORMFEED
534             FORMAT_LINES_LEFT FORMAT_LINES_PER_PAGE FORMAT_LINE_BREAK_CHARACTERS
535             FORMAT_NAME FORMAT_PAGE_NUMBER FORMAT_TOP_NAME GID INPLACE_EDIT
536             INPUT_LINE_NUMBER INPUT_RECORD_SEPARATOR LAST_MATCH_END LAST_MATCH_START
537             LAST_PAREN_MATCH LAST_REGEXP_CODE_RESULT LAST_SUBMATCH_RESULT
538             LIST_SEPARATOR MATCH NR OFMT OFS OLD_PERL_VERSION ORS OSNAME OS_ERROR
539             OUTPUT_AUTOFLUSH OUTPUT_FIELD_SEPARATOR OUTPUT_RECORD_SEPARATOR PERLDB
540             PERL_VERSION PID POSTMATCH PREMATCH PROCESS_ID PROGRAM_NAME REAL_GROUP_ID
541             REAL_USER_ID RS SUBSCRIPT_SEPARATOR SUBSEP SYSTEM_FD_MAX UID WARNING";
542             # The following are names used by Exporter, but not as functions.
543             0 for qw"EXPORT EXPORT_OK EXPORT_FAIL EXPORT_TAGS";
544             # The following are subs used by Exporter, some internal.
545             $special_source{$_}++, $special_target{$_}++ for qw"
546             _push_tags _rebuild_cache as_heavy export export_fail export_fail_in
547             export_ok_tags export_tags export_to_level heavy_export
548             heavy_export_ok_tags heavy_export_tags heavy_export_to_level
549             heavy_require_version require_version";
550             # (Ideally we should have a mechanism to exclude everything that's defined in Exporter
551             # or Exporter::Heavy)
552             # The following are depreciated aliases to the standard filehandles, but as these aren't
553             # forced to main we shan't exclude them.
554             0 for qw"stdin stdout stderr";
555             # Yeah, these lists got out of hand, but I want a place to collect all special names.
556             # TODO: See also the B::Keywords module, and submit patches for it.
557             # If the user gives an list of names, we assume they know what they are doing.
558              
559             sub special_source {
560 1421     1421 0 2456 my($n) = @_;
561 1421         2969 utf8::decode($n);
562 14 100   14   8114 exists($special_source{$n}) || $n !~ /\A[_\pL]/;
  14         212  
  14         211  
  1421         8273  
563             }
564             sub special_target {
565 952     952 0 1580 my($n) = @_;
566 952         2107 utf8::decode($n);
567 952 100       4377 exists($special_target{$n}) || $n !~ /\A[_\pL]/;
568             }
569              
570              
571             # this returns a list to the methods we want to export automatically
572             sub list_method {
573 37     37 0 104 my($obj, $expkg, $debug, $nowarn_nomethod, $underscore, $exclude) = @_;
574 37         62 my $oobj = $obj;
575 37 100       52 my %exclude; if ($exclude) { %exclude = %$exclude; }
  37         99  
  2         5  
576             my $complain = sub {
577 4     4   10 my($k) = @_;
578 4 50       8 $nowarn_nomethod and return;
579 14     14   293176 no warnings "uninitialized";
  14         32  
  14         2572  
580 4         46 warn "warning: Object::Import cannot find methods of " . $k . ": " . $oobj;
581 37         184 };
582 37 100 100     275 if (reftype($obj) ? !defined(blessed($obj)) && "GLOB" eq reftype($obj) : "GLOB" eq reftype(\$obj)) {
    100          
583 4         10 $obj = *$obj{IO}; # this magically converts any filehandle (glob, ref-to-glob, symref, true handle object) to a handle object. we need this to find the methods.
584             # note that we don't enter here if we have a blessed globref: magical overloaded objects such as File::Temp or Coro::Handle objs can take care of themselves, and we'd lose methods if we dereferenced them to their underlying handles.
585 4 50       10 if (!defined($obj)) {
586 0         0 &$complain("globref with no IO handle");
587 0         0 return;
588             }
589             }
590 37         70 eval { $obj->can("import") };
  37         239  
591 37         85 my $can_methods = !$@; # false if $obj is an unblessed ref or a string that does not look like a package name, so perl refuses to call any methods
592 37 100       94 if (!$can_methods) {
593 2 50       17 &$complain(
    0          
    50          
    50          
    100          
594             reftype($obj) ? (defined(blessed($obj)) ? "strange object" : "unblessed reference") :
595             !defined($obj) ? "undefined value" :
596             !length($obj) ? "empty string value" :
597             !$obj ? "false value" :
598             "string value that is an invalid package name");
599 2         33 return;
600             }
601 14 100 100 14   96 if (!reftype($obj) && do { no strict "refs"; !%{$obj . "::"} }) {
  14         28  
  14         1565  
  35         122  
  14         25  
  14         77  
602 2         6 &$complain("nonexistent package");
603             }
604 35         81 my %r;
605 35   66     133 my $class = blessed($obj) || $obj;
606 35         64 my @class = @{mro::get_linear_isa($class)};
  35         168  
607 35 50       93 $debug and warn "debug: Object::Import object $oobj, class $class, search path: @class";
608 35         76 for my $pkgn (@class) {
609 14     14   88 my $pkg = do { no strict "refs"; \%{$pkgn . "::"}};
  14         28  
  14         4713  
  62         96  
  62         82  
  62         164  
610 62         1064 for my $m (sort keys %$pkg) {
611 2064 100 100     9674 if (
      100        
      100        
      100        
      100        
612             !$exclude{$m} &&
613             !$r{$m} &&
614             $obj->can($m) && # was exists(&{$$pkg{$m}})
615             !special_source($m) &&
616             ($underscore || $m !~ /\A_/)
617             ) {
618 954         2182 $r{$m}++;
619             }
620             }
621             }
622 35         448 keys(%r);
623             }
624              
625              
626             sub dor ($$) {
627 153     153 0 268 my($x, $y) = @_;
628 153 100       415 defined($x) ? $x : $y;
629             }
630              
631             sub import {
632 54     54   87938 my($_u, $arg1, @opt) = @_;
633 54 100       205 if (@_ <= 1) {
634 3         164 return; # required for later imports
635             }
636 51 50       176 0 == @opt % 2 or
637             die q"error: odd number of import options to Object::Import; usage: use Object::Import $obj, %opts";
638 51         172 my %opt = @opt;
639             my($deref, $methl, $debug, $nowarn_redefine, $nowarn_nomethod, $underscore, $exclude_method, $exclude_import, $savename, $funprefix, $funsuffix, $expkgn) =
640 51         338 delete(@opt{(qw"deref list debug nowarn_redefine nowarn_nomethod underscore exclude_methods exclude_imports savenames prefix suffix target")});
641 51 50       165 %opt and
642             die "error: unused import options to Object::Import: " . join(" ", keys(%opt));
643 51         173 $expkgn = dor($expkgn, scalar caller);
644 51 100       139 my $objr = $deref ? $arg1 : \$arg1;
645 51         157 $_ = dor($_, "") for $funprefix, $funsuffix; # one could use the suffix "0" afterall
646 51 100       80 my %exclude_import; $exclude_import and %exclude_import = %$exclude_import;
  51         172  
647 51         117 my $expkgns = $expkgn . "::";
648 14     14   108 my $expkg = do {no strict 'refs'; \%{$expkgns} };
  14         29  
  14         940  
  51         74  
  51         64  
  51         154  
649 51 50       128 if ($debug) { warn "debug: Object::Import starting to export methods to package $expkgns"; }
  0         0  
650 51         81 my @meth;
651 51 100       111 if ($methl) {
652 14         30 @meth = @$methl;
653             } else {
654 14     14   83 @meth = list_method do { no strict "refs"; $$objr }, $expkg, $debug, $nowarn_nomethod, $underscore, $exclude_method;
  14         26  
  14         1171  
  37         57  
  37         114  
655             }
656 51         98 my @funn;
657 51         95 for my $methn (@meth) {
658 973         1758 my $funn = $funprefix . $methn . $funsuffix;
659 973 100 100     2693 if (!$exclude_import{$funn} &&
      100        
660             ($methl ||
661             (!special_target($funn) &&
662             !exists(&{$expkgns . $funn}))) # was (!$$expkg{$funn} || !exists(&{$$expkg{$funn}}))
663             # that's wrong because of some shortcut symbol table entries for constants or predeclared subs
664             ) {
665 14     14   84 my $p = sub (@) { no strict "refs"; $$objr->${\$methn}(@_) };
  14     99   26  
  14         668  
  967         3706  
  99         83164  
  99         618  
666             {
667 14     14   74 no strict 'refs';
  14         28  
  14         378  
  967         1514  
668 967 100       1443 if ($nowarn_redefine) {
669 14     14   78 no warnings "redefine";
  14         33  
  14         2951  
670 2         4 *{$expkgns . $funn} = $p;
  2         21  
671             } else {
672 965         1151 *{$expkgns . $funn} = $p;
  965         3925  
673             }
674             }
675 967         2346 push @funn, $funn;
676             }
677             }
678 51 50       128 if ($debug) { warn "debug: Object::Import exported the following functions: ", join(" ", sort(@funn)); }
  0         0  
679 51 100       6299 if ($savename) {
680 13         145 $$savename{$_}++ for @funn;
681             }
682             }
683              
684              
685             1;
686             __END__