X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FController%2FCGIBin.pm;h=cc5218d36052a148384baed179b73ec5992824cb;hb=d5ba2ab2046dc314890bc7d3c2f9185f605d9f85;hp=0d6ff4092f44b7ef1cf7459608b994a4cbf67903;hpb=8ccf44c7f2a05a4694da99f075fc5334e2b76e99;p=catagits%2FCatalyst-Controller-WrapCGI.git diff --git a/lib/Catalyst/Controller/CGIBin.pm b/lib/Catalyst/Controller/CGIBin.pm index 0d6ff40..cc5218d 100644 --- a/lib/Catalyst/Controller/CGIBin.pm +++ b/lib/Catalyst/Controller/CGIBin.pm @@ -13,8 +13,10 @@ use IPC::Open3; use Symbol 'gensym'; use List::MoreUtils 'any'; use IO::File (); -use Carp; - +use File::Temp 'tempfile'; +use File::pushd; +#use CGI::Compile; + use namespace::clean -except => 'meta'; =head1 NAME @@ -23,11 +25,11 @@ Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin =head1 VERSION -Version 0.011 +Version 0.023 =cut -our $VERSION = '0.011'; +our $VERSION = '0.023'; =head1 SYNOPSIS @@ -37,12 +39,6 @@ In your controller: use parent qw/Catalyst::Controller::CGIBin/; - # example of a forward to /cgi-bin/hlagh/mtfnpy.cgi - sub serve_cgi : Local Args(0) { - my ($self, $c) = @_; - $c->forward($self->cgi_action('hlagh/mtfnpy.cgi')); - } - In your .conf: @@ -154,35 +150,25 @@ sub register_actions { =head2 cgi_action -C<<$self->cgi_action($cgi)>> +C<< $self->cgi_action($cgi) >> Takes a path to a CGI from C such as C and returns -the action name it is registered as. See L for a discussion on how -CGI actions are named. - -A path such as C will get the private path -C, for controller Foo, with the Cs converted to C<__> -and prepended with C, as well as all non-word characters converted to -C<_>s. This is because L action names can't have non-word characters -in them. - -This means that C and C for example will both map to -the action C so B. +the action name it is registered as. =cut sub cgi_action { my ($self, $cgi) = @_; - my $action_name = 'CGI_' . join '__' => split '/' => $cgi; - $action_name =~ s/\W/_/g; + my $action_name = 'CGI_' . $cgi; + $action_name =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg; - $action_name + return $action_name; } =head2 cgi_path -C<<$self->cgi_path($cgi)>> +C<< $self->cgi_path($cgi) >> Takes a path to a CGI from C such as C and returns the public path it should be registered under. @@ -202,7 +188,7 @@ sub cgi_path { =head2 is_perl_cgi -C<<$self->is_perl_cgi($path)>> +C<< $self->is_perl_cgi($path) >> Tries to figure out whether the CGI is Perl or not. @@ -214,23 +200,35 @@ L. sub is_perl_cgi { my ($self, $cgi) = @_; - my $shebang = IO::File->new($cgi)->getline; + my (undef, $tempfile) = tempfile; - return 0 if $shebang !~ /perl/ && $cgi !~ /\.pl\z/; + my $pid = fork; + die "Cannot fork: $!" unless defined $pid; - my $taint_check = $shebang =~ /-T/ ? '-T' : ''; + if ($pid) { + waitpid $pid, 0; + my $errors = IO::File->new($tempfile)->getline; + unlink $tempfile; + return $errors ? 0 : 1; + } + # child + local *NULL; open NULL, '>', File::Spec->devnull; - my $pid = open3(gensym, '&>NULL', '&>NULL', "$^X $taint_check -c $cgi"); - close NULL; - waitpid $pid, 0; + open STDOUT, '>&', \*NULL; + open STDERR, '>&', \*NULL; + close STDIN; + + eval { $self->wrap_perl_cgi($cgi, '__DUMMY__') }; - $? >> 8 == 0 + IO::File->new(">$tempfile")->print($@); + + exit; } =head2 wrap_perl_cgi -C<<$self->wrap_perl_cgi($path, $action_name)>> +C<< $self->wrap_perl_cgi($path, $action_name) >> Takes the path to a Perl CGI and returns a coderef suitable for passing to cgi_to_response (from L.) @@ -251,10 +249,14 @@ sub wrap_perl_cgi { my ($self, $cgi, $action_name) = @_; my $code = slurp $cgi; + my $dir = File::Basename::dirname($cgi); - $code =~ s/^__DATA__(?:\r?\n|\r\n?)(.*)//ms; + $code =~ s/^__DATA__\n(.*)//ms; my $data = $1; + my $orig_exit = \*CORE::GLOBAL::exit; + my %orig_sig = %SIG; + my $coderef = do { no warnings; # catch exit() and turn it into (effectively) a return @@ -262,18 +264,23 @@ sub wrap_perl_cgi { # overridden CORE::GLOBAL::exit in view # # set $0 to the name of the cgi file in case it's used there - eval ' + my $source = ' my $cgi_exited = "EXIT\n"; BEGIN { *CORE::GLOBAL::exit = sub (;$) { die [ $cgi_exited, $_[0] || 0 ]; } } package Catalyst::Controller::CGIBin::_CGIs_::'.$action_name.'; - sub {' - . 'local *DATA;' - . q{open DATA, '<', \$data;} - . qq{local \$0 = "\Q$cgi\E";} - . q/my $rv = eval {/ - . $code + sub {'."\n" + . 'local *DATA;'."\n" + . q{open DATA, '<', \$data;}."\n" + . qq{local \$0 = '$cgi';}."\n" + . "my \$_dir = File::pushd::pushd '$dir';"."\n" + . "CGI::initialize_globals() "."\n" + . " if defined &CGI::initialize_globals;"."\n" + . q/my $rv = eval {/."\n" + . 'local %SIG;'."\n" + . "#line 1 $cgi"."\n" + . $code."\n" . q/};/ . q{ return $rv unless $@; @@ -285,16 +292,30 @@ sub wrap_perl_cgi { return $rv; } . '}'; + eval $source; }; - croak __PACKAGE__ . ": Could not compile $cgi to coderef: $@" if $@; + # clean up + *CORE::GLOBAL::exit = $orig_exit; + %SIG = %orig_sig; - $coderef + die "Could not compile $cgi to coderef: $@" if $@; + + return $coderef; } +# Once CGI::Compile is updated, we can use this: + +#sub wrap_perl_cgi { +# my ($self, $cgi, $action_name) = @_; +# +# return CGI::Compile->compile($cgi, +# "Catalyst::Controller::CGIBin::_CGIs_::$action_name"); +#} + =head2 wrap_nonperl_cgi -C<<$self->wrap_nonperl_cgi($path, $action_name)>> +C<< $self->wrap_nonperl_cgi($path, $action_name) >> Takes the path to a non-Perl CGI and returns a coderef for executing it. @@ -317,13 +338,7 @@ __PACKAGE__->meta->make_immutable; =head1 SEE ALSO L, L, -L, L, L - -=head1 AUTHORS - -Rafael Kitover, C<< >> - -Hans Dieter Pearcey, C<< >> +L, L, L, L =head1 BUGS @@ -357,9 +372,15 @@ L =back +=head1 AUTHOR + +See L and +L. + =head1 COPYRIGHT & LICENSE -Copyright (c) 2008 Rafael Kitover +Copyright (c) 2008-2009 L and +L. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.