lib/Catalyst/Plugin/CGIBin.pm

   1 package Catalyst::Plugin::CGIBin;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::C3;
   7 use URI::Escape;
   8 use File::Slurp 'slurp';
   9 use File::Find::Rule ();
  10 use Cwd;
  11 use Catalyst::Exception ();
  12
  13 =head1 NAME
  14
  15 Catalyst::Plugin::CGIBin - Serve CGIs from root/cgi-bin
  16
  17 =head1 VERSION
  18
  19 Version 0.001
  20
  21 =cut
  22
  23 our $VERSION = '0.001';
  24
  25 =head1 SYNOPSIS
  26
  27 In MyApp.pm:
  28
  29     use Catalyst;
  30
  31     __PACKAGE__->setup(qw/CGIBin/);
  32
  33 In your .conf:
  34
  35     <Plugin::CGIBin>
  36         controller Foo
  37     </Plugin::CGIBin>
  38
  39     <Controller::Foo>
  40         <CGI>
  41             pass_env PERL5LIB
  42             pass_env PATH
  43         </CGI>
  44     </Controller::Foo>
  45
  46 =head1 DESCRIPTION
  47
  48 Dispatches to executable CGI files in root/cgi-bin through the configured
  49 controller, which must inherit from L<Catalyst::Controller::WrapCGI>.
  50
  51 =cut
  52
  53 my ($cgi_controller, $cgis);
  54
  55 sub setup {
  56     my $app = shift;
  57
  58     my $cwd = getcwd;
  59
  60     my $cgi_bin = $app->path_to('root', 'cgi-bin');
  61
  62     chdir $cgi_bin ||
  63         Catalyst::Exception->throw(
  64             message => 'You have no root/cgi-bin directory'
  65         );
  66
  67     $cgi_controller = $app->config->{'Plugin::CGIBin'}{controller} ||
  68         Catalyst::Exception->throw(
  69             message => 'You must configure a controller for Plugin::CGIBin'
  70         );
  71
  72     for my $cgi (File::Find::Rule->executable->file->in(".")) {
  73         my $code = do { no warnings; eval 'sub { '.slurp($cgi).' }' };
  74         if (!$@) { # Perl source
  75             $cgis->{$cgi} = $code;
  76             undef $@;
  77         } else { # some other type of executable
  78             $cgis->{$cgi} = sub { system "$cgi_bin/$cgi" };
  79         }
  80     }
  81
  82     chdir $cwd;
  83
  84     $app->next::method(@_);
  85 }
  86
  87 sub dispatch {
  88     my $c = shift;
  89     my $path = uri_unescape($c->req->path);
  90
  91     if ($path =~ m!^cgi-bin/(.*)!) {
  92         my $cgi = $cgis->{$1};
  93
  94         if ($cgi) {
  95             $c->controller($cgi_controller)->cgi_to_response(
  96                 $c, $cgi
  97             );
  98             return;
  99         }
 100     }
 101
 102     $c->next::method(@_);
 103 }
 104
 105 =head1 AUTHOR
 106
 107 Rafael Kitover, C<< <rkitover at cpan.org> >>
 108
 109 =head1 BUGS
 110
 111 Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
 112 rt.cpan.org>, or through the web interface at
 113 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
 114 I will be notified, and then you'll automatically be notified of progress on
 115 your bug as I make changes.
 116
 117 =head1 SUPPORT
 118
 119 More information at:
 120
 121 =over 4
 122
 123 =item * RT: CPAN's request tracker
 124
 125 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Controller-WrapCGI>
 126
 127 =item * AnnoCPAN: Annotated CPAN documentation
 128
 129 L<http://annocpan.org/dist/Catalyst-Controller-WrapCGI>
 130
 131 =item * CPAN Ratings
 132
 133 L<http://cpanratings.perl.org/d/Catalyst-Controller-WrapCGI>
 134
 135 =item * Search CPAN
 136
 137 L<http://search.cpan.org/dist/Catalyst-Controller-WrapCGI>
 138
 139 =back
 140
 141 =head1 COPYRIGHT & LICENSE
 142
 143 Copyright (c) 2008 Rafael Kitover
 144
 145 This program is free software; you can redistribute it and/or modify it
 146 under the same terms as Perl itself.
 147
 148 =cut
 149
 150 1; # End of Catalyst::Plugin::CGIBin
 151
 152 # vim: expandtab shiftwidth=4 ts=4 tw=80: