Profile of CGI/Compile.pm

Filename	/usr/share/perl5/CGI/Compile.pm
Statements	Executed 0 statements in 643µs

Line	State ments	Time on line	Calls	Time in subs	Code
1					package CGI::Compile;
2
3					use strict;
4					use 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.
8					sub _eval {
9					no strict;
10					no warnings;
11
12	1	505µs			eval $_[0]; # spent 512µs executing statements in string eval # includes 37µs spent executing 1 call to 1 sub defined therein. # spent 0s executing statements in string eval # includes 38µs spent executing 1 call to 1 sub defined therein.
13					}
14
15					our $VERSION = '0.17';
16
17					use Cwd;
18					use File::Basename;
19					use File::Spec::Functions;
20					use File::pushd;
21
22					our $RETURN_EXIT_VAL = undef;
23
24					sub new {
25					my ($class, %opts) = @_;
26
27					$opts{namespace_root} \|\|= 'CGI::Compile::ROOT';
28
29					bless \%opts, $class;
30					}
31
32					our $USE_REAL_EXIT;
33					BEGIN {
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
62					sub 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 = @_;
139	1	138µs	5	132µs	$code->($self, $data, $path, $dir, \@args) # spent 132µs making 5 calls to File::pushd::DESTROY, avg 26µs/call
140					};
141					};
142
143					return $sub;
144					}
145
146					sub _read_source {
147					my($self, $file) = @_;
148
149					open my $fh, "<", $file or die "$file: $!";
150					return do { local $/; <$fh> };
151					}
152
153					sub _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
170					1;
171
172					__END__
173
174					=encoding utf-8
175
176					=for stopwords
177
178					=head1 NAME
179
180					CGI::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
189					CGI::Compile is an utility to compile CGI scripts into a code
190					reference that can run many times on its own namespace, as long as the
191					script is ready to run on a persistent environment.
192
193					B<NOTE:> for best results, load L<CGI::Compile> before any modules used by your
194					CGIs.
195
196					=head1 RUN ON PSGI
197
198					Combined with L<CGI::Emulate::PSGI>, your CGI script can be turned
199					into 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
212					If your CGI script has a subroutine that references the lexical scope
213					variable 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
218					This is due to the way this module compiles the whole script into a
219					big C<sub>. To solve this, you have to update your code to pass around
220					the lexical variables, or replace C<my> with C<our>. See also
221					L<http://perl.apache.org/docs/1.0/guide/porting.html#The_First_Mystery>
222					for more details.
223
224					=head1 METHODS
225
226					=head2 new
227
228					Does not need to be called, you only need to call it if you want to set your
229					own C<namespace_root> for the generated packages into which the CGIs are
230					compiled into.
231
232					Otherwise you can just call L</compile> as a class method and the object will
233					be instantiated with a C<namespace_root> of C<CGI::Compile::ROOT>.
234
235					You can also set C<return_exit_val>, see L</RETURN CODE> for details.
236
237					Example:
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
244					Takes either a path to a perl CGI script or a source code and some
245					other optional parameters and wraps it into a coderef for execution.
246
247					Can be called as either a class or instance method, see L</new> above.
248
249					Parameters:
250
251					=over 4
252
253					=item * C<$cgi_script>
254
255					Path to perl CGI script file or a scalar reference that contains the
256					source code of CGI script, required.
257
258					=item * C<$package>
259
260					Optional, package to install the script into, defaults to the path parts of the
261					script joined with C<_>, and all special characters converted to C<_%2x>,
262					prepended with C<CGI::Compile::ROOT::>.
263
264					E.g.:
265
266					/var/www/cgi-bin/foo.cgi
267
268					becomes:
269
270					CGI::Compile::ROOT::var_www_cgi_2dbin_foo_2ecgi
271
272					=back
273
274					Returns:
275
276					=over 4
277
278					=item * C<$coderef>
279
280					C<$cgi_script> or C<$$code> compiled to coderef.
281
282					=back
283
284					=head1 SCRIPT ENVIRONMENT
285
286					=head2 ARGUMENTS
287
288					Things like the query string and form data should generally be in the
289					appropriate environment variables that things like L<CGI> expect.
290
291					You can also pass arguments to the generated coderef, they will be
292					locally aliased to C<@_> and C<@ARGV>.
293
294					=head2 C<BEGIN> and C<END> blocks
295
296					C<BEGIN> blocks are called once when the script is compiled.
297					C<END> blocks are called when the Perl interpreter is unloaded.
298
299					This may cause surprising effects. Suppose, for instance, a script that runs
300					in a forking web server and is loaded in the parent process. C<END>
301					blocks will be called once for each worker process and another time
302					for the parent process while C<BEGIN> blocks are called only by the
303					parent process.
304
305					=head2 C<%SIG>
306
307					The C<%SIG> hash is preserved meaning the script can change signal
308					handlers at will. The next invocation gets a pristine C<%SIG> again.
309
310					=head2 C<exit> and exceptions
311
312					Calls to C<exit> are intercepted and converted into exceptions. When
313					the script calls C<exit 19> and exception is thrown and C<$@> contains
314					a reference pointing to the array
315
316					["EXIT\n", 19]
317
318					Naturally, L<perlvar/$^S> (exceptions being caught) is always C<true>
319					during script runtime.
320
321					If you really want to exit the process call C<CORE::exit> or set
322					C<$CGI::Compile::USE_REAL_EXIT> to true before calling exit:
323
324					$CGI::Compile::USE_REAL_EXIT = 1;
325					exit 19;
326
327					Other exceptions are propagated out of the generated coderef. The coderef's
328					caller is responsible to catch them or the process will exit.
329
330					=head2 Return Code
331
332					The generated coderef's exit value is either the parameter that was
333					passed to C<exit> or the value of the last statement of the script. The
334					return code is converted into an integer.
335
336					On a C<0> exit, the coderef will return C<0>.
337
338					On an explicit non-zero exit, by default an exception will be thrown of
339					the form:
340
341					exited nonzero: <n>
342
343					where C<n> is the exit value.
344
345					This only happens for an actual call to L<perfunc/exit>, not if the last
346					statement value is non-zero, which will just be returned from the
347					coderef.
348
349					If you would prefer that explicit non-zero exit values are returned,
350					rather than thrown, pass:
351
352					return_exit_val => 1
353
354					in your call to L</new>.
355
356					Alternately, you can change this behavior globally by setting:
357
358					$CGI::Compile::RETURN_EXIT_VAL = 1;
359
360					=head2 Current Working Directory
361
362					If C<< CGI::Compile->compile >> was passed a script file, the script's
363					directory becomes the current working directory during the runtime of
364					the script.
365
366					NOTE: to be able to switch back to the original directory, the compiled
367					coderef must establish the current working directory. This operation may
368					cause an additional flush operation on file handles.
369
370					=head2 C<STDIN> and C<STDOUT>
371
372					These file handles are not touched by C<CGI::Compile>.
373
374					=head2 The C<DATA> file handle
375
376					If the script reads from the C<DATA> file handle, it reads the C<__DATA__>
377					section provided by the script just as a normal script would do. Note,
378					however, that the file handle is a memory handle. So, C<fileno DATA> will
379					return C<-1>.
380
381					=head2 CGI.pm integration
382
383					If the subroutine C<CGI::initialize_globals> is defined at script runtime,
384					it is called first thing by the compiled coderef.
385
386					=head1 AUTHOR
387
388					Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
389
390					=head1 CONTRIBUTORS
391
392					Rafael Kitover E<lt>rkitover@cpan.orgE<gt>
393
394					Hans Dieter Pearcey E<lt>hdp@cpan.orgE<gt>
395
396					kocoureasy E<lt>igor.bujna@post.czE<gt>
397
398					Torsten Förtsch E<lt>torsten.foertsch@gmx.netE<gt>
399
400					=head1 COPYRIGHT & LICENSE
401
402					Copyright (c) 2009 Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
403
404					This library is free software; you can redistribute it and/or modify
405					it under the same terms as Perl itself.
406
407					=head1 SEE ALSO
408
409					L<ModPerl::RegistryCooker> L<CGI::Emulate::PSGI>
410
411					=cut