root/lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Interface/FCGI.pm @ 11766

Revision 11766, 4.2 kB (checked in by yappo, 6 years ago)

fcgi broken

Line 
1package HTTP::Engine::Interface::FCGI;
2use Moose;
3with 'HTTP::Engine::Role::Interface';
4use constant should_write_response_line => 0;
5use FCGI;
6use UNIVERSAL::require;
7
8has leave_umask => (
9    is      => 'ro',
10    isa     => 'Bool',
11    default => 0,
12);
13
14has keep_stderr => (
15    is      => 'ro',
16    isa     => 'Bool',
17    default => 0,
18);
19
20has nointr => (
21    is      => 'ro',
22    isa     => 'Bool',
23    default => 0,
24);
25
26has detach => (
27    is      => 'ro',
28    isa     => 'Bool',
29    default => 0,
30);
31
32has manager => (
33    is      => 'ro',
34    isa     => 'Str',
35    default => "FCGI::ProcManager",
36);
37
38has nproc => (
39    is      => 'ro',
40    isa     => 'Int',
41    default => 1,
42);
43
44has pidfile => (
45    is      => 'ro',
46    isa     => 'Str',
47);
48
49has listen => (
50    is  => 'ro',
51    isa => 'Str',
52);
53
54sub run {
55    my ( $self, ) = @_;
56
57    my $sock = 0;
58    if ($self->listen) {
59        my $old_umask = umask;
60        unless ( $self->leave_umask ) {
61            umask(0);
62        }
63        $sock = FCGI::OpenSocket( $self->listen, 100 )
64          or die "failed to open FastCGI socket; $!";
65        unless ( $self->leave_umask ) {
66            umask($old_umask);
67        }
68    }
69    elsif ( $^O ne 'MSWin32' ) {
70        -S STDIN
71          or die "STDIN is not a socket; specify a listen location";
72    }
73
74    my %env;
75    my $error = \*STDERR;    # send STDERR to the web server
76    $error = \*STDOUT                # send STDERR to stdout (a logfile)
77      if $self->keep_stderr;         # (if asked to)
78
79    my $request =
80      FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock,
81        ( $self->nointr ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ),
82      );
83
84    my $proc_manager;
85
86    if ($self->listen) {
87        $self->daemon_fork() if $self->detach;
88
89        if ( $self->manager ) {
90            $self->manager->use or die $@;
91            $proc_manager = $self->manager->new(
92                {
93                    n_processes => $self->nproc,
94                    pid_fname   => $self->pidfile,
95                }
96            );
97
98            # detach *before* the ProcManager inits
99            $self->daemon_detach() if $self->detach;
100
101            $proc_manager->pm_manage();
102        }
103        elsif ( $self->detach ) {
104            $self->daemon_detach();
105        }
106    }
107
108    while ( $request->Accept >= 0 ) {
109        $proc_manager && $proc_manager->pm_pre_dispatch();
110
111        # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
112        # http://lists.rawmode.org/pipermail/catalyst/2006-June/008361.html
113        # Thanks to Mark Blythe for this fix
114        if ( $env{SERVER_SOFTWARE} && $env{SERVER_SOFTWARE} =~ /lighttpd/ ) {
115            $env{PATH_INFO} ||= delete $env{SCRIPT_NAME};
116        }
117
118        local %ENV = %env;
119        $self->handle_request();
120
121        $proc_manager && $proc_manager->pm_post_dispatch();
122    }
123}
124
125sub daemon_fork {
126    require POSIX;
127    fork && exit;
128}
129
130sub daemon_detach {
131    my $self = shift;
132    print "FastCGI daemon started (pid $$)\n";
133    open STDIN,  "+</dev/null" or die $!; ## no critic
134    open STDOUT, ">&STDIN"     or die $!;
135    open STDERR, ">&STDIN"     or die $!;
136    POSIX::setsid();
137}
138
139
140use HTTP::Engine::ResponseWriter;
141HTTP::Engine::ResponseWriter->meta->add_method( write => sub {
142    my($self, $buffer) = @_;
143
144    unless ( $self->{_prepared_write} ) {
145        $self->prepare_write;
146        $self->{_prepared_write} = 1;
147    }
148
149    # XXX: We can't use Engine's write() method because syswrite
150    # appears to return bogus values instead of the number of bytes
151    # written: http://www.fastcgi.com/om_archive/mail-archive/0128.html
152
153    # FastCGI does not stream data properly if using 'print $handle',
154    # but a syswrite appears to work properly.
155    *STDOUT->syswrite($buffer);
156});
157
1581;
159__END__
160
161=for stopwords nointr pidfile nproc
162
163=head1 NAME
164
165HTTP::Engine::Interface::FCGI - FastCGI interface for HTTP::Engine
166
167=head1 SYNOPSIS
168
169    HTTP::Engine::Interface::FCGI->new(
170    );
171
172=head1 ATTRIBUTES
173
174=over 4
175
176=item leave_umask
177
178=item keep_stderr
179
180=item nointr
181
182=item detach
183
184=item manager
185
186=item nproc
187
188=item pidfile
189
190=item listen
191
192=back
193
194=head1 METHODS
195
196=over 4
197
198=item run
199
200internal use only
201
202=back
203
204
205=head1 AUTHORS
206
207Tokuhiro Matsuno
208
209=head1 THANKS TO
210
211many codes copied from L<Catalyst::Engine::FastCGI>. thanks authors of C::E::FastCGI!
212
Note: See TracBrowser for help on using the browser.