← 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 14:16:49 2016
Reported on Fri Jan 8 14:23:06 2016

Filename/usr/share/perl5/CGI/Compile.pm
StatementsExecuted 0 statements in 150µs
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package CGI::Compile;
2
3use strict;
4use 5.008_001;
5
6# this helper function is placed at the top of the file to
7# hide variables in this file from the generated sub.
8sub _eval {
9 no strict;
10 no warnings;
11
12 eval $_[0];
13}
14
15our $VERSION = '0.17';
16
17use Cwd;
18use File::Basename;
19use File::Spec::Functions;
20use File::pushd;
21
22our $RETURN_EXIT_VAL = undef;
23
24sub new {
25 my ($class, %opts) = @_;
26
27 $opts{namespace_root} ||= 'CGI::Compile::ROOT';
28
29 bless \%opts, $class;
30}
31
32our $USE_REAL_EXIT;
33BEGIN {
34 $USE_REAL_EXIT = 1;
35
36 my $orig = *CORE::GLOBAL::exit{CODE};
37
38 my $proto = $orig ? prototype $orig : prototype 'CORE::exit';
39
40 $proto = $proto ? "($proto)" : '';
41
42 $orig ||= sub {
43 my $exit_code = shift;
44
45 CORE::exit(defined $exit_code ? $exit_code : 0);
46 };
47
48 no warnings 'redefine';
49
50 *CORE::GLOBAL::exit = eval qq{
51 sub $proto {
52 my \$exit_code = shift;
53
54 \$orig->(\$exit_code) if \$USE_REAL_EXIT;
55
56 die [ "EXIT\n", \$exit_code || 0 ]
57 };
58 };
59 die $@ if $@;
60}
61
62sub compile {
63 my($class, $script, $package) = @_;
64
65 my $self = ref $class ? $class : $class->new;
66
67 my($code, $path, $dir);
68 if (ref $script eq 'SCALAR') {
69 $code = $$script;
70 } else {
71 $code = $self->_read_source($script);
72 $path = Cwd::abs_path($script);
73 $dir = File::Basename::dirname($path);
74 }
75
76 $package ||= $self->_build_package($path || $script);
77
78 my $warnings = $code =~ /^#!.*\s-w\b/ ? 1 : 0;
79 $code =~ s/^__END__\r?\n.*//ms;
80 $code =~ s/^__DATA__\r?\n(.*)//ms;
81 my $data = $1;
82
83 # TODO handle nph and command line switches?
84 my $eval = join '',
85 "package $package;",
86 "sub {",
87 'local $CGI::Compile::USE_REAL_EXIT = 0;',
88 "\nCGI::initialize_globals() if defined &CGI::initialize_globals;",
89 'local ($0, $CGI::Compile::_dir, *DATA);',
90 '{ my ($data, $path, $dir) = @_[1..3];',
91 ($path ? '$0 = $path;' : ''),
92 ($dir ? '$CGI::Compile::_dir = File::pushd::pushd $dir;' : ''),
93 q{open DATA, '<', \$data;},
94 '}',
95 # NOTE: this is a workaround to fix a problem in Perl 5.10
96 q(local @SIG{keys %SIG} = do { no warnings 'uninitialized'; @{[]} = values %SIG };),
97 "local \$^W = $warnings;",
98 'my $rv = eval {',
99 'local @ARGV = @{ $_[4] };', # args to @ARGV
100 'local @_ = @{ $_[4] };', # args to @_ as well
101 ($path ? "\n#line 1 $path\n" : ''),
102 $code,
103 "\n};",
104 q{
105 my $self = shift;
106 my $exit_val = unpack('C', pack('C', sprintf('%.0f', $rv)));
107 if ($@) {
108 die $@ unless (
109 ref($@) eq 'ARRAY' and
110 $@->[0] eq "EXIT\n"
111 );
112 my $exit_param = unpack('C', pack('C', sprintf('%.0f', $@->[1])));
113
114 if ($exit_param != 0 && !$CGI::Compile::RETURN_EXIT_VAL && !$self->{return_exit_val}) {
115 die "exited nonzero: $exit_param";
116 }
117
118 $exit_val = $exit_param;
119 }
120
121 return $exit_val;
122 },
123 '};';
124
125
126 my $sub = do {
127 no warnings 'uninitialized'; # for 5.8
128 # NOTE: this is a workaround to fix a problem in Perl 5.10
129 local @SIG{keys %SIG} = @{[]} = values %SIG;
130 local $USE_REAL_EXIT = 0;
131
132 my $code = _eval $eval;
133 my $exception = $@;
134
135 die "Could not compile $script: $exception" if $exception;
136
137 sub {
138 my @args = @_;
1391150µs398µs $code->($self, $data, $path, $dir, \@args)
# spent 98µs making 3 calls to File::pushd::DESTROY, avg 33µs/call
140 };
141 };
142
143 return $sub;
144}
145
146sub _read_source {
147 my($self, $file) = @_;
148
149 open my $fh, "<", $file or die "$file: $!";
150 return do { local $/; <$fh> };
151}
152
153sub _build_package {
154 my($self, $path) = @_;
155
156 my ($volume, $dirs, $file) = File::Spec::Functions::splitpath($path);
157 my @dirs = File::Spec::Functions::splitdir($dirs);
158 my $package = join '_', grep { defined && length } $volume, @dirs, $file;
159
160 # Escape everything into valid perl identifiers
161 $package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
162
163 # make sure that the sub-package doesn't start with a digit
164 $package =~ s/^(\d)/_$1/;
165
166 $package = $self->{namespace_root} . "::$package";
167 return $package;
168}
169
1701;
171
172__END__
173
174=encoding utf-8
175
176=for stopwords
177
178=head1 NAME
179
180CGI::Compile - Compile .cgi scripts to a code reference like ModPerl::Registry
181
182=head1 SYNOPSIS
183
184 use CGI::Compile;
185 my $sub = CGI::Compile->compile("/path/to/script.cgi");
186
187=head1 DESCRIPTION
188
189CGI::Compile is an utility to compile CGI scripts into a code
190reference that can run many times on its own namespace, as long as the
191script is ready to run on a persistent environment.
192
193B<NOTE:> for best results, load L<CGI::Compile> before any modules used by your
194CGIs.
195
196=head1 RUN ON PSGI
197
198Combined with L<CGI::Emulate::PSGI>, your CGI script can be turned
199into a persistent PSGI application like:
200
201 use CGI::Emulate::PSGI;
202 use CGI::Compile;
203
204 my $cgi_script = "/path/to/foo.cgi";
205 my $sub = CGI::Compile->compile($cgi_script);
206 my $app = CGI::Emulate::PSGI->handler($sub);
207
208 # $app is a PSGI application
209
210=head1 CAVEATS
211
212If your CGI script has a subroutine that references the lexical scope
213variable outside the subroutine, you'll see warnings such as:
214
215 Variable "$q" is not available at ...
216 Variable "$counter" will not stay shared at ...
217
218This is due to the way this module compiles the whole script into a
219big C<sub>. To solve this, you have to update your code to pass around
220the lexical variables, or replace C<my> with C<our>. See also
221L<http://perl.apache.org/docs/1.0/guide/porting.html#The_First_Mystery>
222for more details.
223
224=head1 METHODS
225
226=head2 new
227
228Does not need to be called, you only need to call it if you want to set your
229own C<namespace_root> for the generated packages into which the CGIs are
230compiled into.
231
232Otherwise you can just call L</compile> as a class method and the object will
233be instantiated with a C<namespace_root> of C<CGI::Compile::ROOT>.
234
235You can also set C<return_exit_val>, see L</RETURN CODE> for details.
236
237Example:
238
239 my $compiler = CGI::Compile->new(namespace_root => 'My::CGIs');
240 my $cgi = $compiler->compile('/var/www/cgi-bin/my.cgi');
241
242=head2 compile
243
244Takes either a path to a perl CGI script or a source code and some
245other optional parameters and wraps it into a coderef for execution.
246
247Can be called as either a class or instance method, see L</new> above.
248
249Parameters:
250
251=over 4
252
253=item * C<$cgi_script>
254
255Path to perl CGI script file or a scalar reference that contains the
256source code of CGI script, required.
257
258=item * C<$package>
259
260Optional, package to install the script into, defaults to the path parts of the
261script joined with C<_>, and all special characters converted to C<_%2x>,
262prepended with C<CGI::Compile::ROOT::>.
263
264E.g.:
265
266 /var/www/cgi-bin/foo.cgi
267
268becomes:
269
270 CGI::Compile::ROOT::var_www_cgi_2dbin_foo_2ecgi
271
272=back
273
274Returns:
275
276=over 4
277
278=item * C<$coderef>
279
280C<$cgi_script> or C<$$code> compiled to coderef.
281
282=back
283
284=head1 SCRIPT ENVIRONMENT
285
286=head2 ARGUMENTS
287
288Things like the query string and form data should generally be in the
289appropriate environment variables that things like L<CGI> expect.
290
291You can also pass arguments to the generated coderef, they will be
292locally aliased to C<@_> and C<@ARGV>.
293
294=head2 C<BEGIN> and C<END> blocks
295
296C<BEGIN> blocks are called once when the script is compiled.
297C<END> blocks are called when the Perl interpreter is unloaded.
298
299This may cause surprising effects. Suppose, for instance, a script that runs
300in a forking web server and is loaded in the parent process. C<END>
301blocks will be called once for each worker process and another time
302for the parent process while C<BEGIN> blocks are called only by the
303parent process.
304
305=head2 C<%SIG>
306
307The C<%SIG> hash is preserved meaning the script can change signal
308handlers at will. The next invocation gets a pristine C<%SIG> again.
309
310=head2 C<exit> and exceptions
311
312Calls to C<exit> are intercepted and converted into exceptions. When
313the script calls C<exit 19> and exception is thrown and C<$@> contains
314a reference pointing to the array
315
316 ["EXIT\n", 19]
317
318Naturally, L<perlvar/$^S> (exceptions being caught) is always C<true>
319during script runtime.
320
321If you really want to exit the process call C<CORE::exit> or set
322C<$CGI::Compile::USE_REAL_EXIT> to true before calling exit:
323
324 $CGI::Compile::USE_REAL_EXIT = 1;
325 exit 19;
326
327Other exceptions are propagated out of the generated coderef. The coderef's
328caller is responsible to catch them or the process will exit.
329
330=head2 Return Code
331
332The generated coderef's exit value is either the parameter that was
333passed to C<exit> or the value of the last statement of the script. The
334return code is converted into an integer.
335
336On a C<0> exit, the coderef will return C<0>.
337
338On an explicit non-zero exit, by default an exception will be thrown of
339the form:
340
341 exited nonzero: <n>
342
343where C<n> is the exit value.
344
345This only happens for an actual call to L<perfunc/exit>, not if the last
346statement value is non-zero, which will just be returned from the
347coderef.
348
349If you would prefer that explicit non-zero exit values are returned,
350rather than thrown, pass:
351
352 return_exit_val => 1
353
354in your call to L</new>.
355
356Alternately, you can change this behavior globally by setting:
357
358 $CGI::Compile::RETURN_EXIT_VAL = 1;
359
360=head2 Current Working Directory
361
362If C<< CGI::Compile->compile >> was passed a script file, the script's
363directory becomes the current working directory during the runtime of
364the script.
365
366NOTE: to be able to switch back to the original directory, the compiled
367coderef must establish the current working directory. This operation may
368cause an additional flush operation on file handles.
369
370=head2 C<STDIN> and C<STDOUT>
371
372These file handles are not touched by C<CGI::Compile>.
373
374=head2 The C<DATA> file handle
375
376If the script reads from the C<DATA> file handle, it reads the C<__DATA__>
377section provided by the script just as a normal script would do. Note,
378however, that the file handle is a memory handle. So, C<fileno DATA> will
379return C<-1>.
380
381=head2 CGI.pm integration
382
383If the subroutine C<CGI::initialize_globals> is defined at script runtime,
384it is called first thing by the compiled coderef.
385
386=head1 AUTHOR
387
388Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
389
390=head1 CONTRIBUTORS
391
392Rafael Kitover E<lt>rkitover@cpan.orgE<gt>
393
394Hans Dieter Pearcey E<lt>hdp@cpan.orgE<gt>
395
396kocoureasy E<lt>igor.bujna@post.czE<gt>
397
398Torsten Förtsch E<lt>torsten.foertsch@gmx.netE<gt>
399
400=head1 COPYRIGHT & LICENSE
401
402Copyright (c) 2009 Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
403
404This library is free software; you can redistribute it and/or modify
405it under the same terms as Perl itself.
406
407=head1 SEE ALSO
408
409L<ModPerl::RegistryCooker> L<CGI::Emulate::PSGI>
410
411=cut
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.