Install.pm
Go to the documentation of this file.
00001 # Original package Sub::Install downloaded from CPAN on 6/15/2012. This module 00002 # has been modified by Andreas Schuh on 6/15/2012 to make it part of BASIS. 00003 00004 package BASIS::Sub::Install; 00005 00006 use warnings; 00007 use strict; 00008 00009 use Carp; 00010 use Scalar::Util (); 00011 00012 =head1 NAME 00013 00014 BASIS::Sub::Install - install subroutines into packages easily 00015 00016 =head1 VERSION 00017 00018 version 0.926 00019 00020 =cut 00021 00022 our $VERSION = '0.926'; 00023 00024 =head1 SYNOPSIS 00025 00026 use BASIS::Sub::Install; 00027 00028 BASIS::Sub::Install::install_sub({ 00029 code => sub { ... }, 00030 into => $package, 00031 as => $subname 00032 }); 00033 00034 =head1 DESCRIPTION 00035 00036 This module makes it easy to install subroutines into packages without the 00037 unslightly mess of C<no strict> or typeglobs lying about where just anyone can 00038 see them. 00039 00040 =head1 FUNCTIONS 00041 00042 =head2 install_sub 00043 00044 BASIS::Sub::Install::install_sub({ 00045 code => \&subroutine, 00046 into => "Finance::Shady", 00047 as => 'launder', 00048 }); 00049 00050 This routine installs a given code reference into a package as a normal 00051 subroutine. The above is equivalent to: 00052 00053 no strict 'refs'; 00054 *{"Finance::Shady" . '::' . "launder"} = \&subroutine; 00055 00056 If C<into> is not given, the sub is installed into the calling package. 00057 00058 If C<code> is not a code reference, it is looked for as an existing sub in the 00059 package named in the C<from> parameter. If C<from> is not given, it will look 00060 in the calling package. 00061 00062 If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>. 00063 If C<as> is not given, but if C<code> is a code ref, BASIS::Sub::Install will try to 00064 find the name of the given code ref and use that as C<as>. 00065 00066 That means that this code: 00067 00068 BASIS::Sub::Install::install_sub({ 00069 code => 'twitch', 00070 from => 'Person::InPain', 00071 into => 'Person::Teenager', 00072 as => 'dance', 00073 }); 00074 00075 is the same as: 00076 00077 package Person::Teenager; 00078 00079 BASIS::Sub::Install::install_sub({ 00080 code => Person::InPain->can('twitch'), 00081 as => 'dance', 00082 }); 00083 00084 =head2 reinstall_sub 00085 00086 This routine behaves exactly like C<L</install_sub>>, but does not emit a 00087 warning if warnings are on and the destination is already defined. 00088 00089 =cut 00090 00091 sub _name_of_code { 00092 my ($code) = @_; 00093 require B; 00094 my $name = B::svref_2object($code)->GV->NAME; 00095 return $name unless $name =~ /\A__ANON__/; 00096 return; 00097 } 00098 00099 # See also Params::Util, to which this code was donated. 00100 sub _CODELIKE { 00101 (Scalar::Util::reftype($_[0])||'') eq 'CODE' 00102 || Scalar::Util::blessed($_[0]) 00103 && (overload::Method($_[0],'&{}') ? $_[0] : undef); 00104 } 00105 00106 # do the heavy lifting 00107 sub _build_public_installer { 00108 my ($installer) = @_; 00109 00110 sub { 00111 my ($arg) = @_; 00112 my ($calling_pkg) = caller(0); 00113 00114 # I'd rather use ||= but I'm whoring for Devel::Cover. 00115 for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} } 00116 00117 # This is the only absolutely required argument, in many cases. 00118 Carp::croak "named argument 'code' is not optional" unless $arg->{code}; 00119 00120 if (_CODELIKE($arg->{code})) { 00121 $arg->{as} ||= _name_of_code($arg->{code}); 00122 } else { 00123 Carp::croak 00124 "couldn't find subroutine named $arg->{code} in package $arg->{from}" 00125 unless my $code = $arg->{from}->can($arg->{code}); 00126 00127 $arg->{as} = $arg->{code} unless $arg->{as}; 00128 $arg->{code} = $code; 00129 } 00130 00131 Carp::croak "couldn't determine name under which to install subroutine" 00132 unless $arg->{as}; 00133 00134 $installer->(@$arg{qw(into as code) }); 00135 } 00136 } 00137 00138 # do the ugly work 00139 00140 my $_misc_warn_re; 00141 my $_redef_warn_re; 00142 BEGIN { 00143 $_misc_warn_re = qr/ 00144 Prototype\ mismatch:\ sub\ .+? | 00145 Constant subroutine \S+ redefined 00146 /x; 00147 $_redef_warn_re = qr/Subroutine\ \S+\ redefined/x; 00148 } 00149 00150 my $eow_re; 00151 BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ }; 00152 00153 sub _do_with_warn { 00154 my ($arg) = @_; 00155 my $code = delete $arg->{code}; 00156 my $wants_code = sub { 00157 my $code = shift; 00158 sub { 00159 my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic 00160 local $SIG{__WARN__} = sub { 00161 my ($error) = @_; 00162 for (@{ $arg->{suppress} }) { 00163 return if $error =~ $_; 00164 } 00165 for (@{ $arg->{croak} }) { 00166 if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { 00167 Carp::croak $base_error; 00168 } 00169 } 00170 for (@{ $arg->{carp} }) { 00171 if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { 00172 return $warn->(Carp::shortmess $base_error); 00173 } 00174 } 00175 ($arg->{default} || $warn)->($error); 00176 }; 00177 $code->(@_); 00178 }; 00179 }; 00180 return $wants_code->($code) if $code; 00181 return $wants_code; 00182 } 00183 00184 sub _installer { 00185 sub { 00186 my ($pkg, $name, $code) = @_; 00187 no strict 'refs'; ## no critic ProhibitNoStrict 00188 *{"$pkg\::$name"} = $code; 00189 return $code; 00190 } 00191 } 00192 00193 BEGIN { 00194 *_ignore_warnings = _do_with_warn({ 00195 carp => [ $_misc_warn_re, $_redef_warn_re ] 00196 }); 00197 00198 *install_sub = _build_public_installer(_ignore_warnings(_installer)); 00199 00200 *_carp_warnings = _do_with_warn({ 00201 carp => [ $_misc_warn_re ], 00202 suppress => [ $_redef_warn_re ], 00203 }); 00204 00205 *reinstall_sub = _build_public_installer(_carp_warnings(_installer)); 00206 00207 *_install_fatal = _do_with_warn({ 00208 code => _installer, 00209 croak => [ $_redef_warn_re ], 00210 }); 00211 } 00212 00213 =head2 install_installers 00214 00215 This routine is provided to allow BASIS::Sub::Install compatibility with 00216 BASIS::Sub::Installer. It installs C<install_sub> and C<reinstall_sub> methods into 00217 the package named by its argument. 00218 00219 BASIS::Sub::Install::install_installers('Code::Builder'); # just for us, please 00220 Code::Builder->install_sub({ name => $code_ref }); 00221 00222 BASIS::Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk? 00223 Anything::At::All->install_sub({ name => $code_ref }); 00224 00225 The installed installers are similar, but not identical, to those provided by 00226 BASIS::Sub::Installer. They accept a single hash as an argument. The key/value pairs 00227 are used as the C<as> and C<code> parameters to the C<install_sub> routine 00228 detailed above. The package name on which the method is called is used as the 00229 C<into> parameter. 00230 00231 Unlike BASIS::Sub::Installer's C<install_sub> will not eval strings into code, but 00232 will look for named code in the calling package. 00233 00234 =cut 00235 00236 sub install_installers { 00237 my ($into) = @_; 00238 00239 for my $method (qw(install_sub reinstall_sub)) { 00240 my $code = sub { 00241 my ($package, $subs) = @_; 00242 my ($caller) = caller(0); 00243 my $return; 00244 for (my ($name, $sub) = %$subs) { 00245 $return = BASIS::Sub::Install->can($method)->({ 00246 code => $sub, 00247 from => $caller, 00248 into => $package, 00249 as => $name 00250 }); 00251 } 00252 return $return; 00253 }; 00254 install_sub({ code => $code, into => $into, as => $method }); 00255 } 00256 } 00257 00258 =head1 EXPORTS 00259 00260 BASIS::Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are 00261 requested. 00262 00263 =head2 exporter 00264 00265 BASIS::Sub::Install has a never-exported subroutine called C<exporter>, which is used 00266 to implement its C<import> routine. It takes a hashref of named arguments, 00267 only one of which is currently recognize: C<exports>. This must be an arrayref 00268 of subroutines to offer for export. 00269 00270 This routine is mainly for BASIS::Sub::Install's own consumption. Instead, consider 00271 L<BASIS::Sub::Exporter>. 00272 00273 =cut 00274 00275 sub exporter { 00276 my ($arg) = @_; 00277 00278 my %is_exported = map { $_ => undef } @{ $arg->{exports} }; 00279 00280 sub { 00281 my $class = shift; 00282 my $target = caller; 00283 for (@_) { 00284 Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_}; 00285 install_sub({ code => $_, from => $class, into => $target }); 00286 } 00287 } 00288 } 00289 00290 BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); } 00291 00292 =head1 SEE ALSO 00293 00294 =over 00295 00296 =item L<BASIS::Sub::Installer> 00297 00298 This module is (obviously) a reaction to Damian Conway's BASIS::Sub::Installer, which 00299 does the same thing, but does it by getting its greasy fingers all over 00300 UNIVERSAL. I was really happy about the idea of making the installation of 00301 coderefs less ugly, but I couldn't bring myself to replace the ugliness of 00302 typeglobs and loosened strictures with the ugliness of UNIVERSAL methods. 00303 00304 =item L<BASIS::Sub::Exporter> 00305 00306 This is a complete Exporter.pm replacement, built atop BASIS::Sub::Install. 00307 00308 =back 00309 00310 =head1 AUTHOR 00311 00312 Ricardo Signes, C<< <rjbs@cpan.org> >> 00313 00314 Several of the tests are adapted from tests that shipped with Damian Conway's 00315 Sub-Installer distribution. 00316 00317 Modified by Andreas Schuh on 6/15/2012 in order to make it a subpackage 00318 of the SBIA namespace for inclusion with the BASIS package. 00319 00320 =head1 BUGS 00321 00322 Please report any bugs or feature requests through the web interface at 00323 L<http://rt.cpan.org>. I will be notified, and then you'll automatically be 00324 notified of progress on your bug as I make changes. 00325 00326 =head1 COPYRIGHT 00327 00328 Copyright 2005-2006 Ricardo Signes, All Rights Reserved. 00329 00330 This program is free software; you can redistribute it and/or modify it 00331 under the same terms as Perl itself. 00332 00333 =cut 00334 00335 1;