File Coverage

blib/lib/Object/Import.pm
Criterion Covered Total %
statement 124 128 96.8
branch 44 56 78.5
condition 26 30 86.6
subroutine 21 21 100.0
pod 0 4 0.0
total 215 239 89.9


line stmt bran cond sub pod time code
1             package Object::Import;
2 14     14   590881 use warnings;
  14         35  
  14         11181  
3             our $VERSION = 1.004;
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             =head1 COPYING
415              
416             Copyright (C) Zsban Ambrus 2010
417              
418             This program is free software: you can redistribute it and/or modify
419             it under the terms of either the GNU General Public License version 3,
420             as published by the Free Software Foundation; or the "Artistic License"
421             which comes with perl.
422              
423             This program is distributed in the hope that it will be useful,
424             but WITHOUT ANY WARRANTY; without even the implied warranty of
425             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
426             GNU General Public License for more details.
427              
428             A copy of the GNU General Public License can be found in the
429             source tree of this module under the name "GPL", or else see
430             "http://www.gnu.org/licenses/". A copy of the Artistic License can
431             be found in the source tree under the name "ARTISTIC", or else see
432             "http://search.cpan.org/~rjbs/perl-5.16.1/pod/perlartistic.pod".
433              
434             =cut
435              
436              
437 14     14   463 use strict;
  14         30  
  14         690  
438 14     14   404 use 5.007;
  14         48  
  14         936  
439 14     14   84 use Scalar::Util qw"blessed reftype";
  14         24  
  14         12380  
440 14     14   14653 eval "
  14         53834  
  14         346  
