← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:04 2021

Filename/usr/local/lib/perl5/site_perl/Module/Implementation.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sModule::Implementation::::BEGIN@128Module::Implementation::BEGIN@128
0000s0sModule::Implementation::::BEGIN@129Module::Implementation::BEGIN@129
0000s0sModule::Implementation::::BEGIN@5Module::Implementation::BEGIN@5
0000s0sModule::Implementation::::BEGIN@6Module::Implementation::BEGIN@6
0000s0sModule::Implementation::::BEGIN@8Module::Implementation::BEGIN@8
0000s0sModule::Implementation::::BEGIN@9Module::Implementation::BEGIN@9
0000s0sModule::Implementation::::CORE:substModule::Implementation::CORE:subst (opcode)
0000s0sModule::Implementation::::__ANON__[:52]Module::Implementation::__ANON__[:52]
0000s0sModule::Implementation::::__ANON__[:78]Module::Implementation::__ANON__[:78]
0000s0sModule::Implementation::::__ANON__[:82]Module::Implementation::__ANON__[:82]
0000s0sModule::Implementation::::__ANON__[:95]Module::Implementation::__ANON__[:95]
0000s0sModule::Implementation::::__ANON__[:98]Module::Implementation::__ANON__[:98]
0000s0sModule::Implementation::::_build_loaderModule::Implementation::_build_loader
0000s0sModule::Implementation::::_copy_symbolsModule::Implementation::_copy_symbols
0000s0sModule::Implementation::::_load_implementationModule::Implementation::_load_implementation
0000s0sModule::Implementation::::build_loader_subModule::Implementation::build_loader_sub
0000s0sModule::Implementation::::catch {...} Module::Implementation::catch {...}
0000s0sModule::Implementation::::implementation_forModule::Implementation::implementation_for
0000s0sModule::Implementation::::try {...} Module::Implementation::try {...}
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Module::Implementation;
2# git description: v0.08-2-gd599347
3$Module::Implementation::VERSION = '0.09';
4
5use strict;
6use warnings;
7
8use Module::Runtime 0.012 qw( require_module );
9use Try::Tiny;
10
11# This is needed for the benefit of Test::CleanNamespaces, which in turn loads
12# Package::Stash, which in turn loads this module and expects a minimum
13# version.
14unless ( exists $Module::Implementation::{VERSION}
15 && ${ $Module::Implementation::{VERSION} } ) {
16
17 $Module::Implementation::{VERSION} = \42;
18}
19
20my %Implementation;
21
22sub build_loader_sub {
23 my $caller = caller();
24
25 return _build_loader( $caller, @_ );
26}
27
28sub _build_loader {
29 my $package = shift;
30 my %args = @_;
31
32 my @implementations = @{ $args{implementations} };
33 my @symbols = @{ $args{symbols} || [] };
34
35 my $implementation;
36 my $env_var = uc $package;
37 $env_var =~ s/::/_/g;
38 $env_var .= '_IMPLEMENTATION';
39
40 return sub {
41 my ( $implementation, $loaded ) = _load_implementation(
42 $package,
43 $ENV{$env_var},
44 \@implementations,
45 );
46
47 $Implementation{$package} = $implementation;
48
49 _copy_symbols( $loaded, $package, \@symbols );
50
51 return $loaded;
52 };
53}
54
55sub implementation_for {
56 my $package = shift;
57
58 return $Implementation{$package};
59}
60
61sub _load_implementation {
62 my $package = shift;
63 my $env_value = shift;
64 my $implementations = shift;
65
66 if ($env_value) {
67 die "$env_value is not a valid implementation for $package"
68 unless grep { $_ eq $env_value } @{$implementations};
69
70 my $requested = "${package}::$env_value";
71
72 # Values from the %ENV hash are tainted. We know it's safe to untaint
73 # this value because the value was one of our known implementations.
74 ($requested) = $requested =~ /^(.+)$/;
75
76 try {
77 require_module($requested);
78 }
79 catch {
80 require Carp;
81 Carp::croak("Could not load $requested: $_");
82 };
83
84 return ( $env_value, $requested );
85 }
86 else {
87 my $err;
88 for my $possible ( @{$implementations} ) {
89 my $try = "${package}::$possible";
90
91 my $ok;
92 try {
93 require_module($try);
94 $ok = 1;
95 }
96 catch {
97 $err .= $_ if defined $_;
98 };
99
100 return ( $possible, $try ) if $ok;
101 }
102
103 require Carp;
104 if ( defined $err && length $err ) {
105 Carp::croak(
106 "Could not find a suitable $package implementation: $err");
107 }
108 else {
109 Carp::croak(
110 'Module::Runtime failed to load a module but did not throw a real error. This should never happen. Something is very broken'
111 );
112 }
113 }
114}
115
116sub _copy_symbols {
117 my $from_package = shift;
118 my $to_package = shift;
119 my $symbols = shift;
120
121 for my $sym ( @{$symbols} ) {
122 my $type = $sym =~ s/^([\$\@\%\&\*])// ? $1 : '&';
123
124 my $from = "${from_package}::$sym";
125 my $to = "${to_package}::$sym";
126
127 {
128 no strict 'refs';
129 no warnings 'once';
130
131 # Copied from Exporter
132 *{$to}
133 = $type eq '&' ? \&{$from}
134 : $type eq '$' ? \${$from}
135 : $type eq '@' ? \@{$from}
136 : $type eq '%' ? \%{$from}
137 : $type eq '*' ? *{$from}
138 : die
139 "Can't copy symbol from $from_package to $to_package: $type$sym";
140 }
141 }
142}
143
1441;
145
146# ABSTRACT: Loads one of several alternate underlying implementations for a module
147
148__END__