Commit | Line | Data |
32b32c62 |
1 | package Catalyst::Plugin::CGIBin; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
457c1d76 |
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 | |
32b32c62 |
13 | =head1 NAME |
14 | |
457c1d76 |
15 | Catalyst::Plugin::CGIBin - Serve CGIs from root/cgi-bin |
32b32c62 |
16 | |
17 | =head1 VERSION |
18 | |
19 | Version 0.001 |
20 | |
21 | =cut |
22 | |
23 | our $VERSION = '0.001'; |
24 | |
32b32c62 |
25 | =head1 SYNOPSIS |
26 | |
457c1d76 |
27 | In MyApp.pm: |
28 | |
29 | use Catalyst; |
30 | |
31 | __PACKAGE__->setup(qw/CGIBin/); |
32 | |
32b32c62 |
33 | In your .conf: |
457c1d76 |
34 | |
32b32c62 |
35 | <Plugin::CGIBin> |
457c1d76 |
36 | controller Foo |
32b32c62 |
37 | </Plugin::CGIBin> |
38 | |
457c1d76 |
39 | <Controller::Foo> |
32b32c62 |
40 | <CGI> |
41 | pass_env PERL5LIB |
42 | pass_env PATH |
43 | </CGI> |
457c1d76 |
44 | </Controller::Foo> |
32b32c62 |
45 | |
46 | =head1 DESCRIPTION |
47 | |
457c1d76 |
48 | Dispatches to executable CGI files in root/cgi-bin through the configured |
49 | controller, which must inherit from L<Catalyst::Controller::WrapCGI>. |
32b32c62 |
50 | |
51 | =cut |
52 | |
457c1d76 |
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 | |
32b32c62 |
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: |