441             use MRO::Compat;
442             ";
443             if (my $use_mro_compat_error = $@) {
444             eval "
445             use mro;
446             ";
447             my $use_mro_error = $@;
448             $use_mro_error and
449             die "$use_mro_compat_error\n$use_mro_error\nerror: could not use either of modules MRO::Compat or mro";
450             }
451              
452              
453             # Methods must not be exported automatically if their original name is in %special_source
454             # or if the name of the exported sub is in %special_target.
455             our %special_source;
456             our %special_target;
457              
458             # Any name starting with a character other than a letter or underscore are forced to
459             # package main. Such names in other packages may only be accessed with an explicit
460             # package name. Most of these are special or reserved to be special by the core, though
461             # none of their function slots are used. We do not export these because the user could
462             # not call them easily unless exported to main. Note that names starting with unicode
463             # non-letter characters or names that start with invalid utf-8 also seem to be forced
464             # to main (these may only be accessed through symbolic references).
465             # The following names are also forced to main like above.
466             $special_source{$_}++, $special_target{$_}++ for
467             qw"ENV INC ARGV ARGVOUT SIG STDIN STDOUT STDERR _";
468             # The following names are called by the core on some occasions.
469             $special_source{$_}++, $special_target{$_}++ for qw"
470             AUTOLOAD BINMODE CLEAR CLEARERR CLONE CLONE_SKIP CLOSE DELETE DESTROY
471             EOF ERROR EXISTS EXTEND FDOPEN FETCH FETCHSIZE FILENO FILL FIRSTKEY
472             FLUSH GETC NEXTKEY OPEN POP POPPED PRINT PRINTF PUSH PUSHED READ READLINE
473             SCALAR SEEK SETLINEBUF SHIFT SPLICE STORE STORESIZE SYSOPEN TELL TIEARRAY
474             TIEHANDLE TIEHASH TIESCALAR UNREAD UNSHIFT UNTIE UTF8 WRITE";
475             # Names starting with "(" are used by the overload mechanism, even as functions in some
476             # cases. We do not touch such subs.
477             # Names starting with "_<" are used for something related to source files,
478             # but the sub slot is not used, so we don't care.
479             # The following names are called by use/no, so they definitely should not be exported.
480             $special_source{$_}++, $special_target{$_}++ for qw"import unimport";
481             # The following should not occur as subs, but we exclude them for good measure.
482             $special_source{$_}++, $special_target{$_}++ for
483             qw"BEGIN UNITCHECK CHECK INIT END";
484             # The following names could override a builtin function if exported to a module
485             $special_target{$_}++ for qw"
486             abs accept alarm atan2 bind binmode bless break caller chdir chmod
487             chomp chop chown chr chroot close closedir connect continue cos
488             crypt dbmclose dbmopen default defined delete die do dump each
489             else elsif endgrent endhostent endnetent endprotoent endpwent
490             endservent eof eval exec exists exit exp fcntl fileno flock for
491             foreach fork format formline getc getgrent getgrgid getgrnam
492             gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr
493             getnetbyname getnetent getpeername getpgrp getppid getpriority
494             getprotobyname getprotobynumber getprotoent getpwent getpwnam
495             getpwuid getservbyname getservbyport getservent getsockname
496             getsockopt given glob gmtime goto grep hex if index int
497             ioctl join keys kill last lc lcfirst length link listen local
498             localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd
499             my next no not oct open opendir ord our pack package pipe pop
500             pos print printf prototype push quotemeta rand read readdir
501             readline readlink readpipe recv redo ref rename require reset
502             return reverse rewinddir rindex rmdir say scalar seek seekdir
503             select semctl semget semop send setgrent sethostent setnetent
504             setpgrp setpriority setprotoent setpwent setservent setsockopt
505             shift shmctl shmget shmread shmwrite shutdown sin sleep socket
506             socketpair sort splice split sprintf sqrt srand stat state
507             study sub substr symlink syscall sysopen sysread sysseek system
508             syswrite tell telldir tie tied time times truncate uc ucfirst
509             umask undef unless unlink unpack unshift untie until use utime
510             values vec wait waitpid wantarray warn when while write
511             fc evalbytes __SUB__ __FILE__ __LINE__ __PACKAGE__
512             ";
513             # The following four are UNIVERSAL functions.
514             $special_source{$_}++, $special_target{$_}++ for qw"can isa DOES VERSION";
515             # The following keywords cannot be overriden this way, so are safe to export,
516             # though you may have to use tricky syntax to call some of them:
517             0 for qw "and cmp eq ge gt le lt m ne or q qq qr qw qx s tr x xor y";
518             # The old aliases LT etc are removed from core at perl 5.8 and do not count
519             # as special anymore.
520             # Some of the above long list might also not be overridable, eg. "if".
521             # The following are special, but are not functions and not forced to main.
522             0 for qw"a b DATA OVERLOAD";
523             # The following names are English aliases for special variables so they could
524             # be aliased to special names, eg. if the module imports English
525             # then &ARG and &::_ are the same. The function slot of none of these is special.
526             # Exporting to such names would be a bad idea because they could overwrite
527             # a function in main.
528             $special_source{$_}++, $special_target{$_}++ for qw"
529             ACCUMULATOR ARG ARRAY_BASE BASETIME CHILD_ERROR COMPILING DEBUGGING
530             EFFECTIVE_GROUP_ID EFFECTIVE_USER_ID EGID ERRNO EUID EVAL_ERROR
531             EXCEPTIONS_BEING_CAUGHT EXECUTABLE_NAME EXTENDED_OS_ERROR FORMAT_FORMFEED
532             FORMAT_LINES_LEFT FORMAT_LINES_PER_PAGE FORMAT_LINE_BREAK_CHARACTERS
533             FORMAT_NAME FORMAT_PAGE_NUMBER FORMAT_TOP_NAME GID INPLACE_EDIT
534             INPUT_LINE_NUMBER INPUT_RECORD_SEPARATOR LAST_MATCH_END LAST_MATCH_START
535             LAST_PAREN_MATCH LAST_REGEXP_CODE_RESULT LAST_SUBMATCH_RESULT
536             LIST_SEPARATOR MATCH NR OFMT OFS OLD_PERL_VERSION ORS OSNAME OS_ERROR
537             OUTPUT_AUTOFLUSH OUTPUT_FIELD_SEPARATOR OUTPUT_RECORD_SEPARATOR PERLDB
538             PERL_VERSION PID POSTMATCH PREMATCH PROCESS_ID PROGRAM_NAME REAL_GROUP_ID
539             REAL_USER_ID RS SUBSCRIPT_SEPARATOR SUBSEP SYSTEM_FD_MAX UID WARNING";
540             # The following are names used by Exporter, but not as functions.
541             0 for qw"EXPORT EXPORT_OK EXPORT_FAIL EXPORT_TAGS";
542             # The following are subs used by Exporter, some internal.
543             $special_source{$_}++, $special_target{$_}++ for qw"
544             _push_tags _rebuild_cache as_heavy export export_fail export_fail_in
545             export_ok_tags export_tags export_to_level heavy_export
546             heavy_export_ok_tags heavy_export_tags heavy_export_to_level
547             heavy_require_version require_version";
548             # (Ideally we should have a mechanism to exclude everything that's defined in Exporter
549             # or Exporter::Heavy)
550             # The following are depreciated aliases to the standard filehandles, but as these aren't
551             # forced to main we shan't exclude them.
552             0 for qw"stdin stdout stderr";
553             # Yeah, these lists got out of hand, but I want a place to collect all special names.
554             # TODO: See also the B::Keywords module, and submit patches for it.
555             # If the user gives an list of names, we assume they know what they are doing.
556              
557             sub special_source {
558 1362     1362 0 2520 my($n) = @_;
559 1362         2625 utf8::decode($n);
560 14 100   14   19131 exists($special_source{$n}) || $n !~ /\A[_\pL]/;
  14         359  
  14         218  
  1362         18118  
561             }
562             sub special_target {
563 898     898 0 1449 my($n) = @_;
564 898         1613 utf8::decode($n);
565 898 100       6650 exists($special_target{$n}) || $n !~ /\A[_\pL]/;
566             }
567              
568              
569             # this returns a list to the methods we want to export automatically
570             sub list_method {
571 37     37 0 80 my($obj, $expkg, $debug, $nowarn_nomethod, $underscore, $exclude) = @_;
572 37         55 my $oobj = $obj;
573 37 100       55 my %exclude; if ($exclude) { %exclude = %$exclude; }
  37         109  
  2         8  
574             my $complain = sub {
575 4     4   8 my($k) = @_;
576 4 50       9 $nowarn_nomethod and return;
577 14     14   434420 no warnings "uninitialized";
  14         39  
  14         3287  
578 4         41 warn "warning: Object::Import cannot find methods of " . $k . ": " . $oobj;
579 37         273 };
580 37 100 100     370 if (reftype($obj) ? !defined(blessed($obj)) && "GLOB" eq reftype($obj) : "GLOB" eq reftype(\$obj)) {
    100          
581 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.
582             # 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.
583 4 50       17 if (!defined($obj)) {
584 0         0 &$complain("globref with no IO handle");
585 0         0 return;
586             }
587             }
588 37         78 eval { $obj->can("import") };
  37         317  
589 37         91 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
590 37 100       118 if (!$can_methods) {
591 2 50       20 &$complain(
    0          
    50          
    50          
    100          
592             reftype($obj) ? (defined(blessed($obj)) ? "strange object" : "unblessed reference") :
593             !defined($obj) ? "undefined value" :
594             !length($obj) ? "empty string value" :
595             !$obj ? "false value" :
596             "string value that is an invalid package name");
597 2         30 return;
598             }
599 14 100 66 14   87 if (!reftype($obj) && do { no strict "refs"; !%{$obj . "::"} }) {
  14         103  
  14         2372  
  35         517  
  14         21  
  14         80  
600 2         6 &$complain("nonexistent package");
601             }
602 35         77 my %r;
603 35   66     335 my $class = blessed($obj) || $obj;
604 35         58 my @class = @{mro::get_linear_isa($class)};
  35         355  
605 35 50       105 $debug and warn "debug: Object::Import object $oobj, class $class, search path: @class";
606 35         80 for my $pkgn (@class) {
607 14     14   96 my $pkg = do { no strict "refs"; \%{$pkgn . "::"}};
  14         24  
  14         7022  
  62         80  
  62         80  
  62         280  
608 62         1541 for my $m (sort keys %$pkg) {
609 2003 100 100     18335 if (
      100        
      100        
      100        
      66        
610             !$exclude{$m} &&
611             !$r{$m} &&
612             $obj->can($m) && # was exists(&{$$pkg{$m}})
613             !special_source($m) &&
614             ($underscore || $m !~ /\A_/)
615             ) {
616 900         8729 $r{$m}++;
617             }
618             }
619             }
620 35         924 keys(%r);
621             }
622              
623              
624             sub dor ($$) {
625 153     153 0 229 my($x, $y) = @_;
626 153 100       596 defined($x) ? $x : $y;
627             }
628              
629             sub import {
630 54     54   126020 my($_u, $arg1, @opt) = @_;
631 54 100       230 if (@_ <= 1) {
632 3         299 return; # required for later imports
633             }
634 51 50       230 0 == @opt % 2 or
635             die q"error: odd number of import options to Object::Import; usage: use Object::Import $obj, %opts";
636 51         338 my %opt = @opt;
637 51         814 my($deref, $methl, $debug, $nowarn_redefine, $nowarn_nomethod, $underscore, $exclude_method, $exclude_import, $savename, $funprefix, $funsuffix, $expkgn) =
638             delete(@opt{(qw"deref list debug nowarn_redefine nowarn_nomethod underscore exclude_methods exclude_imports savenames prefix suffix target")});
639 51 50       177 %opt and
640             die "error: unused import options to Object::Import: " . join(" ", keys(%opt));
641 51         223 $expkgn = dor($expkgn, scalar caller);
642 51 100       154 my $objr = $deref ? $arg1 : \$arg1;
643 51         343 $_ = dor($_, "") for $funprefix, $funsuffix; # one could use the suffix "0" afterall
644 51 100       90 my %exclude_import; $exclude_import and %exclude_import = %$exclude_import;
  51         148  
645 51         124 my $expkgns = $expkgn . "::";
646 14     14   84 my $expkg = do {no strict 'refs'; \%{$expkgns} };
  14         26  
  14         1084  
  51         70  
  51         62  
  51         196  
647 51 50       148 if ($debug) { warn "debug: Object::Import starting to export methods to package $expkgns"; }
  0         0  
648 51         78 my @meth;
649 51 100       122 if ($methl) {
650 14         41 @meth = @$methl;
651             } else {
652 14     14   191 @meth = list_method do { no strict "refs"; $$objr }, $expkg, $debug, $nowarn_nomethod, $underscore, $exclude_method;
  14         26  
  14         1812  
  37         55  
  37         166  
653             }
654 51         145 my @funn;
655 51         114 for my $methn (@meth) {
656 919         10952 my $funn = $funprefix . $methn . $funsuffix;
657 919 100 100     4080 if (!$exclude_import{$funn} &&
      66        
658             ($methl ||
659             (!special_target($funn) &&
660             !exists(&{$expkgns . $funn}))) # was (!$$expkg{$funn} || !exists(&{$$expkg{$funn}}))
661             # that's wrong because of some shortcut symbol table entries for constants or predeclared subs
662             ) {
663 14     14   69 my $p = sub (@) { no strict "refs"; $$objr->${\$methn}(@_) };
  14     99   26  
  14         739  
  913         5170  
  99         151984  
  99         866  
664             {
665 14     14   69 no strict 'refs';
  14         31  
  14         437  
  913         1101  
666 913 100       1695 if ($nowarn_redefine) {
667 14     14   67 no warnings "redefine";
  14         22  
  14         3433  
668 2         5 *{$expkgns . $funn} = $p;
  2         33  
669             } else {
670 911         1868 *{$expkgns . $funn} = $p;
  911         5606  
671             }
672             }
673 913         2813 push @funn, $funn;
674             }
675             }
676 51 50       308 if ($debug) { warn "debug: Object::Import exported the following functions: ", join(" ", sort(@funn)); }
  0         0  
677 51 100       9032 if ($savename) {
678 13         190 $$savename{$_}++ for @funn;
679             }
680             }
681              
682              
683             1;
684             __END__