—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
package HTTP::Server::EV::CGI;
use strict;
use bytes;
use Encode;
use Carp;
use Time::HiRes qw(gettimeofday tv_interval);
use Scalar::Util qw/weaken/;
no warnings;
use HTTP::Server::EV::Buffer;
use HTTP::Server::EV::BufTie;
our $VERSION = '0.66';
HideShow 63 lines of Pod
=head1 NAME
HTTP::Server::EV::CGI - Contains http request data and some extra functions.  
=head1 GETTING DATA
=over
         
To get headers and CGI compatible ENV vars use
=item $cgi->{ headers }{ header_name } = value
To get last parsed from form value use
=item $cgi->{ get }{ url_filed_name }
=item $cgi->{ cookies }{ cookie_name }
=item $cgi->{ post }{ form_filed_name } 
=item $cgi->{ file }{ form_file-filed_name } - L<HTTP::Server::EV::MultipartFile> object
=back
To get reference to array of all elements with same name ( selects, checkboxes, ...) use
=over
=item $cgi->get('filed_name')
=item $cgi->post('filed_name')
=item $cgi->file('filed_name')
=back
=over
=item $cgi->param('filed_name');
=back
Returns one or list of elements depending on call context. 
Prefers returning GET values if exists.
Never returns L<HTTP::Server::EV::MultipartFile> files, use $cgi->{ file }{ filed_name } or $cgi->file('filed_name')
All values are utf8 encoded
=head1 NON BLOCKING OUTPUT
$cgi->{buffer} = L<HTTP::Server::EV::Buffer> object
$cgi->buffer - returns non blocking filehandle tied to L<HTTP::Server::EV::Buffer> object
$cgi->attach(*STDOUT) - attaches STDOUT to socket makes it non blocking 
=head1 METHODS
=cut
our $cookies_lifetime = 3600*24*31;
#$cgi->new({ fd => sock fileno , post => {}, get => {} , headers => {} .... });
# new called only by HTTP::Server::EV 
sub new { # init all structures
        my($self) = @_;
         
        $self->start_timer;
         
        $self->{buffer} = HTTP::Server::EV::Buffer->new({ fd => $self->{fd} });
        $self->{stdout_guard} = [];
         
        ## Parse headers. CGI.pm compatible
        ( $self->{headers}{SCRIPT_NAME}, $self->{headers}{QUERY_STRING} ) =(split /\?/, $self->{headers}{REQUEST_URI});
         
        $self->{headers}{DOCUMENT_URI} = $self->{headers}{SCRIPT_NAME};
         
        $self->{headers}{REMOTE_ADDR} = $self->{headers}{'HTTP_X-REAL-IP'} if($HTTP::Server::EV::backend && $self->{headers}{'HTTP_X-REAL-IP'});
        $self->{headers}{CONTENT_TYPE} = $self->{headers}{'HTTP_CONTENT-TYPE'};
        $self->{headers}{CONTENT_LENGTH} = $self->{headers}{'HTTP_CONTENT-LENGTH'};
         
         
                ## Reading get vars # copy-paste is for microoptimization
                my @pairs = split(/[;&]/,$self->{headers}{QUERY_STRING},1024);
                foreach (@pairs) {
                        my ($name, $data) = split /=/, $self->urldecode($_);
                        Encode::_utf8_on($name);
                        Encode::_utf8_on($data);
                         
                        $self->{get}{$name} = $data;
                         
                        $self->{get_a}{$name}=[] unless $self->{get_a}{$name};
                        push @{$self->{get_a}{$name}},$data;
                }
                if($self->{REQUEST_BODY}){
                        my @pairs = split(/[;&]/,$self->{REQUEST_BODY},1024);
                        foreach (@pairs) {
                                my ($name, $data) = split /=/, $self->urldecode($_);
                                Encode::_utf8_on($name);
                                Encode::_utf8_on($data);
                         
                                $self->{post}{$name} = $data;
                                                 
                                $self->{post_a}{$name}=[] unless $self->{post_a}{$name};
                                push @{$self->{post_a}{$name}},$data;
                        }
                }       
                ## Reading cookies
                @pairs = split(/; /,$self->{headers}{HTTP_COOKIE},100);
                foreach (@pairs) {
                        my ($name, $data) = split /=/, $self->urldecode($_);
                        Encode::_utf8_on($name);
                        Encode::_utf8_on($data);
                         
                        $self->{cookies}{ $name } = $data;
                }
         
        ## Parse urlencoded post
         
         
        return $self;
}
HideShow 6 lines of Pod
=head2 $cgi->next
Drops port listener callback processing. Don`t use it somewhere except HTTP::Server::EV port listener callback or set goto label NEXT_REQ: 
=cut
sub next { $_[0]->{received} ? goto(NEXT_REQ) : $_[0]-> drop};
HideShow 6 lines of Pod
=head2 $cgi->fd
Returns file descriptor (int)
=cut
sub fd { $_[0]->{fd} }
HideShow 7 lines of Pod
=head2 $cgi->fh
Returns perl file handle attached to socket. 
Non buffered and blocking, use $cgi->{buffer}->print() or $cgi->buffer handle instead for sending data without attaching socket.
=cut
sub fh { 
        croak 'Can`t get fh of closed socket!' unless $_[0]->{buffer};
         
        $_[0]->{buffer}{fh}
}
HideShow 6 lines of Pod
=head2 $cgi->buffer
Returns handle tied to L<HTTP::Server::EV::Buffer> object. Writing to this handle buffered an non-blocking
=cut
sub buffer { 
        croak 'Can`t get buffered handle from closed socket!' unless $_[0]->{buffer};
         
        tie($_[0]->{buf_fh}, 'HTTP::Server::EV::Buffer', $_[0]->{buffer}) unless $_[0]->{buf_fh};
         
        return $_[0]->{buf_fh};
}
HideShow 19 lines of Pod
=head2 $cgi->attach(*FH)
Attaches client socket to FH.
Uses L<HTTP::Server::EV::BufTie> to support processing requests in L<Coro> threads when using L<Coro::EV>
Uses L<HTTP::Server::EV::Buffer> to provide non-blocking output.
        $server->listen( 8080 , sub {
                my $cgi = shift;
                 
                $cgi->attach(*STDOUT); # attach STDOUT to socket
                 
                $cgi->header; # print http headers
                 
                print "Test page"; 
        });
