File Coverage

File:local/lib/perl5/Sub/Install.pm
Coverage:54.7%

linestmtbrancondsubtimecode
1
6
6
6
6
12
5
93
use strict;
2
6
6
6
6
10
4
124
use warnings;
3package Sub::Install;
4{
5  $Sub::Install::VERSION = '0.927';
6}
7# ABSTRACT: install subroutines into packages easily
8
9
6
6
6
6
12
3
149
use Carp;
10
6
6
6
6
12
6
1180
use Scalar::Util ();
11
12
13sub _name_of_code {
14
0
0
0
  my ($code) = @_;
15
0
0
  require B;
16
0
0
  my $name = B::svref_2object($code)->GV->NAME;
17
0
0
0
  return $name unless $name =~ /\A__ANON__/;
18
0
0
  return;
19}
20
21# See also Params::Util, to which this code was donated.
22sub _CODELIKE {
23
28
0
50
50
0
28
71
  (Scalar::Util::reftype($_[0])||'') eq 'CODE'
24  || Scalar::Util::blessed($_[0])
25  && (overload::Method($_[0],'&{}') ? $_[0] : undef);
26}
27
28# do the heavy lifting
29sub _build_public_installer {
30
12
12
10
  my ($installer) = @_;
31
32  sub {
33
28
28
10
    my ($arg) = @_;
34
28
32
    my ($calling_pkg) = caller(0);
35
36    # I'd rather use ||= but I'm whoring for Devel::Cover.
37
28
56
100
29
82
    for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} }
38
39    # This is the only absolutely required argument, in many cases.
40
28
50
44
    Carp::croak "named argument 'code' is not optional" unless $arg->{code};
41
42
28
50
25
    if (_CODELIKE($arg->{code})) {
43
28
33
25
      $arg->{as} ||= _name_of_code($arg->{code});
44    } else {
45
0
0
0
      Carp::croak
46        "couldn't find subroutine named $arg->{code} in package $arg->{from}"
47        unless my $code = $arg->{from}->can($arg->{code});
48
49
0
0
0
      $arg->{as}   = $arg->{code} unless $arg->{as};
50
0
0
      $arg->{code} = $code;
51    }
52
53
28
50
29
    Carp::croak "couldn't determine name under which to install subroutine"
54      unless $arg->{as};
55
56
28
29
    $installer->(@$arg{qw(into as code) });
57  }
58
12
30
}
59
60# do the ugly work
61
62my $_misc_warn_re;
63my $_redef_warn_re;
64BEGIN {
65
6
6
12
  $_misc_warn_re = qr/
66    Prototype\ mismatch:\ sub\ .+?  |
67    Constant subroutine \S+ redefined
68  /x;
69
6
97
  $_redef_warn_re = qr/Subroutine\ \S+\ redefined/x;
70}
71
72my $eow_re;
73
6
6
843
BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ };
74
75sub _do_with_warn {
76
18
18
13
  my ($arg) = @_;
77
18
20
  my $code = delete $arg->{code};
78  my $wants_code = sub {
79
18
18
18
15
10
    my $code = shift;
80    sub {
81
28
0
50
26
39
0
      my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic
82      local $SIG{__WARN__} = sub {
83
0
0
0
        my ($error) = @_;
84
0
0
0
0
        for (@{ $arg->{suppress} }) {
85
0
0
0
            return if $error =~ $_;
86        }
87
0
0
0
0
        for (@{ $arg->{croak} }) {
88
0
0
0
          if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
89
0
0
            Carp::croak $base_error;
90          }
91        }
92
0
0
0
0
        for (@{ $arg->{carp} }) {
93
0
0
0
          if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
94
0
0
            return $warn->(Carp::shortmess $base_error);
95          }
96        }
97
0
0
0
        ($arg->{default} || $warn)->($error);
98
28
65
      };
99
28
27
      $code->(@_);
100
18
812
    };
101
18
25
  };
102
18
100
42
  return $wants_code->($code) if $code;
103
12
12
  return $wants_code;
104}
105
106sub _installer {
107  sub {
108
28
28
20
    my ($pkg, $name, $code) = @_;
109
6
6
6
6
18
4
436
    no strict 'refs'; ## no critic ProhibitNoStrict
110
28
28
13
56
    *{"$pkg\::$name"} = $code;
111
28
4395
    return $code;
112  }
113
18
18
34
}
114
115BEGIN {
116
6
6
15
  *_ignore_warnings = _do_with_warn({
117    carp => [ $_misc_warn_re, $_redef_warn_re ]
118  });
119
120
6
11
  *install_sub = _build_public_installer(_ignore_warnings(_installer));
121
122
6
13
  *_carp_warnings =  _do_with_warn({
123    carp     => [ $_misc_warn_re ],
124    suppress => [ $_redef_warn_re ],
125  });
126
127
6
9
  *reinstall_sub = _build_public_installer(_carp_warnings(_installer));
128
129
6
7
  *_install_fatal = _do_with_warn({
130    code     => _installer,
131    croak    => [ $_redef_warn_re ],
132  });
133}
134
135
136sub install_installers {
137
0
0
0
  my ($into) = @_;
138
139
0
0
  for my $method (qw(install_sub reinstall_sub)) {
140    my $code = sub {
141
0
0
0
      my ($package, $subs) = @_;
142
0
0
      my ($caller) = caller(0);
143
0
0
      my $return;
144
0
0
      for (my ($name, $sub) = %$subs) {
145
0
0
        $return = Sub::Install->can($method)->({
146          code => $sub,
147          from => $caller,
148          into => $package,
149          as   => $name
150        });
151      }
152
0
0
      return $return;
153
0
0
    };
154
0
0
    install_sub({ code => $code, into => $into, as => $method });
155  }
156}
157
158
159sub exporter {
160
12
12
12
  my ($arg) = @_;
161
162
12
24
12
6
32
17
  my %is_exported = map { $_ => undef } @{ $arg->{exports} };
163
164  sub {
165
0
0
    my $class = shift;
166
0
    my $target = caller;
167
0
    for (@_) {
168
0
0
      Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_};
169
0
      install_sub({ code => $_, from => $class, into => $target });
170    }
171  }
172
12
163
}
173
174
6
6
25
BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); }
175
176
1771;
178