view release on metacpan or  search on metacpan

lib/AxKit2/HTTPHeaders.pm  view on Meta::CPAN

    elsif ($lame) {
        $self->{requestLine} = (shift @lines) || "";
        $self->{requestLine} =~ /^GET ([^ ]+)$/m
            || die "Strange program interaction - not a lame request at all";
        
        $self->{method} = 'GET';
        $self->{uri} = $1;
        
        $self->{ver} = "0.9";
        $self->{vernum} = 9;
    }
    else {
        $self->{requestLine} = (shift @lines) || "";
    
        # check for valid request line
        return fail("Bogus request line") unless
            $self->{requestLine} =~ m!^(\w+) ((?:\*|(?:\S*?)))(?: HTTP/(\d+)\.(\d+))$!;
    
        $self->{method} = $1;
        $self->{uri} = $2;
    
        my ($ver_ma, $ver_mi) = ($3, $4);
    
        # now check uri for not being a uri
        if ($self->{uri} =~ m!^http://([^/:]+?)(?::\d+)?(/.*)?$!) {
            $absoluteURIHost = lc($1);
            $self->{uri} = $2 || "/"; # "http://www.foo.com" yields no path, so default to "/"
        }
        $self->parse_uri;
    
        # default to HTTP/0.9
        unless (defined $ver_ma) {
            ($ver_ma, $ver_mi) = (0, 9);
        }
    
        $self->{ver} = "$ver_ma.$ver_mi";
        $self->{vernum} = $ver_ma*1000 + $ver_mi;
    }
    
    my $last_header = undef;
    foreach my $line (@lines) {
        if ($line =~ /^\s/) {
            next unless defined $last_header;
            $self->{headers}{$last_header} .= $line;
        } elsif ($line =~ /^([^\x00-\x20\x7f()<>@,;:\\\"\/\[\]?={}]+):\s*(.*)$/) {
            # RFC 2616:
            # sec 4.2:
            #     message-header = field-name ":" [ field-value ]
            #     field-name     = token
            # sec 2.2:
            #     token          = 1*<any CHAR except CTLs or separators>

            $last_header = lc($1);
            if (defined $self->{headers}{$last_header}) {
                if ($last_header eq "set-cookie") {
                    # cookie spec doesn't allow merged headers for set-cookie,
                    # so instead we do this hack so to_string below does the right
                    # thing without needing to be arrayref-aware or such.  also
                    # this lets client code still modify/delete this data
                    # (but retrieving the value of "set-cookie" will be broken)
                    $self->{headers}{$last_header} .= "\r\nSet-Cookie: $2";
                } else {
                    # normal merged header case (according to spec)
                    $self->{headers}{$last_header} .= ", $2";
                }
            } else {
                $self->{headers}{$last_header} = $2;
                $self->{origcase}{$last_header} = $1;
                push @{$self->{hdorder}}, $last_header;
            }
        } else {
            return fail("unknown header line");
        }
    }

    # override the host header if an absolute URI was provided
    $self->header('Host', $absoluteURIHost)
        if defined $absoluteURIHost;

    # now error if no host
    return fail("HTTP 1.1 requires host header")
        if !$is_response && $self->{vernum} >= 1001 && !$self->header('Host');

    return $self;
}


=head2 C<< CLASS->new_response( [ CODE ] ) >>

Create a new response header with response code C<CODE> (default: 200 "OK").

Assumes response is HTTP/1.0.

=cut

sub new_response {
    my AxKit2::HTTPHeaders $self = shift;
    $self = fields::new($self) unless ref $self;

    my $code = shift || 200;
    $self->{headers} = {};
    $self->{origcase} = {};
    $self->{hdorder} = [];
    $self->{method} = undef;
    $self->{uri} = undef;

    $self->{responseLine} = "HTTP/1.0 $code " . $self->http_code_english($code);
    $self->{code} = $code;
    $self->{type} = "res";
    $self->{vernum} = 1000;

    return $self;
}

=head2 C<< $obj->parse_uri >>

Parse the request URI for querystring parameters.

=cut

sub parse_uri {

lib/AxKit2/HTTPHeaders.pm  view on Meta::CPAN

    return $self->http_code_english;
}

=head2 C<< $obj->code( CODE [, TEXT] ) >>

Sets the response code to C<CODE> with optional C<TEXT>.

=cut

sub code {
    my AxKit2::HTTPHeaders $self = shift;
    my ($code, $text) = @_;
    $self->{codetext} = $text;
    if (! defined $self->{code} || $code != $self->{code}) {
        $self->{code} = $code+0;
        if ($self->{responseLine}) {
            $self->{responseLine} = "HTTP/1.0 $code " . $self->http_code_english;
        }
    }
}

=head2 C<< $obj->response_code >>

Gets the response code.

=cut

sub response_code {
    my AxKit2::HTTPHeaders $self = $_[0];
    return $self->{code};
}

=head2 C<< $obj->request_method >>

Gets the request method (e.g. "GET", "POST", etc).

=cut

sub request_method {
    my AxKit2::HTTPHeaders $self = shift;
    return $self->{method};
}


=head2 C<< $obj->request_uri >>

Gets the request URI. Returns the full URI inclusive of query string.

Also callable as C<< $obj->uri >>.

=cut

sub request_uri {
    my AxKit2::HTTPHeaders $self = shift;
    @_ and $self->{uri} = shift;
    return $self->{uri};
}

*uri = \&request_uri;

# Parse the Cookie header.
sub parse_cookies {
    my AxKit2::HTTPHeaders $self = shift;
    my $raw_cookies = $self->header('Cookie') || '';
    $self->{parsed_cookies} = {};
    foreach (split(/;\s+/, $raw_cookies)) {
        my ($key, $value) = split("=", $_, 2);
        my (@values) = map { uri_decode($_) } split(/&/, $value);
        $key = uri_decode($key);
        $self->{parsed_cookies}{$key} = \@values;
    }
}

# From RFC-2109
#    cookie-av       =       "Comment" "=" value
#                    |       "Domain" "=" value
#                    |       "Max-Age" "=" value
#                    |       "Path" "=" value
#                    |       "Secure"
#                    |       "Version" "=" 1*DIGIT

=head2 C<< $obj->cookie( NAME ) >>

Returns a list of values for the given cookie C<NAME> in LIST context, or the
last set cookie for the given cookie C<NAME> in scalar context. Only works on request
headers. 

=head2 C<< $obj->cookie( NAME, VALUE [, PARAMS] ) >>

Set the cookie called C<NAME> with value C<VALUE>.

If value is an arrayref sets a multi-valued cookie.

Optional params are key-value pairs as per the cookie spec, e.g.:

  $header->cookie( foo => "bar", path => "/", secure => 1 );

Expiration via C<expires> is not parsed and does not take formats such as "+1d".
It is suggested to use C<max-age> instead (as per RFC 2109) which is a timeout in
seconds from the current time.

=cut
sub cookie {
    my AxKit2::HTTPHeaders $self = shift;
    my $name = shift;
    if (@_) {
        die "Cannot set cookies in the request"
            if $self->{type} eq 'req';
        # set cookie
        my $value = shift;
        my %params = @_;
        
        # special case for "secure"
        my @params = delete($params{secure}) ? ("secure") : ();
        # rest are key-value pairs
        push @params, map { "$_=$params{$_}" } keys %params;
        
        my $key = uri_encode($name);
        my $cookie = "$key=" . join("&", map uri_encode($_), ref($value) ? @$value : $value);
        $cookie = join('; ', $cookie, @params);
        if (my $oldcookie = $self->header('Set-Cookie')) {
            $cookie = "$oldcookie, $cookie";
        }
        $self->header('Set-Cookie', $cookie);
        $self->header('Expires', http_date(0)) unless $self->header('Expires');
        return;
    }
    die "Cannot extract cookies from the response"
        if $self->{type} eq 'res';
    $self->parse_cookies unless $self->{parsed_cookies};
    if (exists $self->{parsed_cookies}{$name}) {
        return wantarray ? @{$self->{parsed_cookies}{$name}} : $self->{parsed_cookies}{$name}[-1];
    }
}

=head2 C<< $obj->filename( [ STRING ] ) >>

Gets/Sets the request filename value.

=cut
sub filename {
    my AxKit2::HTTPHeaders $self = shift;
    @_ and $self->{file} = shift;
    return $self->{file};
}

=head2 C<< $obj->mime_type( [ STRING ] ) >>

Gets/Sets the request MIME type.

=cut
sub mime_type {
    my AxKit2::HTTPHeaders $self = shift;
    @_ and $self->{mime_type} = shift;
    return $self->{mime_type};
}

=head2 C<< $obj->path_info( [ STRING ] ) >>

Gets/Sets the request path-info value.

=cut
sub path_info {
    my AxKit2::HTTPHeaders $self = shift;
    @_ and $self->{path_info} = shift;
    return $self->{path_info};
}

=head2 C<< $obj->version_number( [ VER ] ) >>

Gets/Sets the header version number. Uses the form C<MAJOR * 1000 + MINOR>, so
HTTP/1.0 will return C<1000> and HTTP/0.9 will return C<9>.

=cut
sub version_number {
    my AxKit2::HTTPHeaders $self = shift;
    @_ and $self->{vernum} = shift;
    $self->{vernum};
}

=head2 C<< $obj->request_line >>

Returns the very first line of the request as seen.