=cut
sub attach {
        croak 'Can`t attach closed socket!' unless $_[0]->{buffer};
         
        push @{$_[0]->{stdout_guard}}, HTTP::Server::EV::BufTie->new($_[1], $_[0]->{buffer});
}
HideShow 6 lines of Pod
=head2 $cgi->copy(*FH)
Attaches socket to handle but don`t uses L<HTTP::Server::EV::BufTie> magick and buffered L<HTTP::Server::EV::Buffer> otput.
=cut
sub copy {
        croak 'Can`t attach closed socket!' unless $_[0]->{buffer};
         
        open($_[1], '>&', $_[0]->{fd} ) or croak 'Can`t attach socket handle';
        binmode $_[1];
}
HideShow 6 lines of Pod
=head2 $cgi->print($data)
Buffered non-blocking print to socket. Same as $cgi->{buffer}->print or $cgi->buffer handle
=cut
sub print {shift->{buffer}->print(@_)};
HideShow 6 lines of Pod
=head2 $cgi->flush and $cgi->flush_wait
Same as $cgi->{buffer}->flush and $cgi->{buffer}->flush_wait
=cut
sub flush {$_[0]->{buffer}->flush($_[1])};
sub flush_wait {$_[0]->{buffer}->flush_wait($_[1])};
HideShow 6 lines of Pod
=head2 $cgi->close
Flush all buffered data and close received connection.
=cut
sub close { 
        delete $_[0]->{buffer}; # From 0.21 HTTP::Server::EV::Buffer closes socket
        $_[0]->{stdout_guard} = []; # close all attached handles
        #CORE::close $_[0]->{fh} ;
        #HTTP::Server::EV::close_socket( $_[0]->{fd} );
};
HideShow 10 lines of Pod
=head2 $cgi->start_timer
Initalize a page generation timer. Called automatically on every request
=head2 $cgi->flush_timer
Returns string like '0.12345' with page generation time 
=cut
### Page generation timer
sub start_timer { shift->{timer}=[gettimeofday] }; # start/reset timer
sub flush_timer { return tv_interval(shift->{timer}) }; # get generation time
### Get params as array refs. Ex: $cgi->post('checkboxes') - ['one','two']
sub get { return $_[0]->{get_a}{$_[1]} ? $_[0]->{get_a}{$_[1]} : [] ;}
sub post { return $_[0]->{post_a}{$_[1]} ? $_[0]->{post_a}{$_[1]} : [] ;}
sub file { return $_[0]->{file_a}{$_[1]} ? $_[0]->{file_a}{$_[1]} : [] ;}
sub param {
        if(wantarray){
                return( (@{$_[0]->{get_a}{$_[1]} || []}) ? @{$_[0]->{get_a}{$_[1]}}  : @{$_[0]->{post_a}{$_[1]} || []} );
        }else{
                return $_[0]->{get}{$_[1]} || $_[0]->{post}{$_[1]};
        }
}
HideShow 6 lines of Pod
=head2 $cgi->set_cookies({ name=> 'value', name2=> 'value2' }, $sec_lifetime );
Takes hashref with cookies as first argumet. Second(optional) argument is cookies lifetime in seconds(1 month by default)
=cut
sub set_cookies {
        my ($self,$cookies, $lifetime)=@_;
        my ($name,$value);
        my @days=qw(Sun Mon Tue Wed Thu Fri Sat);
        my @months=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
        my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime( time + ( defined($lifetime) ? $lifetime :  $HTTP::Server::EV::CGI::cookies_lifetime ) );
        my $date = sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",$days[$wday],$mday,$months[$mon],$year+1900,$hour,$min,$sec);
        $self->{cookiesbuffer}.="Set-Cookie: $name=$value; path=/; expires=$date;\r\n" while(($name,$value)=each %{$cookies});
};
# generate headers
HideShow 26 lines of Pod
=head2 $cgi->header( \%args );
Prints http headers and cookies buffer to socket
Args:
=over
=item STATUS 
HTTP status string. '200 OK' by default
=item Server 
Server header. 'Perl HTTP::Server::EV' by default
=item Content-Type
Content-Type header. 'text/html' by default
=back
All other args will be converted to headers.
=cut
sub header {
        my ($self,$params)=@_;
        croak 'Can`t print headers to closed socket!' unless $_[0]->{buffer};
         
        my $headers = 'HTTP/1.1 '.($params->{'STATUS'} ? delete($params->{'STATUS'}) : '200 OK')."\r\n";
        $headers .= 'Server: '.($params->{'Server'} ? delete($params->{'Server'}) : 'Perl HTTP::Server::EV')."\r\n";
        $headers .= $self->{cookiesbuffer};
        $headers .= 'Content-Type: '.($params->{'Content-Type'} ? delete($params->{'Content-Type'}) : 'text/html')."\r\n";
         
        $headers .= $_.': '.$params->{$_}."\r\n" for(keys %{$params});
         
        $self->{buffer}->print($headers."\r\n");
}
HideShow 6 lines of Pod
=head2 $cgi->urldecode( $str );
Returns urldecoded utf8 string
=cut
sub urldecode {
        my ($output, $is_utf) = HTTP::Server::EV::url_decode($_[1]);
        $output = decode( $is_utf ? 'utf8' : 'cp1251', $output); 
        Encode::_utf8_on($output);
        $output;
};
         
HideShow 18 lines of Pod
=head1 NOT RECEIVED REQUEST METHODS
You can call these methods only after HTTP::Server::EV::PortListener on_multipart callback, when server receives POST data. You shouldn`t call them after request has received. 
=head2 $cgi->stop;
Stop request processing
=head2 $cgi->start;
Starts stopped request processing. 
=head2 $cgi->drop;
Drop user connection
=cut
sub stop { HTTP::Server::EV::stop_req($_[0]->{stack_pos}); 1}
sub start {
        my $fd = HTTP::Server::EV::start_req($_[0]->{stack_pos});
        EV::feed_fd_event($fd, EV::READ) if defined $fd;
        1;
}
sub drop { 
        HTTP::Server::EV::drop_req($_[0]->{stack_pos});
        EV::feed_fd_event($_[0]->{fd}, EV::READ);
}
sub DESTROY {
        HTTP::Server::EV::start_listen($_[0]->{parent_listener}{ptr}) unless $_[0]->{parent_listener}{stopped};
}
1;