← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 13:50:58 2016
Reported on Fri Jan 8 13:51:26 2016

Filename/usr/share/perl/5.20/base.pm
StatementsExecuted 0 statements in 1.01ms
Line State
ments
Time
on line
Calls Time
in subs
Code
1package base;
2
3use strict 'vars';
4use vars qw($VERSION);
5$VERSION = '2.22';
6$VERSION = eval $VERSION;
7
8# constant.pm is slow
9sub SUCCESS () { 1 }
10
11sub PUBLIC () { 2**0 }
12sub PRIVATE () { 2**1 }
13sub INHERITED () { 2**2 }
14sub PROTECTED () { 2**3 }
15
16my $Fattr = \%fields::attr;
17
18sub has_fields {
19 my($base) = shift;
20 my $fglob = ${"$base\::"}{FIELDS};
21 return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
22}
23
24sub has_attr {
25 my($proto) = shift;
26 my($class) = ref $proto || $proto;
27 return exists $Fattr->{$class};
28}
29
30sub get_attr {
31 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
32 return $Fattr->{$_[0]};
33}
34
35if ($] < 5.009) {
36 *get_fields = sub {
37 # Shut up a possible typo warning.
38 () = \%{$_[0].'::FIELDS'};
39 my $f = \%{$_[0].'::FIELDS'};
40
41 # should be centralized in fields? perhaps
42 # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
43 # is used here anyway, it doesn't matter.
44 bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
45
46 return $f;
47 }
48}
49else {
50 *get_fields = sub {
51 # Shut up a possible typo warning.
52 () = \%{$_[0].'::FIELDS'};
53 return \%{$_[0].'::FIELDS'};
54 }
55}
56
57if ($] < 5.008) {
58 *_module_to_filename = sub {
59 (my $fn = $_[0]) =~ s!::!/!g;
60 $fn .= '.pm';
61 return $fn;
62 }
63}
64else {
65 *_module_to_filename = sub {
66 (my $fn = $_[0]) =~ s!::!/!g;
67 $fn .= '.pm';
68 utf8::encode($fn);
69 return $fn;
70 }
71}
72
73sub import {
74 my $class = shift;
75
76 return SUCCESS unless @_;
77
78 # List of base classes from which we will inherit %FIELDS.
79 my $fields_base;
80
81 my $inheritor = caller(0);
82
83 my @bases;
84 foreach my $base (@_) {
85 if ( $inheritor eq $base ) {
86 warn "Class '$inheritor' tried to inherit from itself\n";
87 }
88
89 next if grep $_->isa($base), ($inheritor, @bases);
90
91 # Following blocks help isolate $SIG{__DIE__} changes
92 {
93 my $sigdie;
94 {
95 local $SIG{__DIE__};
96 my $fn = _module_to_filename($base);
9711.01ms eval { require $fn };
98 # Only ignore "Can't locate" errors from our eval require.
99 # Other fatal errors (syntax etc) must be reported.
100 #
101 # changing the check here is fragile - if the check
102 # here isn't catching every error you want, you should
103 # probably be using parent.pm, which doesn't try to
104 # guess whether require is needed or failed,
105 # see [perl #118561]
106 die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
107 || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
108 unless (%{"$base\::"}) {
109 require Carp;
110 local $" = " ";
111 Carp::croak(<<ERROR);
112Base class package "$base" is empty.
113 (Perhaps you need to 'use' the module which defines that package first,
114 or make that module available in \@INC (\@INC contains: @INC).
115ERROR
116 }
117 $sigdie = $SIG{__DIE__} || undef;
118 }
119 # Make sure a global $SIG{__DIE__} makes it out of the localization.
120 $SIG{__DIE__} = $sigdie if defined $sigdie;
121 }
122 push @bases, $base;
123
124 if ( has_fields($base) || has_attr($base) ) {
125 # No multiple fields inheritance *suck*
126 if ($fields_base) {
127 require Carp;
128 Carp::croak("Can't multiply inherit fields");
129 } else {
130 $fields_base = $base;
131 }
132 }
133 }
134 # Save this until the end so it's all or nothing if the above loop croaks.
135 push @{"$inheritor\::ISA"}, @bases;
136
137 if( defined $fields_base ) {
138 inherit_fields($inheritor, $fields_base);
139 }
140}
141
142sub inherit_fields {
143 my($derived, $base) = @_;
144
145 return SUCCESS unless $base;
146
147 my $battr = get_attr($base);
148 my $dattr = get_attr($derived);
149 my $dfields = get_fields($derived);
150 my $bfields = get_fields($base);
151
152 $dattr->[0] = @$battr;
153
154 if( keys %$dfields ) {
155 warn <<"END";
156$derived is inheriting from $base but already has its own fields!
157This will cause problems. Be sure you use base BEFORE declaring fields.
158END
159
160 }
161
162 # Iterate through the base's fields adding all the non-private
163 # ones to the derived class. Hang on to the original attribute
164 # (Public, Private, etc...) and add Inherited.
165 # This is all too complicated to do efficiently with add_fields().
166 while (my($k,$v) = each %$bfields) {
167 my $fno;
168 if ($fno = $dfields->{$k} and $fno != $v) {
169 require Carp;
170 Carp::croak ("Inherited fields can't override existing fields");
171 }
172
173 if( $battr->[$v] & PRIVATE ) {
174 $dattr->[$v] = PRIVATE | INHERITED;
175 }
176 else {
177 $dattr->[$v] = INHERITED | $battr->[$v];
178 $dfields->{$k} = $v;
179 }
180 }
181
182 foreach my $idx (1..$#{$battr}) {
183 next if defined $dattr->[$idx];
184 $dattr->[$idx] = $battr->[$idx] & INHERITED;
185 }
186}
187
1881;
189
190__END__
191