File Coverage

blib/lib/package/compute.pm
Criterion Covered Total %
statement 54 56 96.4
branch 18 24 75.0
condition 6 8 75.0
subroutine 9 9 100.0
pod n/a
total 87 97 89.6


line stmt bran cond sub pod time code
1             package package::compute;
2              
3 4     4   95332 use 5.008;
  4         16  
  4         152  
4 4     4   25 use strict;
  4         8  
  4         151  
5 4     4   19 use warnings;
  4         15  
  4         268  
6              
7             BEGIN {
8 4     4   10 $package::compute::AUTHORITY = 'cpan:TOBYINK';
9 4         145 $package::compute::VERSION = '0.004';
10             }
11              
12 4     4   4168 use B::Hooks::Parser 0.08 qw();
  4         23336  
  4         191  
13 4     4   40 use Carp qw(confess);
  4         9  
  4         1504  
14              
15             my $count = 0;
16              
17             sub import
18             {
19 5     5   51 my ($class, $name) = @_;
20            
21 5         13 my $caller = caller;
22 5         8 my $pkg;
23            
24 5 100 66     63 if (not defined $name)
    100 66        
    100          
25             {
26 1         1 $pkg = $caller;
27             }
28             elsif (!ref $name and $name eq '-anon')
29             {
30 1         6 $pkg = sprintf('%s::__ANON__::%s', $class, ++$count);
31             }
32             elsif (!ref $name and $name eq '-filename')
33             {
34             # figure out where we're called from
35 1         3 my (undef, $filename) = caller;
36              
37             # figure out where it got loaded via %INC.
38 1         62 for my $k (sort keys %INC)
39             {
40 48 100       84 if ($INC{$k} eq $filename)
41             {
42 1         3 $pkg = $k;
43 1         8 $pkg =~ s<[/\\]><::>g;
44 1         5 $pkg =~ s<\.pm$><>i; # can this be uppercase on some platforms?
45 1         4 last;
46             }
47             }
48             }
49             else
50             {
51 2         8 $pkg = __RPACKAGE__($name, $caller);
52             }
53            
54 5 50       31 confess("package::compute could not determine package name, died")
55             unless defined $pkg;
56            
57 5 100       33 B::Hooks::Parser::inject("; package $pkg;")
58             unless $pkg eq $caller;
59            
60 4     4   26 no strict 'refs';
  4         9  
  4         1955  
61 5         118 *{"$pkg\::__RPACKAGE__"} = \&__RPACKAGE__;
  5         3785  
62             }
63              
64             sub __RPACKAGE__
65             {
66 10     10   1099 my ($name, $caller) = @_;
67 10   100     35 $caller ||= scalar caller;
68 10 50       26 return $caller unless defined $name;
69            
70 10         14 my $count;
71 10         34 while (ref $name eq 'CODE')
72 0 0       0 { $name = $name->($caller); die "too deep" if ++$count > 7 }
  0         0  
73 10 50       58 if ($name =~ /^[.]+(?:::|'|\/)/)
74 10         25 { $name = "$caller\::$name" }
75            
76 10 50       88 my @pkg = grep { length and $_ ne '.' } split /(?:::|'|\/)/, $name;
  44         199  
77 10         18 my @final;
78 10         23 foreach (@pkg)
79             {
80 40         62 push @final, $_;
81 40 100       115 next unless /^([.]+)/;
82 7 100       275 confess "invalid relative package path" if length $1 > @final;
83 6         21 splice(@final, -(length $1));
84             }
85            
86 9         60 return join q/::/, @final;
87             }
88              
89             1;
90              
91             __END__