/usr/share/perl5/Sub/Defer.pm is in libmoo-perl 2.000002-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | package Sub::Defer;
use Moo::_strictures;
use Exporter qw(import);
use Moo::_Utils qw(_getglob _install_coderef);
use Scalar::Util qw(weaken);
our $VERSION = '2.000002';
$VERSION = eval $VERSION;
our @EXPORT = qw(defer_sub undefer_sub undefer_all);
our @EXPORT_OK = qw(undefer_package);
our %DEFERRED;
sub undefer_sub {
my ($deferred) = @_;
my ($target, $maker, $undeferred_ref) = @{
$DEFERRED{$deferred}||return $deferred
};
return ${$undeferred_ref}
if ${$undeferred_ref};
${$undeferred_ref} = my $made = $maker->();
# make sure the method slot has not changed since deferral time
if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
no warnings 'redefine';
# I believe $maker already evals with the right package/name, so that
# _install_coderef calls are not necessary --ribasushi
*{_getglob($target)} = $made;
}
$DEFERRED{$made} = $DEFERRED{$deferred};
weaken $DEFERRED{$made}
unless $target;
return $made;
}
sub undefer_all {
undefer_sub($_) for keys %DEFERRED;
return;
}
sub undefer_package {
my $package = shift;
my @subs = grep { $DEFERRED{$_}[0] =~ /^${package}::[^:]+$/ } keys %DEFERRED;
undefer_sub($_) for @subs;
return;
}
sub defer_info {
my ($deferred) = @_;
my $info = $DEFERRED{$deferred||''} or return undef;
[ @$info ];
}
sub defer_sub {
my ($target, $maker) = @_;
my $undeferred;
my $deferred_info;
my $deferred = sub {
$undeferred ||= undefer_sub($deferred_info->[3]);
goto &$undeferred;
};
$deferred_info = [ $target, $maker, \$undeferred, $deferred ];
weaken($deferred_info->[3]);
weaken($DEFERRED{$deferred} = $deferred_info);
_install_coderef($target => $deferred) if defined $target;
return $deferred;
}
sub CLONE {
%DEFERRED = map { defined $_ && $_->[3] ? ($_->[3] => $_) : () } values %DEFERRED;
foreach my $info (values %DEFERRED) {
weaken($info)
unless $info->[0] && ${$info->[2]};
}
}
1;
__END__
=head1 NAME
Sub::Defer - defer generation of subroutines until they are first called
=head1 SYNOPSIS
use Sub::Defer;
my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
my $t = time;
sub { time - $t };
};
Logger->time_since_first_log; # returns 0 and replaces itself
Logger->time_since_first_log; # returns time - $t
=head1 DESCRIPTION
These subroutines provide the user with a convenient way to defer creation of
subroutines and methods until they are first called.
=head1 SUBROUTINES
=head2 defer_sub
my $coderef = defer_sub $name => sub { ... };
This subroutine returns a coderef that encapsulates the provided sub - when
it is first called, the provided sub is called and is -itself- expected to
return a subroutine which will be goto'ed to on subsequent calls.
If a name is provided, this also installs the sub as that name - and when
the subroutine is undeferred will re-install the final version for speed.
Exported by default.
=head2 undefer_sub
my $coderef = undefer_sub \&Foo::name;
If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
If the passed coderef has not been deferred, this will just return it.
If this is confusing, take a look at the example in the L</SYNOPSIS>.
Exported by default.
=head2 undefer_all
undefer_all();
This will undefer all defered subs in one go. This can be very useful in a
forking environment where child processes would each have to undefer the same
subs. By calling this just before you start forking children you can undefer
all currently deferred subs in the parent so that the children do not have to
do it. Note this may bake the behavior of some subs that were intended to
calculate their behavior later, so it shouldn't be used midway through a
module load or class definition.
Exported by default.
=head2 undefer_package
undefer_package($package);
This undefers all defered subs in a package.
Not exported by default.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
|