diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 818642ae..4664dc54 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -37,7 +37,7 @@ You can run tests directly using the `prove` tool: ## Code style and tidying -This distribution contains a `.perltidyrc` file in the root of the repository. +This distribution contains a `perltidyrc` file in the root of the repository. Please install Perl::Tidy and use `perltidy` before submitting patches. However, as this is an old distribution and styling has changed somewhat over the years, please keep your tidying constrained to the portion of code or function in which @@ -48,7 +48,7 @@ you're patching. $ rm my_tidy_copy.pm The above command, for example, would provide you with a copy of `Status.pm` -that has been cleaned according to our `.perltidyrc` settings. You'd then look +that has been cleaned according to our `perltidyrc` settings. You'd then look at the newly created `my_tidy_copy.pm` in the dist root and replace your work with the cleaned up copy if there are differences. diff --git a/lib/HTTP/Config.pm b/lib/HTTP/Config.pm index f5dc9224..7f10720b 100644 --- a/lib/HTTP/Config.pm +++ b/lib/HTTP/Config.pm @@ -23,30 +23,30 @@ sub empty { } sub add { - if (@_ == 2) { + if ( @_ == 2 ) { my $self = shift; - push(@$self, shift); + push( @$self, shift ); return; } - my($self, %spec) = @_; - push(@$self, \%spec); + my ( $self, %spec ) = @_; + push( @$self, \%spec ); return; } sub find2 { - my($self, %spec) = @_; + my ( $self, %spec ) = @_; my @found; my @rest; - ITEM: +ITEM: for my $item (@$self) { - for my $k (keys %spec) { + for my $k ( keys %spec ) { no warnings 'uninitialized'; - if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) { - push(@rest, $item); + if ( !exists $item->{$k} || $spec{$k} ne $item->{$k} ) { + push( @rest, $item ); next ITEM; } } - push(@found, $item); + push( @found, $item ); } return \@found unless wantarray; return \@found, \@rest; @@ -54,106 +54,108 @@ sub find2 { sub find { my $self = shift; - my $f = $self->find2(@_); + my $f = $self->find2(@_); return @$f if wantarray; return $f->[0]; } sub remove { - my($self, %spec) = @_; - my($removed, $rest) = $self->find2(%spec); + my ( $self, %spec ) = @_; + my ( $removed, $rest ) = $self->find2(%spec); @$self = @$rest if @$removed; return @$removed; } my %MATCH = ( m_scheme => sub { - my($v, $uri) = @_; - return $uri->_scheme eq $v; # URI known to be canonical + my ( $v, $uri ) = @_; + return $uri->_scheme eq $v; # URI known to be canonical }, m_secure => sub { - my($v, $uri) = @_; - my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; + my ( $v, $uri ) = @_; + my $secure + = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; return $secure == !!$v; }, m_host_port => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("host_port"); return $uri->host_port eq $v, 7; }, m_host => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("host"); return $uri->host eq $v, 6; }, m_port => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("port"); return $uri->port eq $v; }, m_domain => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("host"); my $h = $uri->host; $h = "$h.local" unless $h =~ /\./; - $v = ".$v" unless $v =~ /^\./; - return length($v), 5 if substr($h, -length($v)) eq $v; + $v = ".$v" unless $v =~ /^\./; + return length($v), 5 if substr( $h, -length($v) ) eq $v; return 0; }, m_path => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("path"); return $uri->path eq $v, 4; }, m_path_prefix => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("path"); my $path = $uri->path; - my $len = length($v); + my $len = length($v); return $len, 3 if $path eq $v; return 0 if length($path) <= $len; $v .= "/" unless $v =~ m,/\z,,; - return $len, 3 if substr($path, 0, length($v)) eq $v; + return $len, 3 if substr( $path, 0, length($v) ) eq $v; return 0; }, m_path_match => sub { - my($v, $uri) = @_; + my ( $v, $uri ) = @_; return unless $uri->can("path"); return $uri->path =~ $v; }, m_uri__ => sub { - my($v, $k, $uri) = @_; - return unless $uri->can($k); + my ( $v, $k, $uri ) = @_; + return unless $uri->can($k); return 1 unless defined $v; return $uri->$k eq $v; }, m_method => sub { - my($v, $uri, $request) = @_; + my ( $v, $uri, $request ) = @_; return $request && $request->method eq $v; }, m_proxy => sub { - my($v, $uri, $request) = @_; - return $request && ($request->{proxy} || "") eq $v; + my ( $v, $uri, $request ) = @_; + return $request && ( $request->{proxy} || "" ) eq $v; }, m_code => sub { - my($v, $uri, $request, $response) = @_; + my ( $v, $uri, $request, $response ) = @_; $v =~ s/xx\z//; return unless $response; - return length($v), 2 if substr($response->code, 0, length($v)) eq $v; + return length($v), 2 + if substr( $response->code, 0, length($v) ) eq $v; }, - m_media_type => sub { # for request too?? - my($v, $uri, $request, $response) = @_; + m_media_type => sub { # for request too?? + my ( $v, $uri, $request, $response ) = @_; return unless $response; return 1, 1 if $v eq "*/*"; my $ct = $response->content_type; - return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; - return 3, 1 if $v eq "html" && $response->content_is_html; - return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; + return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; + return 3, 1 if $v eq "html" && $response->content_is_html; + return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; return 10, 1 if $v eq $ct; return 0; }, m_header__ => sub { - my($v, $k, $uri, $request, $response) = @_; + my ( $v, $k, $uri, $request, $response ) = @_; return unless $request; my $req_header = $request->header($k); return 1 if defined($req_header) && $req_header eq $v; @@ -164,7 +166,7 @@ my %MATCH = ( return 0; }, m_response_attr__ => sub { - my($v, $k, $uri, $request, $response) = @_; + my ( $v, $k, $uri, $request, $response ) = @_; return unless $response; return 1 if !defined($v) && exists $response->{$k}; return 0 unless exists $response->{$k}; @@ -175,27 +177,29 @@ my %MATCH = ( sub matching { my $self = shift; - if (@_ == 1) { - if ($_[0]->can("request")) { - unshift(@_, $_[0]->request); - unshift(@_, undef) unless defined $_[0]; + if ( @_ == 1 ) { + if ( $_[0]->can("request") ) { + unshift( @_, $_[0]->request ); + unshift( @_, undef ) unless defined $_[0]; } - unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); + unshift( @_, $_[0]->uri_canonical ) + if $_[0] && $_[0]->can("uri_canonical"); } - my($uri, $request, $response) = @_; + my ( $uri, $request, $response ) = @_; $uri = URI->new($uri) unless ref($uri); my @m; - ITEM: +ITEM: for my $item (@$self) { my $order; - for my $ikey (keys %$item) { + for my $ikey ( keys %$item ) { my $mkey = $ikey; my $k; $k = $1 if $mkey =~ s/__(.*)/__/; - if (my $m = $MATCH{$mkey}) { + if ( my $m = $MATCH{$mkey} ) { + #print "$ikey $mkey\n"; - my($c, $o); + my ( $c, $o ); my @arg = ( defined($k) ? $k : (), $uri, $request, $response @@ -203,17 +207,19 @@ sub matching { my $v = $item->{$ikey}; $v = [$v] unless ref($v) eq "ARRAY"; for (@$v) { - ($c, $o) = $m->($_, @arg); + ( $c, $o ) = $m->( $_, @arg ); + #print " - $_ ==> $c $o\n"; last if $c; } next ITEM unless $c; - $order->[$o || 0] += $c; + $order->[ $o || 0 ] += $c; } } $order->[7] ||= 0; - $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order); - push(@m, $item); + $item->{_order} + = join( ".", reverse map sprintf( "%03d", $_ || 0 ), @$order ); + push( @m, $item ); } @m = sort { $b->{_order} cmp $a->{_order} } @m; delete $_->{_order} for @m; @@ -224,7 +230,7 @@ sub matching { sub add_item { my $self = shift; my $item = shift; - return $self->add(item => $item, @_); + return $self->add( item => $item, @_ ); } sub remove_items { diff --git a/lib/HTTP/Headers.pm b/lib/HTTP/Headers.pm index cc5659aa..b329cb05 100644 --- a/lib/HTTP/Headers.pm +++ b/lib/HTTP/Headers.pm @@ -6,7 +6,7 @@ use warnings; our $VERSION = '7.01'; use Clone qw(clone); -use Carp (); +use Carp (); # The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used # as a replacement for '-' in header field names. @@ -57,270 +57,260 @@ my %standard_case; { my $i = 0; for (@header_order) { - my $lc = lc $_; - $header_order{$lc} = ++$i; - $standard_case{$lc} = $_; + my $lc = lc $_; + $header_order{$lc} = ++$i; + $standard_case{$lc} = $_; } } - - -sub new -{ - my($class) = shift; - my $self = bless {}, $class; - $self->header(@_) if @_; # set up initial headers +sub new { + my ($class) = shift; + my $self = bless {}, $class; + $self->header(@_) if @_; # set up initial headers $self; } - -sub header -{ +sub header { my $self = shift; Carp::croak('Usage: $h->header($field, ...)') unless @_; - my(@old); + my (@old); my %seen; while (@_) { - my $field = shift; - my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET'; - @old = $self->_header($field, shift, $op); + my $field = shift; + my $op = @_ ? ( $seen{ lc($field) }++ ? 'PUSH' : 'SET' ) : 'GET'; + @old = $self->_header( $field, shift, $op ); } - return @old if wantarray; + return @old if wantarray; return $old[0] if @old <= 1; - join(", ", @old); + join( ", ", @old ); } -sub clear -{ +sub clear { my $self = shift; %$self = (); } - -sub push_header -{ +sub push_header { my $self = shift; - return $self->_header(@_, 'PUSH_H') if @_ == 2; + return $self->_header( @_, 'PUSH_H' ) if @_ == 2; while (@_) { - $self->_header(splice(@_, 0, 2), 'PUSH_H'); + $self->_header( splice( @_, 0, 2 ), 'PUSH_H' ); } } - -sub init_header -{ +sub init_header { Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; - shift->_header(@_, 'INIT'); + shift->_header( @_, 'INIT' ); } - -sub remove_header -{ - my($self, @fields) = @_; +sub remove_header { + my ( $self, @fields ) = @_; my $field; my @values; foreach $field (@fields) { - $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; - my $v = delete $self->{lc $field}; - push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v; + $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; + my $v = delete $self->{ lc $field }; + push( @values, ref($v) eq 'ARRAY' ? @$v : $v ) if defined $v; } return @values; } -sub remove_content_headers -{ +sub remove_content_headers { my $self = shift; - unless (defined(wantarray)) { - # fast branch that does not create return object - delete @$self{grep $entity_header{$_} || /^content-/, keys %$self}; - return; + unless ( defined(wantarray) ) { + + # fast branch that does not create return object + delete @$self{ grep $entity_header{$_} || /^content-/, keys %$self }; + return; } my $c = ref($self)->new; - for my $f (grep $entity_header{$_} || /^content-/, keys %$self) { - $c->{$f} = delete $self->{$f}; + for my $f ( grep $entity_header{$_} || /^content-/, keys %$self ) { + $c->{$f} = delete $self->{$f}; } - if (exists $self->{'::std_case'}) { - $c->{'::std_case'} = $self->{'::std_case'}; + if ( exists $self->{'::std_case'} ) { + $c->{'::std_case'} = $self->{'::std_case'}; } $c; } - -sub _header -{ - my($self, $field, $val, $op) = @_; +sub _header { + my ( $self, $field, $val, $op ) = @_; Carp::croak("Illegal field name '$field'") - if rindex($field, ':') > 1 || !length($field); - - unless ($field =~ /^:/) { - $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; - my $old = $field; - $field = lc $field; - unless($standard_case{$field} || $self->{'::std_case'}{$field}) { - # generate a %std_case entry for this field - $old =~ s/\b(\w)/\u$1/g; - $self->{'::std_case'}{$field} = $old; - } + if rindex( $field, ':' ) > 1 || !length($field); + + unless ( $field =~ /^:/ ) { + $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; + my $old = $field; + $field = lc $field; + unless ( $standard_case{$field} || $self->{'::std_case'}{$field} ) { + + # generate a %std_case entry for this field + $old =~ s/\b(\w)/\u$1/g; + $self->{'::std_case'}{$field} = $old; + } } $op ||= defined($val) ? 'SET' : 'GET'; - if ($op eq 'PUSH_H') { - # Like PUSH but where we don't care about the return value - if (exists $self->{$field}) { - my $h = $self->{$field}; - if (ref($h) eq 'ARRAY') { - push(@$h, ref($val) eq "ARRAY" ? @$val : $val); - } - else { - $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val] - } - return; - } - $self->{$field} = $val; - return; + if ( $op eq 'PUSH_H' ) { + + # Like PUSH but where we don't care about the return value + if ( exists $self->{$field} ) { + my $h = $self->{$field}; + if ( ref($h) eq 'ARRAY' ) { + push( @$h, ref($val) eq "ARRAY" ? @$val : $val ); + } + else { + $self->{$field} = [ $h, ref($val) eq "ARRAY" ? @$val : $val ]; + } + return; + } + $self->{$field} = $val; + return; } - my $h = $self->{$field}; - my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ()); - - unless ($op eq 'GET' || ($op eq 'INIT' && @old)) { - if (defined($val)) { - my @new = ($op eq 'PUSH') ? @old : (); - if (ref($val) ne 'ARRAY') { - push(@new, $val); - } - else { - push(@new, @$val); - } - $self->{$field} = @new > 1 ? \@new : $new[0]; - } - elsif ($op ne 'PUSH') { - delete $self->{$field}; - } + my $h = $self->{$field}; + my @old = ref($h) eq 'ARRAY' ? @$h : ( defined($h) ? ($h) : () ); + + unless ( $op eq 'GET' || ( $op eq 'INIT' && @old ) ) { + if ( defined($val) ) { + my @new = ( $op eq 'PUSH' ) ? @old : (); + if ( ref($val) ne 'ARRAY' ) { + push( @new, $val ); + } + else { + push( @new, @$val ); + } + $self->{$field} = @new > 1 ? \@new : $new[0]; + } + elsif ( $op ne 'PUSH' ) { + delete $self->{$field}; + } } @old; } - -sub _sorted_field_names -{ +sub _sorted_field_names { my $self = shift; - return [ sort { - ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || - $a cmp $b - } grep !/^::/, keys %$self ]; + return [ + sort { + ( $header_order{$a} || 999 ) <=> ( $header_order{$b} || 999 ) + || $a cmp $b + } grep !/^::/, + keys %$self + ]; } - sub header_field_names { my $self = shift; - return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names }, - if wantarray; + return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, + @{ $self->_sorted_field_names }, + if wantarray; return grep !/^::/, keys %$self; } - -sub scan -{ - my($self, $sub) = @_; +sub scan { + my ( $self, $sub ) = @_; my $key; - for $key (@{ $self->_sorted_field_names }) { - my $vals = $self->{$key}; - if (ref($vals) eq 'ARRAY') { - my $val; - for $val (@$vals) { - $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val); - } - } - else { - $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals); - } + for $key ( @{ $self->_sorted_field_names } ) { + my $vals = $self->{$key}; + if ( ref($vals) eq 'ARRAY' ) { + my $val; + for $val (@$vals) { + $sub->( $standard_case{$key} + || $self->{'::std_case'}{$key} + || $key, $val ); + } + } + else { + $sub->( $standard_case{$key} + || $self->{'::std_case'}{$key} + || $key, $vals ); + } } } sub flatten { - my($self)=@_; - - ( - map { - my $k = $_; - map { - ( $k => $_ ) - } $self->header($_); - } $self->header_field_names - ); + my ($self) = @_; + + ( + map { + my $k = $_; + map { ( $k => $_ ) } $self->header($_); + } $self->header_field_names + ); } -sub as_string -{ - my($self, $endl) = @_; +sub as_string { + my ( $self, $endl ) = @_; $endl = "\n" unless defined $endl; my @result = (); - for my $key (@{ $self->_sorted_field_names }) { - next if index($key, '_') == 0; - my $vals = $self->{$key}; - if ( ref($vals) eq 'ARRAY' ) { - for my $val (@$vals) { - $val = '' if not defined $val; - my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; - $field =~ s/^://; - if ( index($val, "\n") >= 0 ) { - $val = _process_newline($val, $endl); - } - push @result, $field . ': ' . $val; - } - } - else { - $vals = '' if not defined $vals; - my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; - $field =~ s/^://; - if ( index($vals, "\n") >= 0 ) { - $vals = _process_newline($vals, $endl); - } - push @result, $field . ': ' . $vals; - } + for my $key ( @{ $self->_sorted_field_names } ) { + next if index( $key, '_' ) == 0; + my $vals = $self->{$key}; + if ( ref($vals) eq 'ARRAY' ) { + for my $val (@$vals) { + $val = '' if not defined $val; + my $field + = $standard_case{$key} + || $self->{'::std_case'}{$key} + || $key; + $field =~ s/^://; + if ( index( $val, "\n" ) >= 0 ) { + $val = _process_newline( $val, $endl ); + } + push @result, $field . ': ' . $val; + } + } + else { + $vals = '' if not defined $vals; + my $field + = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; + $field =~ s/^://; + if ( index( $vals, "\n" ) >= 0 ) { + $vals = _process_newline( $vals, $endl ); + } + push @result, $field . ': ' . $vals; + } } - join($endl, @result, ''); + join( $endl, @result, '' ); } sub _process_newline { local $_ = shift; my $endl = shift; + # must handle header values with embedded newlines with care - s/\s+$//; # trailing newlines and space must go - s/\n(\x0d?\n)+/\n/g; # no empty lines - s/\n([^\040\t])/\n $1/g; # initial space for continuation - s/\n/$endl/g; # substitute with requested line ending + s/\s+$//; # trailing newlines and space must go + s/\n(\x0d?\n)+/\n/g; # no empty lines + s/\n([^\040\t])/\n $1/g; # initial space for continuation + s/\n/$endl/g; # substitute with requested line ending $_; } - -sub _date_header -{ +sub _date_header { require HTTP::Date; - my($self, $header, $time) = @_; - my($old) = $self->_header($header); - if (defined $time) { - $self->_header($header, HTTP::Date::time2str($time)); + my ( $self, $header, $time ) = @_; + my ($old) = $self->_header($header); + if ( defined $time ) { + $self->_header( $header, HTTP::Date::time2str($time) ); } $old =~ s/;.*// if defined($old); HTTP::Date::str2time($old); } - -sub date { shift->_date_header('Date', @_); } -sub expires { shift->_date_header('Expires', @_); } -sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } -sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } -sub last_modified { shift->_date_header('Last-Modified', @_); } +sub date { shift->_date_header( 'Date', @_ ); } +sub expires { shift->_date_header( 'Expires', @_ ); } +sub if_modified_since { shift->_date_header( 'If-Modified-Since', @_ ); } +sub if_unmodified_since { shift->_date_header( 'If-Unmodified-Since', @_ ); } +sub last_modified { shift->_date_header( 'Last-Modified', @_ ); } # This is used as a private LWP extension. The Client-Date header is # added as a timestamp to a response when it has been received. -sub client_date { shift->_date_header('Client-Date', @_); } +sub client_date { shift->_date_header( 'Client-Date', @_ ); } # The retry_after field is dual format (can also be a expressed as # number of seconds from now), so we don't provide an easy way to @@ -329,16 +319,16 @@ sub client_date { shift->_date_header('Client-Date', @_); } # relative seconds and a positive value for epoch based time values. #sub retry_after { shift->_date_header('Retry-After', @_); } -sub content_type { +sub content_type { my $self = shift; - my $ct = $self->{'content-type'}; - $self->{'content-type'} = shift if @_; - $ct = $ct->[0] if ref($ct) eq 'ARRAY'; + my $ct = $self->{'content-type'}; + $self->{'content-type'} = shift if @_; + $ct = $ct->[0] if ref($ct) eq 'ARRAY'; return '' unless defined($ct) && length($ct); - my @ct = split(/;\s*/, $ct, 2); - for ($ct[0]) { - s/\s+//g; - $_ = lc($_); + my @ct = split( /;\s*/, $ct, 2 ); + for ( $ct[0] ) { + s/\s+//g; + $_ = lc($_); } wantarray ? @ct : $ct[0]; } @@ -351,19 +341,20 @@ sub content_type_charset { $h = "" unless defined $h; my @v = HTTP::Headers::Util::split_header_words($h); if (@v) { - my($ct, undef, %ct_param) = @{$v[0]}; - my $charset = $ct_param{charset}; - if ($ct) { - $ct = lc($ct); - $ct =~ s/\s+//; - } - if ($charset) { - $charset = uc($charset); - $charset =~ s/^\s+//; $charset =~ s/\s+\z//; - undef($charset) if $charset eq ""; - } - return $ct, $charset if wantarray; - return $charset; + my ( $ct, undef, %ct_param ) = @{ $v[0] }; + my $charset = $ct_param{charset}; + if ($ct) { + $ct = lc($ct); + $ct =~ s/\s+//; + } + if ($charset) { + $charset = uc($charset); + $charset =~ s/^\s+//; + $charset =~ s/\s+\z//; + undef($charset) if $charset eq ""; + } + return $ct, $charset if wantarray; + return $charset; } return undef, undef if wantarray; return undef; @@ -381,8 +372,8 @@ sub content_is_html { sub content_is_xhtml { my $ct = shift->content_type; - return $ct eq "application/xhtml+xml" || - $ct eq "application/vnd.wap.xhtml+xml"; + return $ct eq "application/xhtml+xml" + || $ct eq "application/vnd.wap.xhtml+xml"; } sub content_is_xml { @@ -393,64 +384,67 @@ sub content_is_xml { return 0; } -sub referer { +sub referer { my $self = shift; - if (@_ && $_[0] =~ /#/) { - # Strip fragment per RFC 2616, section 14.36. - my $uri = shift; - if (ref($uri)) { - $uri = $uri->clone; - $uri->fragment(undef); - } - else { - $uri =~ s/\#.*//; - } - unshift @_, $uri; + if ( @_ && $_[0] =~ /#/ ) { + + # Strip fragment per RFC 2616, section 14.36. + my $uri = shift; + if ( ref($uri) ) { + $uri = $uri->clone; + $uri->fragment(undef); + } + else { + $uri =~ s/\#.*//; + } + unshift @_, $uri; } - ($self->_header('Referer', @_))[0]; + ( $self->_header( 'Referer', @_ ) )[0]; } -*referrer = \&referer; # on tchrist's request +*referrer = \&referer; # on tchrist's request -sub title { (shift->_header('Title', @_))[0] } -sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } -sub content_language { (shift->_header('Content-Language', @_))[0] } -sub content_length { (shift->_header('Content-Length', @_))[0] } +sub title { ( shift->_header( 'Title', @_ ) )[0] } +sub content_encoding { ( shift->_header( 'Content-Encoding', @_ ) )[0] } +sub content_language { ( shift->_header( 'Content-Language', @_ ) )[0] } +sub content_length { ( shift->_header( 'Content-Length', @_ ) )[0] } -sub user_agent { (shift->_header('User-Agent', @_))[0] } -sub server { (shift->_header('Server', @_))[0] } +sub user_agent { ( shift->_header( 'User-Agent', @_ ) )[0] } +sub server { ( shift->_header( 'Server', @_ ) )[0] } -sub from { (shift->_header('From', @_))[0] } -sub warning { (shift->_header('Warning', @_))[0] } +sub from { ( shift->_header( 'From', @_ ) )[0] } +sub warning { ( shift->_header( 'Warning', @_ ) )[0] } -sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } -sub authorization { (shift->_header('Authorization', @_))[0] } +sub www_authenticate { ( shift->_header( 'WWW-Authenticate', @_ ) )[0] } +sub authorization { ( shift->_header( 'Authorization', @_ ) )[0] } -sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } -sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } +sub proxy_authenticate { ( shift->_header( 'Proxy-Authenticate', @_ ) )[0] } +sub proxy_authorization { ( shift->_header( 'Proxy-Authorization', @_ ) )[0] } -sub authorization_basic { shift->_basic_auth("Authorization", @_) } -sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } +sub authorization_basic { shift->_basic_auth( "Authorization", @_ ) } + +sub proxy_authorization_basic { + shift->_basic_auth( "Proxy-Authorization", @_ ); +} sub _basic_auth { require MIME::Base64; - my($self, $h, $user, $passwd) = @_; - my($old) = $self->_header($h); - if (defined $user) { - Carp::croak("Basic authorization user name can't contain ':'") - if $user =~ /:/; - $passwd = '' unless defined $passwd; - $self->_header($h => 'Basic ' . - MIME::Base64::encode("$user:$passwd", '')); + my ( $self, $h, $user, $passwd ) = @_; + my ($old) = $self->_header($h); + if ( defined $user ) { + Carp::croak("Basic authorization user name can't contain ':'") + if $user =~ /:/; + $passwd = '' unless defined $passwd; + $self->_header( + $h => 'Basic ' . MIME::Base64::encode( "$user:$passwd", '' ) ); } - if (defined $old && $old =~ s/^\s*Basic\s+//) { - my $val = MIME::Base64::decode($old); - return $val unless wantarray; - return split(/:/, $val, 2); + if ( defined $old && $old =~ s/^\s*Basic\s+// ) { + my $val = MIME::Base64::decode($old); + return $val unless wantarray; + return split( /:/, $val, 2 ); } return; } - 1; __END__ @@ -532,7 +526,7 @@ field value. Examples: $header->header(MIME_Version => '1.0', - User_Agent => 'My-Web-Client/0.01'); + User_Agent => 'My-Web-Client/0.01'); $header->header(Accept => "text/html, text/plain, image/*"); $header->header(Accept => [qw(text/html text/plain image/*)]); @accepts = $header->header('Accept'); # get multiple values @@ -677,7 +671,7 @@ modified. I: # check if document is more than 1 hour old if (my $last_mod = $h->last_modified) { if ($last_mod < time - 60*60) { - ... + ... } } diff --git a/lib/HTTP/Headers/Auth.pm b/lib/HTTP/Headers/Auth.pm index 86aa5b6c..8032f855 100644 --- a/lib/HTTP/Headers/Auth.pm +++ b/lib/HTTP/Headers/Auth.pm @@ -7,8 +7,7 @@ our $VERSION = '7.01'; use HTTP::Headers; -package - HTTP::Headers; +package HTTP::Headers; BEGIN { # we provide a new (and better) implementations below @@ -18,83 +17,84 @@ BEGIN { require HTTP::Headers::Util; -sub _parse_authenticate -{ +sub _parse_authenticate { my @ret; - for (HTTP::Headers::Util::split_header_words(@_)) { - if (!defined($_->[1])) { - # this is a new auth scheme - push(@ret, shift(@$_) => {}); - shift @$_; - } - if (@ret) { - # this a new parameter pair for the last auth scheme - while (@$_) { - my $k = shift @$_; - my $v = shift @$_; - $ret[-1]{$k} = $v; - } - } - else { - # something wrong, parameter pair without any scheme seen - # IGNORE - } + for ( HTTP::Headers::Util::split_header_words(@_) ) { + if ( !defined( $_->[1] ) ) { + + # this is a new auth scheme + push( @ret, shift(@$_) => {} ); + shift @$_; + } + if (@ret) { + + # this a new parameter pair for the last auth scheme + while (@$_) { + my $k = shift @$_; + my $v = shift @$_; + $ret[-1]{$k} = $v; + } + } + else { + # something wrong, parameter pair without any scheme seen + # IGNORE + } } @ret; } -sub _authenticate -{ - my $self = shift; +sub _authenticate { + my $self = shift; my $header = shift; - my @old = $self->_header($header); + my @old = $self->_header($header); if (@_) { - $self->remove_header($header); - my @new = @_; - while (@new) { - my $a_scheme = shift(@new); - if ($a_scheme =~ /\s/) { - # assume complete valid value, pass it through - $self->push_header($header, $a_scheme); - } - else { - my @param; - if (@new) { - my $p = $new[0]; - if (ref($p) eq "ARRAY") { - @param = @$p; - shift(@new); - } - elsif (ref($p) eq "HASH") { - @param = %$p; - shift(@new); - } - } - my $val = ucfirst(lc($a_scheme)); - if (@param) { - my $sep = " "; - while (@param) { - my $k = shift @param; - my $v = shift @param; - if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { - # must quote the value - $v =~ s,([\\\"]),\\$1,g; - $v = qq("$v"); - } - $val .= "$sep$k=$v"; - $sep = ", "; - } - } - $self->push_header($header, $val); - } - } + $self->remove_header($header); + my @new = @_; + while (@new) { + my $a_scheme = shift(@new); + if ( $a_scheme =~ /\s/ ) { + + # assume complete valid value, pass it through + $self->push_header( $header, $a_scheme ); + } + else { + my @param; + if (@new) { + my $p = $new[0]; + if ( ref($p) eq "ARRAY" ) { + @param = @$p; + shift(@new); + } + elsif ( ref($p) eq "HASH" ) { + @param = %$p; + shift(@new); + } + } + my $val = ucfirst( lc($a_scheme) ); + if (@param) { + my $sep = " "; + while (@param) { + my $k = shift @param; + my $v = shift @param; + if ( $v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm" ) { + + # must quote the value + $v =~ s,([\\\"]),\\$1,g; + $v = qq("$v"); + } + $val .= "$sep$k=$v"; + $sep = ", "; + } + } + $self->push_header( $header, $val ); + } + } } return unless defined wantarray; - wantarray ? _parse_authenticate(@old) : join(", ", @old); + wantarray ? _parse_authenticate(@old) : join( ", ", @old ); } - -sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } -sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } +sub www_authenticate { shift->_authenticate( "WWW-Authenticate", @_ ) } +sub proxy_authenticate { shift->_authenticate( "Proxy-Authenticate", @_ ) } 1; diff --git a/lib/HTTP/Headers/ETag.pm b/lib/HTTP/Headers/ETag.pm index 8ac91deb..9d6c6598 100644 --- a/lib/HTTP/Headers/ETag.pm +++ b/lib/HTTP/Headers/ETag.pm @@ -8,89 +8,85 @@ our $VERSION = '7.01'; require HTTP::Date; require HTTP::Headers; -package - HTTP::Headers; +package HTTP::Headers; -sub _etags -{ - my $self = shift; +sub _etags { + my $self = shift; my $header = shift; - my @old = _split_etag_list($self->_header($header)); + my @old = _split_etag_list( $self->_header($header) ); if (@_) { - $self->_header($header => join(", ", _split_etag_list(@_))); + $self->_header( $header => join( ", ", _split_etag_list(@_) ) ); } - wantarray ? @old : join(", ", @old); + wantarray ? @old : join( ", ", @old ); } -sub etag { shift->_etags("ETag", @_); } -sub if_match { shift->_etags("If-Match", @_); } -sub if_none_match { shift->_etags("If-None-Match", @_); } +sub etag { shift->_etags( "ETag", @_ ); } +sub if_match { shift->_etags( "If-Match", @_ ); } +sub if_none_match { shift->_etags( "If-None-Match", @_ ); } sub if_range { + # Either a date or an entity-tag my $self = shift; - my @old = $self->_header("If-Range"); + my @old = $self->_header("If-Range"); if (@_) { - my $new = shift; - if (!defined $new) { - $self->remove_header("If-Range"); - } - elsif ($new =~ /^\d+$/) { - $self->_date_header("If-Range", $new); - } - else { - $self->_etags("If-Range", $new); - } + my $new = shift; + if ( !defined $new ) { + $self->remove_header("If-Range"); + } + elsif ( $new =~ /^\d+$/ ) { + $self->_date_header( "If-Range", $new ); + } + else { + $self->_etags( "If-Range", $new ); + } } return unless defined(wantarray); for (@old) { - my $t = HTTP::Date::str2time($_); - $_ = $t if $t; + my $t = HTTP::Date::str2time($_); + $_ = $t if $t; } - wantarray ? @old : join(", ", @old); + wantarray ? @old : join( ", ", @old ); } - # Split a list of entity tag values. The return value is a list # consisting of one element per entity tag. Suitable for parsing # headers like C, C. You might even want to # use it on C and C entity tag values, because it will # normalize them to the common form. # -# entity-tag = [ weak ] opaque-tag -# weak = "W/" -# opaque-tag = quoted-string +# entity-tag = [ weak ] opaque-tag +# weak = "W/" +# opaque-tag = quoted-string - -sub _split_etag_list -{ - my(@val) = @_; +sub _split_etag_list { + my (@val) = @_; my @res; for (@val) { while (length) { my $weak = ""; - $weak = "W/" if s,^\s*[wW]/,,; + $weak = "W/" if s,^\s*[wW]/,,; my $etag = ""; - if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { - push(@res, "$weak$1"); + if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { + push( @res, "$weak$1" ); } elsif (s/^\s*,//) { - push(@res, qq(W/"")) if $weak; + push( @res, qq(W/"") ) if $weak; } elsif (s/^\s*([^,\s]+)//) { $etag = $1; - $etag =~ s/([\"\\])/\\$1/g; - push(@res, qq($weak"$etag")); + $etag =~ s/([\"\\])/\\$1/g; + push( @res, qq($weak"$etag") ); } - elsif (s/^\s+// || !length) { - push(@res, qq(W/"")) if $weak; + elsif ( s/^\s+// || !length ) { + push( @res, qq(W/"") ) if $weak; } else { - die "This should not happen: '$_'"; + die "This should not happen: '$_'"; } } - } - @res; + } + @res; } 1; diff --git a/lib/HTTP/Headers/Util.pm b/lib/HTTP/Headers/Util.pm index 850d1691..c22e5b06 100644 --- a/lib/HTTP/Headers/Util.pm +++ b/lib/HTTP/Headers/Util.pm @@ -7,90 +7,90 @@ our $VERSION = '7.01'; use Exporter 5.57 'import'; -our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words); - +our @EXPORT_OK = qw(split_header_words _split_header_words join_header_words); sub split_header_words { my @res = &_split_header_words; for my $arr (@res) { - for (my $i = @$arr - 2; $i >= 0; $i -= 2) { - $arr->[$i] = lc($arr->[$i]); - } + for ( my $i = @$arr - 2 ; $i >= 0 ; $i -= 2 ) { + $arr->[$i] = lc( $arr->[$i] ); + } } return @res; } -sub _split_header_words -{ - my(@val) = @_; +sub _split_header_words { + my (@val) = @_; my @res; for (@val) { - my @cur; - while (length) { - if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' - push(@cur, $1); - # a quoted value - if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { - my $val = $1; - $val =~ s/\\(.)/$1/g; - push(@cur, $val); - # some unquoted value - } - elsif (s/^\s*=\s*([^;,\s]*)//) { - my $val = $1; - $val =~ s/\s+$//; - push(@cur, $val); - # no value, a lone token - } - else { - push(@cur, undef); - } - } - elsif (s/^\s*,//) { - push(@res, [@cur]) if @cur; - @cur = (); - } - elsif (s/^\s*;// || s/^\s+// || s/^=//) { - # continue - } - else { - die "This should not happen: '$_'"; - } - } - push(@res, \@cur) if @cur; + my @cur; + while (length) { + if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' + push( @cur, $1 ); + + # a quoted value + if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { + my $val = $1; + $val =~ s/\\(.)/$1/g; + push( @cur, $val ); + + # some unquoted value + } + elsif (s/^\s*=\s*([^;,\s]*)//) { + my $val = $1; + $val =~ s/\s+$//; + push( @cur, $val ); + + # no value, a lone token + } + else { + push( @cur, undef ); + } + } + elsif (s/^\s*,//) { + push( @res, [@cur] ) if @cur; + @cur = (); + } + elsif ( s/^\s*;// || s/^\s+// || s/^=// ) { + + # continue + } + else { + die "This should not happen: '$_'"; + } + } + push( @res, \@cur ) if @cur; } @res; } - -sub join_header_words -{ - @_ = ([@_]) if @_ && !ref($_[0]); +sub join_header_words { + @_ = ( [@_] ) if @_ && !ref( $_[0] ); my @res; for (@_) { - my @cur = @$_; - my @attr; - while (@cur) { - my $k = shift @cur; - my $v = shift @cur; - if (defined $v) { - if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) { - $v =~ s/([\"\\])/\\$1/g; # escape " and \ - $k .= qq(="$v"); - } - else { - # token - $k .= "=$v"; - } - } - push(@attr, $k); - } - push(@res, join("; ", @attr)) if @attr; + my @cur = @$_; + my @attr; + while (@cur) { + my $k = shift @cur; + my $v = shift @cur; + if ( defined $v ) { + if ( $v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ + || !length($v) ) { + $v =~ s/([\"\\])/\\$1/g; # escape " and \ + $k .= qq(="$v"); + } + else { + # token + $k .= "=$v"; + } + } + push( @attr, $k ); + } + push( @res, join( "; ", @attr ) ) if @attr; } - join(", ", @res); + join( ", ", @res ); } - 1; __END__ diff --git a/lib/HTTP/Message.pm b/lib/HTTP/Message.pm index 9a8d0227..29de0793 100644 --- a/lib/HTTP/Message.pm +++ b/lib/HTTP/Message.pm @@ -10,42 +10,42 @@ require Carp; our $MAXIMUM_BODY_SIZE; -my $CRLF = "\015\012"; # "\r\n" is not portable +my $CRLF = "\015\012"; # "\r\n" is not portable unless ($HTTP::URI_CLASS) { - if ($ENV{PERL_HTTP_URI_CLASS} - && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) { + if ( $ENV{PERL_HTTP_URI_CLASS} + && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/ ) { $HTTP::URI_CLASS = $1; - } else { + } + else { $HTTP::URI_CLASS = "URI"; } } -eval "require $HTTP::URI_CLASS"; die $@ if $@; +eval "require $HTTP::URI_CLASS"; +die $@ if $@; -*_utf8_downgrade = defined(&utf8::downgrade) ? - sub { - utf8::downgrade($_[0], 1) or - Carp::croak("HTTP::Message content must be bytes") +*_utf8_downgrade = defined(&utf8::downgrade) + ? sub { + utf8::downgrade( $_[0], 1 ) + or Carp::croak("HTTP::Message content must be bytes"); } - : - sub { + : sub { }; -sub new -{ - my($class, $header, $content) = @_; - if (defined $header) { - Carp::croak("Bad header argument") unless ref $header; - if (ref($header) eq "ARRAY") { - $header = HTTP::Headers->new(@$header); - } - else { - $header = $header->clone; - } +sub new { + my ( $class, $header, $content ) = @_; + if ( defined $header ) { + Carp::croak("Bad header argument") unless ref $header; + if ( ref($header) eq "ARRAY" ) { + $header = HTTP::Headers->new(@$header); + } + else { + $header = $header->clone; + } } else { - $header = HTTP::Headers->new; + $header = HTTP::Headers->new; } - if (defined $content) { + if ( defined $content ) { _utf8_downgrade($content); } else { @@ -53,46 +53,44 @@ sub new } bless { - '_headers' => $header, - '_content' => $content, - '_max_body_size' => $HTTP::Message::MAXIMUM_BODY_SIZE, + '_headers' => $header, + '_content' => $content, + '_max_body_size' => $HTTP::Message::MAXIMUM_BODY_SIZE, }, $class; } -sub parse -{ - my($class, $str) = @_; +sub parse { + my ( $class, $str ) = @_; my @hdr; while (1) { - if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) { - push(@hdr, $1, $2); - $hdr[-1] =~ s/\r\z//; - } - elsif (@hdr && $str =~ s/^([ \t].*)\n?//) { - $hdr[-1] .= "\n$1"; - $hdr[-1] =~ s/\r\z//; - } - else { - $str =~ s/^\r?\n//; - last; - } + if ( $str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?// ) { + push( @hdr, $1, $2 ); + $hdr[-1] =~ s/\r\z//; + } + elsif ( @hdr && $str =~ s/^([ \t].*)\n?// ) { + $hdr[-1] .= "\n$1"; + $hdr[-1] =~ s/\r\z//; + } + else { + $str =~ s/^\r?\n//; + last; + } } local $HTTP::Headers::TRANSLATE_UNDERSCORE; - new($class, \@hdr, $str); + new( $class, \@hdr, $str ); } - -sub clone -{ +sub clone { my $self = shift; - my $clone = HTTP::Message->new($self->headers, - $self->content); - $clone->protocol($self->protocol); + my $clone = HTTP::Message->new( + $self->headers, + $self->content + ); + $clone->protocol( $self->protocol ); $clone; } - sub clear { my $self = shift; $self->{_headers}->clear; @@ -101,9 +99,8 @@ sub clear { return; } - sub protocol { - shift->_elem('_protocol', @_); + shift->_elem( '_protocol', @_ ); } sub headers { @@ -120,169 +117,176 @@ sub headers_as_string { shift->headers->as_string(@_); } - -sub content { +sub content { my $self = $_[0]; - if (defined(wantarray)) { - $self->_content unless exists $self->{_content}; - my $old = $self->{_content}; - $old = $$old if ref($old) eq "SCALAR"; - &_set_content if @_ > 1; - return $old; + if ( defined(wantarray) ) { + $self->_content unless exists $self->{_content}; + my $old = $self->{_content}; + $old = $$old if ref($old) eq "SCALAR"; + &_set_content if @_ > 1; + return $old; } - if (@_ > 1) { - &_set_content; + if ( @_ > 1 ) { + &_set_content; } else { - Carp::carp("Useless content call in void context") if $^W; + Carp::carp("Useless content call in void context") if $^W; } } - sub _set_content { my $self = $_[0]; - _utf8_downgrade($_[1]); - if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") { - ${$self->{_content}} = defined( $_[1] ) ? $_[1] : ''; + _utf8_downgrade( $_[1] ); + if ( !ref( $_[1] ) && ref( $self->{_content} ) eq "SCALAR" ) { + ${ $self->{_content} } = defined( $_[1] ) ? $_[1] : ''; } else { - die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR"; - $self->{_content} = defined( $_[1] ) ? $_[1] : ''; - delete $self->{_content_ref}; + die "Can't set content to be a scalar reference" + if ref( $_[1] ) eq "SCALAR"; + $self->{_content} = defined( $_[1] ) ? $_[1] : ''; + delete $self->{_content_ref}; } delete $self->{_parts} unless $_[2]; } - -sub add_content -{ +sub add_content { my $self = shift; $self->_content unless exists $self->{_content}; my $chunkref = \$_[0]; - $chunkref = $$chunkref if ref($$chunkref); # legacy + $chunkref = $$chunkref if ref($$chunkref); # legacy _utf8_downgrade($$chunkref); - my $ref = ref($self->{_content}); - if (!$ref) { - $self->{_content} .= $$chunkref; + my $ref = ref( $self->{_content} ); + if ( !$ref ) { + $self->{_content} .= $$chunkref; } - elsif ($ref eq "SCALAR") { - ${$self->{_content}} .= $$chunkref; + elsif ( $ref eq "SCALAR" ) { + ${ $self->{_content} } .= $$chunkref; } else { - Carp::croak("Can't append to $ref content"); + Carp::croak("Can't append to $ref content"); } delete $self->{_parts}; } sub add_content_utf8 { - my($self, $buf) = @_; + my ( $self, $buf ) = @_; utf8::upgrade($buf); utf8::encode($buf); $self->add_content($buf); } -sub content_ref -{ +sub content_ref { my $self = shift; $self->_content unless exists $self->{_content}; delete $self->{_parts}; - my $old = \$self->{_content}; + my $old = \$self->{_content}; my $old_cref = $self->{_content_ref}; if (@_) { - my $new = shift; - Carp::croak("Setting content_ref to a non-ref") unless ref($new); - delete $self->{_content}; # avoid modifying $$old - $self->{_content} = $new; - $self->{_content_ref}++; + my $new = shift; + Carp::croak("Setting content_ref to a non-ref") unless ref($new); + delete $self->{_content}; # avoid modifying $$old + $self->{_content} = $new; + $self->{_content_ref}++; } $old = $$old if $old_cref; return $old; } - -sub content_charset -{ +sub content_charset { my $self = shift; - if (my $charset = $self->content_type_charset) { - return $charset; + if ( my $charset = $self->content_type_charset ) { + return $charset; } # time to start guessing - my $cref = $self->decoded_content(ref => 1, charset => "none"); + my $cref = $self->decoded_content( ref => 1, charset => "none" ); # Unicode BOM for ($$cref) { - return "UTF-8" if /^\xEF\xBB\xBF/; - return "UTF-32LE" if /^\xFF\xFE\x00\x00/; - return "UTF-32BE" if /^\x00\x00\xFE\xFF/; - return "UTF-16LE" if /^\xFF\xFE/; - return "UTF-16BE" if /^\xFE\xFF/; + return "UTF-8" if /^\xEF\xBB\xBF/; + return "UTF-32LE" if /^\xFF\xFE\x00\x00/; + return "UTF-32BE" if /^\x00\x00\xFE\xFF/; + return "UTF-16LE" if /^\xFF\xFE/; + return "UTF-16BE" if /^\xFE\xFF/; } - if ($self->content_is_xml) { - # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing - # XML entity not accompanied by external encoding information and not - # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, - # in which the first characters must be ')/) { - if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) { - my $enc = $2; - $enc =~ s/^\s+//; $enc =~ s/\s+\z//; - return $enc if $enc; - } - } - } - return "UTF-8"; + if ( $self->content_is_xml ) { + + # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing + # XML entity not accompanied by external encoding information and not + # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, + # in which the first characters must be ')/) { + if ( $1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/ ) { + my $enc = $2; + $enc =~ s/^\s+//; + $enc =~ s/\s+\z//; + return $enc if $enc; + } + } + } + return "UTF-8"; } - elsif ($self->content_is_html) { - # look for or - # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding - require IO::HTML; - # Use relaxed search to match previous versions of HTTP::Message: - my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1, - need_pragma => 0 }); - return $encoding->mime_name if $encoding; + elsif ( $self->content_is_html ) { + + # look for or + # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding + require IO::HTML; + + # Use relaxed search to match previous versions of HTTP::Message: + my $encoding = IO::HTML::find_charset_in( + $$cref, + { + encoding => 1, + need_pragma => 0 + } + ); + return $encoding->mime_name if $encoding; } - elsif ($self->content_type eq "application/json") { - for ($$cref) { - # RFC 4627, ch 3 - return "UTF-32BE" if /^\x00\x00\x00./s; - return "UTF-32LE" if /^.\x00\x00\x00/s; - return "UTF-16BE" if /^\x00.\x00./s; - return "UTF-16LE" if /^.\x00.\x00/s; - return "UTF-8"; - } + elsif ( $self->content_type eq "application/json" ) { + for ($$cref) { + + # RFC 4627, ch 3 + return "UTF-32BE" if /^\x00\x00\x00./s; + return "UTF-32LE" if /^.\x00\x00\x00/s; + return "UTF-16BE" if /^\x00.\x00./s; + return "UTF-16LE" if /^.\x00.\x00/s; + return "UTF-8"; + } } - if ($self->content_type =~ /^text\//) { - for ($$cref) { - if (length) { - return "US-ASCII" unless /[\x80-\xFF]/; - require Encode; - eval { - Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC()); - }; - return "UTF-8" unless $@; - return "ISO-8859-1"; - } - } + if ( $self->content_type =~ /^text\// ) { + for ($$cref) { + if (length) { + return "US-ASCII" unless /[\x80-\xFF]/; + require Encode; + eval { + Encode::decode_utf8( + $_, + Encode::FB_CROAK() | Encode::LEAVE_SRC() + ); + }; + return "UTF-8" unless $@; + return "ISO-8859-1"; + } + } } return undef; } -sub max_body_size { +sub max_body_size { my $self = $_[0]; - my $old = $self->{_max_body_size}; - $self->_set_max_body_size($_[1]) if @_ > 1; + my $old = $self->{_max_body_size}; + $self->_set_max_body_size( $_[1] ) if @_ > 1; return $old; } @@ -291,368 +295,411 @@ sub _set_max_body_size { $self->{_max_body_size} = $_[1]; } -sub decoded_content -{ - my($self, %opt) = @_; +sub decoded_content { + my ( $self, %opt ) = @_; my $content_ref; my $content_ref_iscopy; eval { - $content_ref = $self->content_ref; - die "Can't decode ref content" if ref($content_ref) ne "SCALAR"; - - my $content_limit = exists $opt{ max_body_size } ? $opt{ max_body_size } - : defined $self->max_body_size ? $self->max_body_size - : undef - ; - my %limiter_options; - if( defined $content_limit ) { - %limiter_options = (LimitOutput => 1, Bufsize => $content_limit); - }; - if (my $h = $self->header("Content-Encoding")) { - $h =~ s/^\s+//; - $h =~ s/\s+$//; - for my $ce (reverse split(/\s*,\s*/, lc($h))) { - next unless $ce; - next if $ce eq "identity" || $ce eq "none"; - if ($ce eq "gzip" || $ce eq "x-gzip") { - require Compress::Raw::Zlib; # 'WANT_GZIP_OR_ZLIB', 'Z_BUF_ERROR'; - - if( ! $content_ref_iscopy and keys %limiter_options) { - # Create a copy of the input because Zlib will overwrite it - # :-( - my $input = "$$content_ref"; - $content_ref = \$input; - $content_ref_iscopy++; - }; - my ($i, $status) = Compress::Raw::Zlib::Inflate->new( - %limiter_options, - ConsumeInput => 0, # overridden by Zlib if we have %limiter_options :-( - WindowBits => Compress::Raw::Zlib::WANT_GZIP_OR_ZLIB(), - ); - my $res = $i->inflate( $content_ref, \my $output ); - $res == Compress::Raw::Zlib::Z_BUF_ERROR() - and Carp::croak("Decoded content would be larger than $content_limit octets"); - $res == Compress::Raw::Zlib::Z_OK() - or $res == Compress::Raw::Zlib::Z_STREAM_END() - or die "Can't gunzip content: $res"; - $content_ref = \$output; - $content_ref_iscopy++; - } - elsif ($ce eq 'br') { - require IO::Uncompress::Brotli; - my $bro = IO::Uncompress::Brotli->create; - - my $output; - if( defined $content_limit ) { - $output = eval { $bro->decompress( $$content_ref, $content_limit ); } - } else { - $output = eval { $bro->decompress($$content_ref) }; - } - - $@ and die "Can't unbrotli content: $@"; - $content_ref = \$output; - $content_ref_iscopy++; - } - elsif ($ce eq "x-bzip2" or $ce eq "bzip2") { - require Compress::Raw::Bzip2; - - if( ! $content_ref_iscopy ) { - # Create a copy of the input because Bzlib2 will overwrite it - # :-( - my $input = "$$content_ref"; - $content_ref = \$input; - $content_ref_iscopy++; - }; - my ($i, $status) = Compress::Raw::Bunzip2->new( - 1, # appendInput - 0, # consumeInput - 0, # small - $limiter_options{ LimitOutput } || 0, - ); - my $output; - $output = "\0" x $limiter_options{ Bufsize } - if $limiter_options{ Bufsize }; - my $res = $i->bzinflate( $content_ref, \$output ); - $res == Compress::Raw::Bzip2::BZ_OUTBUFF_FULL() - and Carp::croak("Decoded content would be larger than $content_limit octets"); - $res == Compress::Raw::Bzip2::BZ_OK() - or $res == Compress::Raw::Bzip2::BZ_STREAM_END() - or die "Can't bunzip content: $res"; - $content_ref = \$output; - $content_ref_iscopy++; - } - elsif ($ce eq "deflate") { - require IO::Uncompress::Inflate; - my $output; - my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0); - my $error = $IO::Uncompress::Inflate::InflateError; - unless ($status) { - # "Content-Encoding: deflate" is supposed to mean the - # "zlib" format of RFC 1950, but Microsoft got that - # wrong, so some servers sends the raw compressed - # "deflate" data. This tries to inflate this format. - $output = undef; - require IO::Uncompress::RawInflate; - unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) { - $self->push_header("Client-Warning" => - "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError"); - $output = undef; - } - } - die "Can't inflate content: $error" unless defined $output; - $content_ref = \$output; - $content_ref_iscopy++; - } - elsif ($ce eq "compress" || $ce eq "x-compress") { - die "Can't uncompress content"; - } - elsif ($ce eq "base64") { # not really C-T-E, but should be harmless - require MIME::Base64; - $content_ref = \MIME::Base64::decode($$content_ref); - $content_ref_iscopy++; - } - elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless - require MIME::QuotedPrint; - $content_ref = \MIME::QuotedPrint::decode($$content_ref); - $content_ref_iscopy++; - } - else { - die "Don't know how to decode Content-Encoding '$ce'"; - } - } - } - - if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) { - my $charset = lc( - $opt{charset} || - $self->content_type_charset || - $opt{default_charset} || - $self->content_charset || - "ISO-8859-1" - ); - if ($charset eq "none") { - # leave it as is - } - elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") { - if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) { - unless ($content_ref_iscopy) { - my $copy = $$content_ref; - $content_ref = \$copy; - $content_ref_iscopy++; - } - utf8::upgrade($$content_ref); - } - } - else { - require Encode; - eval { - $content_ref = \Encode::decode($charset, $$content_ref, - ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()); - }; - if ($@) { - my $retried; - if ($@ =~ /^Unknown encoding/) { - my $alt_charset = lc($opt{alt_charset} || ""); - if ($alt_charset && $charset ne $alt_charset) { - # Retry decoding with the alternative charset - $content_ref = \Encode::decode($alt_charset, $$content_ref, - ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()) - unless $alt_charset eq "none"; - $retried++; - } - } - die unless $retried; - } - die "Encode::decode() returned undef improperly" unless defined $$content_ref; - if ($is_xml) { - # Get rid of the XML encoding declaration if present - $$content_ref =~ s/^\x{FEFF}//; - if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) { - substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//; - } - } - } - } + $content_ref = $self->content_ref; + die "Can't decode ref content" if ref($content_ref) ne "SCALAR"; + + my $content_limit + = exists $opt{max_body_size} ? $opt{max_body_size} + : defined $self->max_body_size ? $self->max_body_size + : undef; + my %limiter_options; + if ( defined $content_limit ) { + %limiter_options + = ( LimitOutput => 1, Bufsize => $content_limit ); + } + if ( my $h = $self->header("Content-Encoding") ) { + $h =~ s/^\s+//; + $h =~ s/\s+$//; + for my $ce ( reverse split( /\s*,\s*/, lc($h) ) ) { + next unless $ce; + next if $ce eq "identity" || $ce eq "none"; + if ( $ce eq "gzip" || $ce eq "x-gzip" ) { + require Compress::Raw::Zlib + ; # 'WANT_GZIP_OR_ZLIB', 'Z_BUF_ERROR'; + + if ( !$content_ref_iscopy and keys %limiter_options ) { + + # Create a copy of the input because Zlib will overwrite it + # :-( + my $input = "$$content_ref"; + $content_ref = \$input; + $content_ref_iscopy++; + } + my ( $i, $status ) = Compress::Raw::Zlib::Inflate->new( + %limiter_options, + ConsumeInput => 0 + , # overridden by Zlib if we have %limiter_options :-( + WindowBits => + Compress::Raw::Zlib::WANT_GZIP_OR_ZLIB(), + ); + my $res = $i->inflate( $content_ref, \my $output ); + $res == Compress::Raw::Zlib::Z_BUF_ERROR() + and Carp::croak( + "Decoded content would be larger than $content_limit octets" + ); + $res == Compress::Raw::Zlib::Z_OK() + or $res == Compress::Raw::Zlib::Z_STREAM_END() + or die "Can't gunzip content: $res"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ( $ce eq 'br' ) { + require IO::Uncompress::Brotli; + my $bro = IO::Uncompress::Brotli->create; + + my $output; + if ( defined $content_limit ) { + $output = eval { + $bro->decompress( $$content_ref, $content_limit ); + } + } + else { + $output = eval { $bro->decompress($$content_ref) }; + } + + $@ and die "Can't unbrotli content: $@"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ( $ce eq "x-bzip2" or $ce eq "bzip2" ) { + require Compress::Raw::Bzip2; + + if ( !$content_ref_iscopy ) { + + # Create a copy of the input because Bzlib2 will overwrite it + # :-( + my $input = "$$content_ref"; + $content_ref = \$input; + $content_ref_iscopy++; + } + my ( $i, $status ) = Compress::Raw::Bunzip2->new( + 1, # appendInput + 0, # consumeInput + 0, # small + $limiter_options{LimitOutput} || 0, + ); + my $output; + $output = "\0" x $limiter_options{Bufsize} + if $limiter_options{Bufsize}; + my $res = $i->bzinflate( $content_ref, \$output ); + $res == Compress::Raw::Bzip2::BZ_OUTBUFF_FULL() + and Carp::croak( + "Decoded content would be larger than $content_limit octets" + ); + $res == Compress::Raw::Bzip2::BZ_OK() + or $res == Compress::Raw::Bzip2::BZ_STREAM_END() + or die "Can't bunzip content: $res"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ( $ce eq "deflate" ) { + require IO::Uncompress::Inflate; + my $output; + my $status = IO::Uncompress::Inflate::inflate( + $content_ref, + \$output, Transparent => 0 + ); + my $error = $IO::Uncompress::Inflate::InflateError; + unless ($status) { + + # "Content-Encoding: deflate" is supposed to mean the + # "zlib" format of RFC 1950, but Microsoft got that + # wrong, so some servers sends the raw compressed + # "deflate" data. This tries to inflate this format. + $output = undef; + require IO::Uncompress::RawInflate; + unless ( + IO::Uncompress::RawInflate::rawinflate( + $content_ref, \$output + ) + ) { + $self->push_header( "Client-Warning" => + "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError" + ); + $output = undef; + } + } + die "Can't inflate content: $error" + unless defined $output; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ( $ce eq "compress" || $ce eq "x-compress" ) { + die "Can't uncompress content"; + } + elsif ( $ce eq "base64" ) + { # not really C-T-E, but should be harmless + require MIME::Base64; + $content_ref = \MIME::Base64::decode($$content_ref); + $content_ref_iscopy++; + } + elsif ( $ce eq "quoted-printable" ) + { # not really C-T-E, but should be harmless + require MIME::QuotedPrint; + $content_ref = \MIME::QuotedPrint::decode($$content_ref); + $content_ref_iscopy++; + } + else { + die "Don't know how to decode Content-Encoding '$ce'"; + } + } + } + + if ( $self->content_is_text + || ( my $is_xml = $self->content_is_xml ) ) { + my $charset + = lc( $opt{charset} + || $self->content_type_charset + || $opt{default_charset} + || $self->content_charset + || "ISO-8859-1" ); + if ( $charset eq "none" ) { + + # leave it as is + } + elsif ( $charset eq "us-ascii" || $charset eq "iso-8859-1" ) { + if ( $$content_ref =~ /[^\x00-\x7F]/ + && defined &utf8::upgrade ) { + unless ($content_ref_iscopy) { + my $copy = $$content_ref; + $content_ref = \$copy; + $content_ref_iscopy++; + } + utf8::upgrade($$content_ref); + } + } + else { + require Encode; + eval { + $content_ref = \Encode::decode( + $charset, $$content_ref, + ( $opt{charset_strict} ? Encode::FB_CROAK() : 0 ) + | Encode::LEAVE_SRC() + ); + }; + if ($@) { + my $retried; + if ( $@ =~ /^Unknown encoding/ ) { + my $alt_charset = lc( $opt{alt_charset} || "" ); + if ( $alt_charset && $charset ne $alt_charset ) { + + # Retry decoding with the alternative charset + $content_ref = \Encode::decode( + $alt_charset, $$content_ref, + ( + $opt{charset_strict} + ? Encode::FB_CROAK() + : 0 + ) | Encode::LEAVE_SRC() + ) unless $alt_charset eq "none"; + $retried++; + } + } + die unless $retried; + } + die "Encode::decode() returned undef improperly" + unless defined $$content_ref; + if ($is_xml) { + + # Get rid of the XML encoding declaration if present + $$content_ref =~ s/^\x{FEFF}//; + if ( $$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/ ) { + substr( $$content_ref, 0, length($1) ) + =~ s/\sencoding\s*=\s*(["']).*?\1//; + } + } + } + } }; if ($@) { - Carp::croak($@) if $opt{raise_error}; - return undef; + Carp::croak($@) if $opt{raise_error}; + return undef; } return $opt{ref} ? $content_ref : $$content_ref; } +sub decodable { -sub decodable -{ # should match the Content-Encoding values that decoded_content can deal with my $self = shift; my @enc; local $@; + # XXX preferably we should determine if the modules are available without loading # them here eval { require Compress::Raw::Zlib; - push(@enc, "gzip", "x-gzip"); + push( @enc, "gzip", "x-gzip" ); }; eval { require IO::Uncompress::Inflate; require IO::Uncompress::RawInflate; - push(@enc, "deflate"); + push( @enc, "deflate" ); }; eval { require Compress::Raw::Bzip2; - push(@enc, "x-bzip2", "bzip2"); + push( @enc, "x-bzip2", "bzip2" ); }; eval { require IO::Uncompress::Brotli; - push(@enc, 'br'); + push( @enc, 'br' ); }; + # we don't care about announcing the 'identity', 'base64' and # 'quoted-printable' stuff - return wantarray ? @enc : join(", ", @enc); + return wantarray ? @enc : join( ", ", @enc ); } - -sub decode -{ +sub decode { my $self = shift; return 1 unless $self->header("Content-Encoding"); - if (defined(my $content = $self->decoded_content(charset => "none"))) { - $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5"); - $self->content($content); - return 1; + if ( + defined( my $content = $self->decoded_content( charset => "none" ) ) ) + { + $self->remove_header( + "Content-Encoding", "Content-Length", + "Content-MD5" + ); + $self->content($content); + return 1; } return 0; } +sub encode { + my ( $self, @enc ) = @_; -sub encode -{ - my($self, @enc) = @_; + Carp::croak("Can't encode multipart/* messages") + if $self->content_type =~ m,^multipart/,; + Carp::croak("Can't encode message/* messages") + if $self->content_type =~ m,^message/,; - Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,; - Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,; - - return 1 unless @enc; # nothing to do + return 1 unless @enc; # nothing to do my $content = $self->content; for my $encoding (@enc) { - if ($encoding eq "identity" || $encoding eq "none") { - # nothing to do - } - elsif ($encoding eq "base64") { - require MIME::Base64; - $content = MIME::Base64::encode($content); - } - elsif ($encoding eq "gzip" || $encoding eq "x-gzip") { - require IO::Compress::Gzip; - my $output; - IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1) - or die "Can't gzip content: $IO::Compress::Gzip::GzipError"; - $content = $output; - } - elsif ($encoding eq "deflate") { - require IO::Compress::Deflate; - my $output; - IO::Compress::Deflate::deflate(\$content, \$output) - or die "Can't deflate content: $IO::Compress::Deflate::DeflateError"; - $content = $output; - } - elsif ($encoding eq "x-bzip2" || $encoding eq "bzip2") { - require IO::Compress::Bzip2; - my $output; - IO::Compress::Bzip2::bzip2(\$content, \$output) - or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error"; - $content = $output; - } - elsif ($encoding eq "br") { - require IO::Compress::Brotli; - my $output; - eval { $output = IO::Compress::Brotli::bro($content) } - or die "Can't brotli content: $@"; - $content = $output; - } - elsif ($encoding eq "rot13") { # for the fun of it - $content =~ tr/A-Za-z/N-ZA-Mn-za-m/; - } - else { - return 0; - } + if ( $encoding eq "identity" || $encoding eq "none" ) { + + # nothing to do + } + elsif ( $encoding eq "base64" ) { + require MIME::Base64; + $content = MIME::Base64::encode($content); + } + elsif ( $encoding eq "gzip" || $encoding eq "x-gzip" ) { + require IO::Compress::Gzip; + my $output; + IO::Compress::Gzip::gzip( \$content, \$output, Minimal => 1 ) + or die "Can't gzip content: $IO::Compress::Gzip::GzipError"; + $content = $output; + } + elsif ( $encoding eq "deflate" ) { + require IO::Compress::Deflate; + my $output; + IO::Compress::Deflate::deflate( \$content, \$output ) + or die + "Can't deflate content: $IO::Compress::Deflate::DeflateError"; + $content = $output; + } + elsif ( $encoding eq "x-bzip2" || $encoding eq "bzip2" ) { + require IO::Compress::Bzip2; + my $output; + IO::Compress::Bzip2::bzip2( \$content, \$output ) + or die + "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error"; + $content = $output; + } + elsif ( $encoding eq "br" ) { + require IO::Compress::Brotli; + my $output; + eval { $output = IO::Compress::Brotli::bro($content) } + or die "Can't brotli content: $@"; + $content = $output; + } + elsif ( $encoding eq "rot13" ) { # for the fun of it + $content =~ tr/A-Za-z/N-ZA-Mn-za-m/; + } + else { + return 0; + } } my $h = $self->header("Content-Encoding"); - unshift(@enc, $h) if $h; - $self->header("Content-Encoding", join(", ", @enc)); - $self->remove_header("Content-Length", "Content-MD5"); + unshift( @enc, $h ) if $h; + $self->header( "Content-Encoding", join( ", ", @enc ) ); + $self->remove_header( "Content-Length", "Content-MD5" ); $self->content($content); return 1; } - -sub as_string -{ - my($self, $eol) = @_; +sub as_string { + my ( $self, $eol ) = @_; $eol = "\n" unless defined $eol; # The calculation of content might update the headers # so we need to do that first. my $content = $self->content; - return join("", $self->{'_headers'}->as_string($eol), - $eol, - $content, - (@_ == 1 && length($content) && - $content !~ /\n\z/) ? "\n" : "", - ); + return join( + "", $self->{'_headers'}->as_string($eol), + $eol, + $content, + ( @_ == 1 && length($content) && $content !~ /\n\z/ ) ? "\n" : "", + ); } - -sub dump -{ - my($self, %opt) = @_; +sub dump { + my ( $self, %opt ) = @_; my $content = $self->content; my $chopped = 0; - if (!ref($content)) { - my $maxlen = $opt{maxlength}; - $maxlen = 512 unless defined($maxlen); - if ($maxlen && length($content) > $maxlen * 1.1 + 3) { - $chopped = length($content) - $maxlen; - $content = substr($content, 0, $maxlen) . "..."; - } - - $content =~ s/\\/\\\\/g; - $content =~ s/\t/\\t/g; - $content =~ s/\r/\\r/g; - - # no need for 3 digits in escape for these - $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; - - $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; - $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg; - - # remaining whitespace - $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg; - $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; - $content =~ s/\n\z/\\n/; - - my $no_content = $opt{no_content}; - $no_content = "(no content)" unless defined $no_content; - if ($content eq $no_content) { - # escape our $no_content marker - $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; - } - elsif ($content eq "") { - $content = $no_content; - } + if ( !ref($content) ) { + my $maxlen = $opt{maxlength}; + $maxlen = 512 unless defined($maxlen); + if ( $maxlen && length($content) > $maxlen * 1.1 + 3 ) { + $chopped = length($content) - $maxlen; + $content = substr( $content, 0, $maxlen ) . "..."; + } + + $content =~ s/\\/\\\\/g; + $content =~ s/\t/\\t/g; + $content =~ s/\r/\\r/g; + + # no need for 3 digits in escape for these + $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + + $content + =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg; + + # remaining whitespace + $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg; + $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; + $content =~ s/\n\z/\\n/; + + my $no_content = $opt{no_content}; + $no_content = "(no content)" unless defined $no_content; + if ( $content eq $no_content ) { + + # escape our $no_content marker + $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; + } + elsif ( $content eq "" ) { + $content = $no_content; + } } my @dump; - push(@dump, $opt{preheader}) if $opt{preheader}; - push(@dump, $self->{_headers}->as_string, $content); - push(@dump, "(+ $chopped more bytes not shown)") if $chopped; + push( @dump, $opt{preheader} ) if $opt{preheader}; + push( @dump, $self->{_headers}->as_string, $content ); + push( @dump, "(+ $chopped more bytes not shown)" ) if $chopped; - my $dump = join("\n", @dump, ""); + my $dump = join( "\n", @dump, "" ); $dump =~ s/^/$opt{prefix}/gm if $opt{prefix}; print $dump unless defined wantarray; @@ -666,23 +713,26 @@ sub _part_class { sub parts { my $self = shift; - if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) { - $self->_parts; + if ( + defined(wantarray) + && ( !exists $self->{_parts} || ref( $self->{_content} ) eq "SCALAR" ) + ) { + $self->_parts; } my $old = $self->{_parts}; if (@_) { - my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; - my $ct = $self->content_type || ""; - if ($ct =~ m,^message/,) { - Carp::croak("Only one part allowed for $ct content") - if @parts > 1; - } - elsif ($ct !~ m,^multipart/,) { - $self->remove_content_headers; - $self->content_type("multipart/mixed"); - } - $self->{_parts} = \@parts; - _stale_content($self); + my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; + my $ct = $self->content_type || ""; + if ( $ct =~ m,^message/, ) { + Carp::croak("Only one part allowed for $ct content") + if @parts > 1; + } + elsif ( $ct !~ m,^multipart/, ) { + $self->remove_content_headers; + $self->content_type("multipart/mixed"); + } + $self->{_parts} = \@parts; + _stale_content($self); } return @$old if wantarray; return $old->[0]; @@ -690,36 +740,38 @@ sub parts { sub add_part { my $self = shift; - if (($self->content_type || "") !~ m,^multipart/,) { - my $p = $self->_part_class->new( - $self->remove_content_headers, - $self->content(""), - ); - $self->content_type("multipart/mixed"); - $self->{_parts} = []; - if ($p->headers->header_field_names || $p->content ne "") { - push(@{$self->{_parts}}, $p); + if ( ( $self->content_type || "" ) !~ m,^multipart/, ) { + my $p = $self->_part_class->new( + $self->remove_content_headers, + $self->content(""), + ); + $self->content_type("multipart/mixed"); + $self->{_parts} = []; + if ( $p->headers->header_field_names || $p->content ne "" ) { + push( @{ $self->{_parts} }, $p ); } } - elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") { - $self->_parts; + elsif ( !exists $self->{_parts} || ref( $self->{_content} ) eq "SCALAR" ) + { + $self->_parts; } - push(@{$self->{_parts}}, @_); + push( @{ $self->{_parts} }, @_ ); _stale_content($self); return; } sub _stale_content { my $self = shift; - if (ref($self->{_content}) eq "SCALAR") { - # must recalculate now - $self->_content; + if ( ref( $self->{_content} ) eq "SCALAR" ) { + + # must recalculate now + $self->_content; } else { - # just invalidate cache - delete $self->{_content}; - delete $self->{_content_ref}; + # just invalidate cache + delete $self->{_content}; + delete $self->{_content_ref}; } } @@ -761,120 +813,122 @@ sub can { sub DESTROY { } # avoid AUTOLOADing it # Private method to access members in %$self -sub _elem -{ +sub _elem { my $self = shift; my $elem = shift; - my $old = $self->{$elem}; + my $old = $self->{$elem}; $self->{$elem} = $_[0] if @_; return $old; } - # Create private _parts attribute from current _content sub _parts { my $self = shift; - my $ct = $self->content_type; - if ($ct =~ m,^multipart/,) { - require HTTP::Headers::Util; - my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type")); - die "Assert" unless @h; - my %h = @{$h[0]}; - if (defined(my $b = $h{boundary})) { - my $str = $self->content; - $str =~ s/\r?\n--\Q$b\E--.*//s; - if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) { - $self->{_parts} = [map $self->_part_class->parse($_), - split(/\r?\n--\Q$b\E\r?\n/, $str)] - } - } + my $ct = $self->content_type; + if ( $ct =~ m,^multipart/, ) { + require HTTP::Headers::Util; + my @h = HTTP::Headers::Util::split_header_words( + $self->header("Content-Type") ); + die "Assert" unless @h; + my %h = @{ $h[0] }; + if ( defined( my $b = $h{boundary} ) ) { + my $str = $self->content; + $str =~ s/\r?\n--\Q$b\E--.*//s; + if ( $str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s ) { + $self->{_parts} = [ + map $self->_part_class->parse($_), + split( /\r?\n--\Q$b\E\r?\n/, $str ) + ]; + } + } } - elsif ($ct eq "message/http") { - require HTTP::Request; - require HTTP::Response; - my $content = $self->content; - my $class = ($content =~ m,^(HTTP/.*)\n,) ? - "HTTP::Response" : "HTTP::Request"; - $self->{_parts} = [$class->parse($content)]; + elsif ( $ct eq "message/http" ) { + require HTTP::Request; + require HTTP::Response; + my $content = $self->content; + my $class + = ( $content =~ m,^(HTTP/.*)\n, ) + ? "HTTP::Response" + : "HTTP::Request"; + $self->{_parts} = [ $class->parse($content) ]; } - elsif ($ct =~ m,^message/,) { - $self->{_parts} = [ $self->_part_class->parse($self->content) ]; + elsif ( $ct =~ m,^message/, ) { + $self->{_parts} = [ $self->_part_class->parse( $self->content ) ]; } $self->{_parts} ||= []; } - # Create private _content attribute from current _parts sub _content { my $self = shift; - my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed"; - if ($ct =~ m,^\s*message/,i) { - _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1); - return; + my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed"; + if ( $ct =~ m,^\s*message/,i ) { + _set_content( $self, $self->{_parts}[0]->as_string($CRLF), 1 ); + return; } require HTTP::Headers::Util; my @v = HTTP::Headers::Util::split_header_words($ct); Carp::carp("Multiple Content-Type headers") if @v > 1; - @v = @{$v[0]}; + @v = @{ $v[0] }; my $boundary; my $boundary_index; - for (my @tmp = @v; @tmp;) { - my($k, $v) = splice(@tmp, 0, 2); - if ($k eq "boundary") { - $boundary = $v; - $boundary_index = @v - @tmp - 1; - last; - } + for ( my @tmp = @v ; @tmp ; ) { + my ( $k, $v ) = splice( @tmp, 0, 2 ); + if ( $k eq "boundary" ) { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } } - my @parts = map $_->as_string($CRLF), @{$self->{_parts}}; + my @parts = map $_->as_string($CRLF), @{ $self->{_parts} }; my $bno = 0; $boundary = _boundary() unless defined $boundary; - CHECK_BOUNDARY: +CHECK_BOUNDARY: { - for (@parts) { - if (index($_, $boundary) >= 0) { - # must have a better boundary - $boundary = _boundary(++$bno); - redo CHECK_BOUNDARY; - } - } + for (@parts) { + if ( index( $_, $boundary ) >= 0 ) { + + # must have a better boundary + $boundary = _boundary( ++$bno ); + redo CHECK_BOUNDARY; + } + } } if ($boundary_index) { - $v[$boundary_index] = $boundary; + $v[$boundary_index] = $boundary; } else { - push(@v, boundary => $boundary); + push( @v, boundary => $boundary ); } $ct = HTTP::Headers::Util::join_header_words(@v); - $self->{_headers}->header("Content-Type", $ct); - - _set_content($self, "--$boundary$CRLF" . - join("$CRLF--$boundary$CRLF", @parts) . - "$CRLF--$boundary--$CRLF", - 1); + $self->{_headers}->header( "Content-Type", $ct ); + + _set_content( + $self, "--$boundary$CRLF" + . join( "$CRLF--$boundary$CRLF", @parts ) + . "$CRLF--$boundary--$CRLF", + 1 + ); } - -sub _boundary -{ +sub _boundary { my $size = shift || return "xYzZY"; require MIME::Base64; - my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); - $b =~ s/[\W]/X/g; # ensure alnum only + my $b = MIME::Base64::encode( + join( "", map chr( rand(256) ), 1 .. $size * 3 ), "" ); + $b =~ s/[\W]/X/g; # ensure alnum only $b; } - 1; - __END__ =pod diff --git a/lib/HTTP/Request.pm b/lib/HTTP/Request.pm index f4f483a9..48882737 100644 --- a/lib/HTTP/Request.pm +++ b/lib/HTTP/Request.pm @@ -7,95 +7,89 @@ our $VERSION = '7.01'; use parent 'HTTP::Message'; -sub new -{ - my($class, $method, $uri, $header, $content) = @_; - my $self = $class->SUPER::new($header, $content); +sub new { + my ( $class, $method, $uri, $header, $content ) = @_; + my $self = $class->SUPER::new( $header, $content ); $self->method($method); $self->uri($uri); $self; } - -sub parse -{ - my($class, $str) = @_; - Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; +sub parse { + my ( $class, $str ) = @_; + Carp::carp('Undefined argument to parse()') if $^W && !defined $str; my $request_line; - if (defined $str && $str =~ s/^(.*)\n//) { - $request_line = $1; + if ( defined $str && $str =~ s/^(.*)\n// ) { + $request_line = $1; } else { - $request_line = $str; - $str = ""; + $request_line = $str; + $str = ""; } my $self = $class->SUPER::parse($str); - if (defined $request_line) { - my($method, $uri, $protocol) = split(' ', $request_line); + if ( defined $request_line ) { + my ( $method, $uri, $protocol ) = split( ' ', $request_line ); $self->method($method); - $self->uri($uri) if defined($uri); + $self->uri($uri) if defined($uri); $self->protocol($protocol) if $protocol; } $self; } - -sub clone -{ - my $self = shift; +sub clone { + my $self = shift; my $clone = bless $self->SUPER::clone, ref($self); - $clone->method($self->method); - $clone->uri($self->uri); + $clone->method( $self->method ); + $clone->uri( $self->uri ); $clone; } - -sub method -{ - shift->_elem('_method', @_); +sub method { + shift->_elem( '_method', @_ ); } - -sub uri -{ +sub uri { my $self = shift; - my $old = $self->{'_uri'}; + my $old = $self->{'_uri'}; if (@_) { - my $uri = shift; - if (!defined $uri) { - # that's ok - } - elsif (ref $uri) { - Carp::croak("A URI can't be a " . ref($uri) . " reference") - if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; - Carp::croak("Can't use a " . ref($uri) . " object as a URI") - unless $uri->can('scheme') && $uri->can('canonical'); - $uri = $uri->clone; - unless ($HTTP::URI_CLASS eq "URI") { - # Argh!! Hate this... old LWP legacy! - eval { local $SIG{__DIE__}; $uri = $uri->abs; }; - die $@ if $@ && $@ !~ /Missing base argument/; - } - } - else { - $uri = $HTTP::URI_CLASS->new($uri); - } - $self->{'_uri'} = $uri; + my $uri = shift; + if ( !defined $uri ) { + + # that's ok + } + elsif ( ref $uri ) { + Carp::croak( "A URI can't be a " . ref($uri) . " reference" ) + if ref($uri) eq 'HASH' + or ref($uri) eq 'ARRAY'; + Carp::croak( "Can't use a " . ref($uri) . " object as a URI" ) + unless $uri->can('scheme') && $uri->can('canonical'); + $uri = $uri->clone; + unless ( $HTTP::URI_CLASS eq "URI" ) { + + # Argh!! Hate this... old LWP legacy! + eval { local $SIG{__DIE__}; $uri = $uri->abs; }; + die $@ if $@ && $@ !~ /Missing base argument/; + } + } + else { + $uri = $HTTP::URI_CLASS->new($uri); + } + $self->{'_uri'} = $uri; delete $self->{'_uri_canonical'}; } $old; } -*url = \&uri; # legacy +*url = \&uri; # legacy -sub uri_canonical -{ +sub uri_canonical { my $self = shift; my $uri = $self->{_uri}; - if (defined (my $canon = $self->{_uri_canonical})) { + if ( defined( my $canon = $self->{_uri_canonical} ) ) { + # early bailout if these are the exact same string; # rely on stringification of the URI objects return $canon if $canon eq $uri; @@ -105,44 +99,39 @@ sub uri_canonical $self->{_uri_canonical} = $uri->canonical; } - -sub accept_decodable -{ +sub accept_decodable { my $self = shift; - $self->header("Accept-Encoding", scalar($self->decodable)); + $self->header( "Accept-Encoding", scalar( $self->decodable ) ); } -sub as_string -{ +sub as_string { my $self = shift; - my($eol) = @_; + my ($eol) = @_; $eol = "\n" unless defined $eol; my $req_line = $self->method || "-"; - my $uri = $self->uri; - $uri = (defined $uri) ? $uri->as_string : "-"; + my $uri = $self->uri; + $uri = ( defined $uri ) ? $uri->as_string : "-"; $req_line .= " $uri"; my $proto = $self->protocol; $req_line .= " $proto" if $proto; - return join($eol, $req_line, $self->SUPER::as_string(@_)); + return join( $eol, $req_line, $self->SUPER::as_string(@_) ); } -sub dump -{ +sub dump { my $self = shift; - my @pre = ($self->method || "-", $self->uri || "-"); - if (my $prot = $self->protocol) { - push(@pre, $prot); + my @pre = ( $self->method || "-", $self->uri || "-" ); + if ( my $prot = $self->protocol ) { + push( @pre, $prot ); } return $self->SUPER::dump( - preheader => join(" ", @pre), - @_, + preheader => join( " ", @pre ), + @_, ); } - 1; __END__ diff --git a/lib/HTTP/Request/Common.pm b/lib/HTTP/Request/Common.pm index 25bb955f..f0eed805 100644 --- a/lib/HTTP/Request/Common.pm +++ b/lib/HTTP/Request/Common.pm @@ -5,298 +5,308 @@ use warnings; our $VERSION = '7.01'; -our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) -our $READ_BUFFER_SIZE = 8192; +our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) +our $READ_BUFFER_SIZE = 8192; use Exporter 5.57 'import'; -our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS); +our @EXPORT = qw(GET HEAD PUT PATCH POST OPTIONS); our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); require HTTP::Request; use Carp(); use File::Spec; -my $CRLF = "\015\012"; # "\r\n" is not portable +my $CRLF = "\015\012"; # "\r\n" is not portable -sub GET { _simple_req('GET', @_); } -sub HEAD { _simple_req('HEAD', @_); } -sub DELETE { _simple_req('DELETE', @_); } -sub PATCH { request_type_with_data('PATCH', @_); } -sub POST { request_type_with_data('POST', @_); } -sub PUT { request_type_with_data('PUT', @_); } -sub OPTIONS { request_type_with_data('OPTIONS', @_); } +sub GET { _simple_req( 'GET', @_ ); } +sub HEAD { _simple_req( 'HEAD', @_ ); } +sub DELETE { _simple_req( 'DELETE', @_ ); } +sub PATCH { request_type_with_data( 'PATCH', @_ ); } +sub POST { request_type_with_data( 'POST', @_ ); } +sub PUT { request_type_with_data( 'PUT', @_ ); } +sub OPTIONS { request_type_with_data( 'OPTIONS', @_ ); } -sub request_type_with_data -{ +sub request_type_with_data { my $type = shift; my $url = shift; - my $req = HTTP::Request->new($type => $url); + my $req = HTTP::Request->new( $type => $url ); my $content; $content = shift if @_ and ref $_[0]; - my($k, $v); - while (($k,$v) = splice(@_, 0, 2)) { - if (lc($k) eq 'content') { - $content = $v; - } - else { - $req->push_header($k, $v); - } + my ( $k, $v ); + while ( ( $k, $v ) = splice( @_, 0, 2 ) ) { + if ( lc($k) eq 'content' ) { + $content = $v; + } + else { + $req->push_header( $k, $v ); + } } my $ct = $req->header('Content-Type'); unless ($ct) { - $ct = 'application/x-www-form-urlencoded'; + $ct = 'application/x-www-form-urlencoded'; } - elsif ($ct eq 'form-data') { - $ct = 'multipart/form-data'; + elsif ( $ct eq 'form-data' ) { + $ct = 'multipart/form-data'; } - if (ref $content) { - if ($ct =~ m,^multipart/form-data\s*(;|$),i) { - require HTTP::Headers::Util; - my @v = HTTP::Headers::Util::split_header_words($ct); - Carp::carp("Multiple Content-Type headers") if @v > 1; - @v = @{$v[0]}; - - my $boundary; - my $boundary_index; - for (my @tmp = @v; @tmp;) { - my($k, $v) = splice(@tmp, 0, 2); - if ($k eq "boundary") { - $boundary = $v; - $boundary_index = @v - @tmp - 1; - last; - } - } - - ($content, $boundary) = form_data($content, $boundary, $req); - - if ($boundary_index) { - $v[$boundary_index] = $boundary; - } - else { - push(@v, boundary => $boundary); - } - - $ct = HTTP::Headers::Util::join_header_words(@v); - } - else { - # We use a temporary URI object to format - # the application/x-www-form-urlencoded content. - require URI; - my $url = URI->new('http:'); - $url->query_form(ref($content) eq "HASH" ? %$content : @$content); - $content = $url->query; - } + if ( ref $content ) { + if ( $ct =~ m,^multipart/form-data\s*(;|$),i ) { + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{ $v[0] }; + + my $boundary; + my $boundary_index; + for ( my @tmp = @v ; @tmp ; ) { + my ( $k, $v ) = splice( @tmp, 0, 2 ); + if ( $k eq "boundary" ) { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + ( $content, $boundary ) = form_data( $content, $boundary, $req ); + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } + else { + push( @v, boundary => $boundary ); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + } + else { + # We use a temporary URI object to format + # the application/x-www-form-urlencoded content. + require URI; + my $url = URI->new('http:'); + $url->query_form( + ref($content) eq "HASH" ? %$content : @$content ); + $content = $url->query; + } } - $req->header('Content-Type' => $ct); # might be redundant - if (defined($content)) { - $req->header('Content-Length' => - length($content)) unless ref($content); - $req->content($content); + $req->header( 'Content-Type' => $ct ); # might be redundant + if ( defined($content) ) { + $req->header( 'Content-Length' => length($content) ) + unless ref($content); + $req->content($content); } else { - $req->header('Content-Length' => 0); + $req->header( 'Content-Length' => 0 ); } $req; } - -sub _simple_req -{ - my($method, $url) = splice(@_, 0, 2); - my $req = HTTP::Request->new($method => $url); - my($k, $v); +sub _simple_req { + my ( $method, $url ) = splice( @_, 0, 2 ); + my $req = HTTP::Request->new( $method => $url ); + my ( $k, $v ); my $content; - while (($k,$v) = splice(@_, 0, 2)) { - if (lc($k) eq 'content') { - $req->add_content($v); + while ( ( $k, $v ) = splice( @_, 0, 2 ) ) { + if ( lc($k) eq 'content' ) { + $req->add_content($v); $content++; - } - else { - $req->push_header($k, $v); - } + } + else { + $req->push_header( $k, $v ); + } } - if ($content && !defined($req->header("Content-Length"))) { - $req->header("Content-Length", length(${$req->content_ref})); + if ( $content && !defined( $req->header("Content-Length") ) ) { + $req->header( "Content-Length", length( ${ $req->content_ref } ) ); } $req; } - -sub form_data # RFC1867 +sub form_data # RFC1867 { - my($data, $boundary, $req) = @_; - my @data = ref($data) eq "HASH" ? %$data : @$data; # copy + my ( $data, $boundary, $req ) = @_; + my @data = ref($data) eq "HASH" ? %$data : @$data; # copy my $fhparts; my @parts; - while (my ($k,$v) = splice(@data, 0, 2)) { - if (!ref($v)) { - $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes + while ( my ( $k, $v ) = splice( @data, 0, 2 ) ) { + if ( !ref($v) ) { + $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes no warnings 'uninitialized'; - push(@parts, - qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); - } - else { - my($file, $usename, @headers) = @$v; - unless (defined $usename) { - $usename = $file; - $usename = (File::Spec->splitpath($usename))[-1] if defined($usename); - } + push( + @parts, + qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v) + ); + } + else { + my ( $file, $usename, @headers ) = @$v; + unless ( defined $usename ) { + $usename = $file; + $usename = ( File::Spec->splitpath($usename) )[-1] + if defined($usename); + } $k =~ s/([\\\"])/\\$1/g; - my $disp = qq(form-data; name="$k"); - if (defined($usename) and length($usename)) { + my $disp = qq(form-data; name="$k"); + if ( defined($usename) and length($usename) ) { $usename =~ s/([\\\"])/\\$1/g; $disp .= qq(; filename="$usename"); } - my $content = ""; - my $h = HTTP::Headers->new(@headers); - if ($file) { - open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!"); - binmode($fh); - if ($DYNAMIC_FILE_UPLOAD) { - # will read file later, close it now in order to + my $content = ""; + my $h = HTTP::Headers->new(@headers); + if ($file) { + open( my $fh, "<", $file ) + or Carp::croak("Can't open file $file: $!"); + binmode($fh); + if ($DYNAMIC_FILE_UPLOAD) { + + # will read file later, close it now in order to # not accumulate to many open file handles close($fh); - $content = \$file; - } - else { - local($/) = undef; # slurp files - $content = <$fh>; - close($fh); - } - unless ($h->header("Content-Type")) { - require LWP::MediaTypes; - LWP::MediaTypes::guess_media_type($file, $h); - } - } - if ($h->header("Content-Disposition")) { - # just to get it sorted first - $disp = $h->header("Content-Disposition"); - $h->remove_header("Content-Disposition"); - } - if ($h->header("Content")) { - $content = $h->header("Content"); - $h->remove_header("Content"); - } - my $head = join($CRLF, "Content-Disposition: $disp", - $h->as_string($CRLF), - ""); - if (ref $content) { - push(@parts, [$head, $$content]); - $fhparts++; - } - else { - push(@parts, $head . $content); - } - } + $content = \$file; + } + else { + local ($/) = undef; # slurp files + $content = <$fh>; + close($fh); + } + unless ( $h->header("Content-Type") ) { + require LWP::MediaTypes; + LWP::MediaTypes::guess_media_type( $file, $h ); + } + } + if ( $h->header("Content-Disposition") ) { + + # just to get it sorted first + $disp = $h->header("Content-Disposition"); + $h->remove_header("Content-Disposition"); + } + if ( $h->header("Content") ) { + $content = $h->header("Content"); + $h->remove_header("Content"); + } + my $head = join( + $CRLF, "Content-Disposition: $disp", + $h->as_string($CRLF), + "" + ); + if ( ref $content ) { + push( @parts, [ $head, $$content ] ); + $fhparts++; + } + else { + push( @parts, $head . $content ); + } + } } - return ("", "none") unless @parts; + return ( "", "none" ) unless @parts; my $content; if ($fhparts) { - $boundary = boundary(10) # hopefully enough randomness - unless $boundary; - - # add the boundaries to the @parts array - for (1..@parts-1) { - splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); - } - unshift(@parts, "--$boundary$CRLF"); - push(@parts, "$CRLF--$boundary--$CRLF"); - - # See if we can generate Content-Length header - my $length = 0; - for (@parts) { - if (ref $_) { - my ($head, $f) = @$_; - my $file_size; - unless ( -f $f && ($file_size = -s _) ) { - # The file is either a dynamic file like /dev/audio - # or perhaps a file in the /proc file system where - # stat may return a 0 size even though reading it - # will produce data. So we cannot make - # a Content-Length header. - undef $length; - last; - } - $length += $file_size + length $head; - } - else { - $length += length; - } + $boundary = boundary(10) # hopefully enough randomness + unless $boundary; + + # add the boundaries to the @parts array + for ( 1 .. @parts - 1 ) { + splice( @parts, $_ * 2 - 1, 0, "$CRLF--$boundary$CRLF" ); } - $length && $req->header('Content-Length' => $length); - - # set up a closure that will return content piecemeal - $content = sub { - for (;;) { - unless (@parts) { - defined $length && $length != 0 && - Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; - return; - } - my $p = shift @parts; - unless (ref $p) { - $p .= shift @parts while @parts && !ref($parts[0]); - defined $length && ($length -= length $p); - return $p; - } - my($buf, $fh) = @$p; - unless (ref($fh)) { + unshift( @parts, "--$boundary$CRLF" ); + push( @parts, "$CRLF--$boundary--$CRLF" ); + + # See if we can generate Content-Length header + my $length = 0; + for (@parts) { + if ( ref $_ ) { + my ( $head, $f ) = @$_; + my $file_size; + unless ( -f $f && ( $file_size = -s _ ) ) { + + # The file is either a dynamic file like /dev/audio + # or perhaps a file in the /proc file system where + # stat may return a 0 size even though reading it + # will produce data. So we cannot make + # a Content-Length header. + undef $length; + last; + } + $length += $file_size + length $head; + } + else { + $length += length; + } + } + $length && $req->header( 'Content-Length' => $length ); + + # set up a closure that will return content piecemeal + $content = sub { + for ( ; ; ) { + unless (@parts) { + defined $length + && $length != 0 + && Carp::croak + "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; + return; + } + my $p = shift @parts; + unless ( ref $p ) { + $p .= shift @parts while @parts && !ref( $parts[0] ); + defined $length && ( $length -= length $p ); + return $p; + } + my ( $buf, $fh ) = @$p; + unless ( ref($fh) ) { my $file = $fh; undef($fh); - open($fh, "<", $file) || Carp::croak("Can't open file $file: $!"); + open( $fh, "<", $file ) + || Carp::croak("Can't open file $file: $!"); binmode($fh); } - my $buflength = length $buf; - my $n = read($fh, $buf, $READ_BUFFER_SIZE, $buflength); - if ($n) { - $buflength += $n; - unshift(@parts, ["", $fh]); - } - else { - close($fh); - } - if ($buflength) { - defined $length && ($length -= $buflength); - return $buf - } - } - }; + my $buflength = length $buf; + my $n = read( $fh, $buf, $READ_BUFFER_SIZE, $buflength ); + if ($n) { + $buflength += $n; + unshift( @parts, [ "", $fh ] ); + } + else { + close($fh); + } + if ($buflength) { + defined $length && ( $length -= $buflength ); + return $buf; + } + } + }; } else { - $boundary = boundary() unless $boundary; - - my $bno = 0; - CHECK_BOUNDARY: - { - for (@parts) { - if (index($_, $boundary) >= 0) { - # must have a better boundary - $boundary = boundary(++$bno); - redo CHECK_BOUNDARY; - } - } - last; - } - $content = "--$boundary$CRLF" . - join("$CRLF--$boundary$CRLF", @parts) . - "$CRLF--$boundary--$CRLF"; + $boundary = boundary() unless $boundary; + + my $bno = 0; + CHECK_BOUNDARY: + { + for (@parts) { + if ( index( $_, $boundary ) >= 0 ) { + + # must have a better boundary + $boundary = boundary( ++$bno ); + redo CHECK_BOUNDARY; + } + } + last; + } + $content + = "--$boundary$CRLF" + . join( "$CRLF--$boundary$CRLF", @parts ) + . "$CRLF--$boundary--$CRLF"; } - wantarray ? ($content, $boundary) : $content; + wantarray ? ( $content, $boundary ) : $content; } - -sub boundary -{ +sub boundary { my $size = shift || return "xYzZY"; require MIME::Base64; - my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); - $b =~ s/[\W]/X/g; # ensure alnum only + my $b = MIME::Base64::encode( + join( "", map chr( rand(256) ), 1 .. $size * 3 ), "" ); + $b =~ s/[\W]/X/g; # ensure alnum only $b; } diff --git a/lib/HTTP/Response.pm b/lib/HTTP/Response.pm index 42ca36f6..3d16b3b1 100644 --- a/lib/HTTP/Response.pm +++ b/lib/HTTP/Response.pm @@ -9,221 +9,208 @@ use parent 'HTTP::Message'; use HTTP::Status (); - -sub new -{ - my($class, $rc, $msg, $header, $content) = @_; - my $self = $class->SUPER::new($header, $content); +sub new { + my ( $class, $rc, $msg, $header, $content ) = @_; + my $self = $class->SUPER::new( $header, $content ); $self->code($rc); $self->message($msg); $self; } - -sub parse -{ - my($class, $str) = @_; - Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; +sub parse { + my ( $class, $str ) = @_; + Carp::carp('Undefined argument to parse()') if $^W && !defined $str; my $status_line; - if (defined $str && $str =~ s/^(.*)\n//) { - $status_line = $1; + if ( defined $str && $str =~ s/^(.*)\n// ) { + $status_line = $1; } else { - $status_line = $str; - $str = ""; + $status_line = $str; + $str = ""; } $status_line =~ s/\r\z// if defined $status_line; my $self = $class->SUPER::parse($str); - if (defined $status_line) { - my($protocol, $code, $message); - if ($status_line =~ /^\d{3} /) { - # Looks like a response created by HTTP::Response->new - ($code, $message) = split(' ', $status_line, 2); - } else { - ($protocol, $code, $message) = split(' ', $status_line, 3); + if ( defined $status_line ) { + my ( $protocol, $code, $message ); + if ( $status_line =~ /^\d{3} / ) { + + # Looks like a response created by HTTP::Response->new + ( $code, $message ) = split( ' ', $status_line, 2 ); + } + else { + ( $protocol, $code, $message ) = split( ' ', $status_line, 3 ); } $self->protocol($protocol) if $protocol; - $self->code($code) if defined($code); - $self->message($message) if defined($message); + $self->code($code) if defined($code); + $self->message($message) if defined($message); } $self; } - -sub clone -{ - my $self = shift; +sub clone { + my $self = shift; my $clone = bless $self->SUPER::clone, ref($self); - $clone->code($self->code); - $clone->message($self->message); - $clone->request($self->request->clone) if $self->request; + $clone->code( $self->code ); + $clone->message( $self->message ); + $clone->request( $self->request->clone ) if $self->request; + # we don't clone previous $clone; } +sub code { shift->_elem( '_rc', @_ ); } +sub message { shift->_elem( '_msg', @_ ); } +sub previous { shift->_elem( '_previous', @_ ); } +sub request { shift->_elem( '_request', @_ ); } -sub code { shift->_elem('_rc', @_); } -sub message { shift->_elem('_msg', @_); } -sub previous { shift->_elem('_previous',@_); } -sub request { shift->_elem('_request', @_); } - - -sub status_line -{ +sub status_line { my $self = shift; - my $code = $self->{'_rc'} || "000"; - my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; + my $code = $self->{'_rc'} || "000"; + my $mess + = $self->{'_msg'} + || HTTP::Status::status_message($code) + || "Unknown code"; return "$code $mess"; } - -sub base -{ +sub base { my $self = shift; my $base = ( - $self->header('Content-Base'), # used to be HTTP/1.1 - $self->header('Base'), # HTTP/1.0 + $self->header('Content-Base'), # used to be HTTP/1.1 + $self->header('Base'), # HTTP/1.0 )[0]; - if ($base && $base =~ /^$URI::scheme_re:/o) { - # already absolute - return $HTTP::URI_CLASS->new($base); + if ( $base && $base =~ /^$URI::scheme_re:/o ) { + + # already absolute + return $HTTP::URI_CLASS->new($base); } my $req = $self->request; if ($req) { + # if $base is undef here, the return value is effectively # just a copy of $self->request->uri. - return $HTTP::URI_CLASS->new_abs($base, $req->uri); + return $HTTP::URI_CLASS->new_abs( $base, $req->uri ); } # can't find an absolute base return undef; } - sub redirects { my $self = shift; my @r; my $r = $self; - while (my $p = $r->previous) { - push(@r, $p); + while ( my $p = $r->previous ) { + push( @r, $p ); $r = $p; } return @r unless wantarray; return reverse @r; } - -sub filename -{ +sub filename { my $self = shift; my $file; my $cd = $self->header('Content-Disposition'); if ($cd) { - require HTTP::Headers::Util; - if (my @cd = HTTP::Headers::Util::split_header_words($cd)) { - my ($disposition, undef, %cd_param) = @{$cd[-1]}; - $file = $cd_param{filename}; - - # RFC 2047 encoded? - if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) { - my $charset = $1; - my $encoding = uc($2); - my $encfile = $3; - - if ($encoding eq 'Q' || $encoding eq 'B') { - local($SIG{__DIE__}); - eval { - if ($encoding eq 'Q') { - $encfile =~ s/_/ /g; - require MIME::QuotedPrint; - $encfile = MIME::QuotedPrint::decode($encfile); - } - else { # $encoding eq 'B' - require MIME::Base64; - $encfile = MIME::Base64::decode($encfile); - } - - require Encode; - require Encode::Locale; - Encode::from_to($encfile, $charset, "locale_fs"); - }; - - $file = $encfile unless $@; - } - } - } + require HTTP::Headers::Util; + if ( my @cd = HTTP::Headers::Util::split_header_words($cd) ) { + my ( $disposition, undef, %cd_param ) = @{ $cd[-1] }; + $file = $cd_param{filename}; + + # RFC 2047 encoded? + if ( $file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/ ) { + my $charset = $1; + my $encoding = uc($2); + my $encfile = $3; + + if ( $encoding eq 'Q' || $encoding eq 'B' ) { + local ( $SIG{__DIE__} ); + eval { + if ( $encoding eq 'Q' ) { + $encfile =~ s/_/ /g; + require MIME::QuotedPrint; + $encfile = MIME::QuotedPrint::decode($encfile); + } + else { # $encoding eq 'B' + require MIME::Base64; + $encfile = MIME::Base64::decode($encfile); + } + + require Encode; + require Encode::Locale; + Encode::from_to( $encfile, $charset, "locale_fs" ); + }; + + $file = $encfile unless $@; + } + } + } } - unless (defined($file) && length($file)) { - my $uri; - if (my $cl = $self->header('Content-Location')) { - $uri = URI->new($cl); - } - elsif (my $request = $self->request) { - $uri = $request->uri; - } - - if ($uri) { - $file = ($uri->path_segments)[-1]; - } + unless ( defined($file) && length($file) ) { + my $uri; + if ( my $cl = $self->header('Content-Location') ) { + $uri = URI->new($cl); + } + elsif ( my $request = $self->request ) { + $uri = $request->uri; + } + + if ($uri) { + $file = ( $uri->path_segments )[-1]; + } } if ($file) { - $file =~ s,.*[\\/],,; # basename + $file =~ s,.*[\\/],,; # basename } - if ($file && !length($file)) { - $file = undef; + if ( $file && !length($file) ) { + $file = undef; } $file; } - -sub as_string -{ +sub as_string { my $self = shift; - my($eol) = @_; + my ($eol) = @_; $eol = "\n" unless defined $eol; my $status_line = $self->status_line; - my $proto = $self->protocol; + my $proto = $self->protocol; $status_line = "$proto $status_line" if $proto; - return join($eol, $status_line, $self->SUPER::as_string(@_)); + return join( $eol, $status_line, $self->SUPER::as_string(@_) ); } - -sub dump -{ +sub dump { my $self = shift; my $status_line = $self->status_line; - my $proto = $self->protocol; + my $proto = $self->protocol; $status_line = "$proto $status_line" if $proto; return $self->SUPER::dump( - preheader => $status_line, + preheader => $status_line, @_, ); } +sub is_info { HTTP::Status::is_info( shift->{'_rc'} ); } +sub is_success { HTTP::Status::is_success( shift->{'_rc'} ); } +sub is_redirect { HTTP::Status::is_redirect( shift->{'_rc'} ); } +sub is_error { HTTP::Status::is_error( shift->{'_rc'} ); } +sub is_client_error { HTTP::Status::is_client_error( shift->{'_rc'} ); } +sub is_server_error { HTTP::Status::is_server_error( shift->{'_rc'} ); } -sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } -sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } -sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } -sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } -sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); } -sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); } - - -sub error_as_HTML -{ - my $self = shift; +sub error_as_HTML { + my $self = shift; my $title = 'An Error Occurred'; my $body = $self->status_line; $body =~ s/&/&/g; @@ -239,58 +226,55 @@ sub error_as_HTML EOM } - -sub current_age -{ +sub current_age { my $self = shift; my $time = shift; # Implementation of RFC 2616 section 13.2.3 # (age calculations) my $response_time = $self->client_date; - my $date = $self->date; + my $date = $self->date; my $age = 0; - if ($response_time && $date) { - $age = $response_time - $date; # apparent_age - $age = 0 if $age < 0; + if ( $response_time && $date ) { + $age = $response_time - $date; # apparent_age + $age = 0 if $age < 0; } my $age_v = $self->header('Age'); - if ($age_v && $age_v > $age) { - $age = $age_v; # corrected_received_age + if ( $age_v && $age_v > $age ) { + $age = $age_v; # corrected_received_age } if ($response_time) { - my $request = $self->request; - if ($request) { - my $request_time = $request->date; - if ($request_time && $request_time < $response_time) { - # Add response_delay to age to get 'corrected_initial_age' - $age += $response_time - $request_time; - } - } - $age += ($time || time) - $response_time; + my $request = $self->request; + if ($request) { + my $request_time = $request->date; + if ( $request_time && $request_time < $response_time ) { + + # Add response_delay to age to get 'corrected_initial_age' + $age += $response_time - $request_time; + } + } + $age += ( $time || time ) - $response_time; } return $age; } - -sub freshness_lifetime -{ - my($self, %opt) = @_; +sub freshness_lifetime { + my ( $self, %opt ) = @_; # First look for the Cache-Control: max-age=n header - for my $cc ($self->header('Cache-Control')) { - for my $cc_dir (split(/\s*,\s*/, $cc)) { - return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; - } + for my $cc ( $self->header('Cache-Control') ) { + for my $cc_dir ( split( /\s*,\s*/, $cc ) ) { + return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; + } } # Next possibility is to look at the "Expires" header my $date = $self->date || $self->client_date || $opt{time} || time; - if (my $expires = $self->expires) { - return $expires - $date; + if ( my $expires = $self->expires ) { + return $expires - $date; } # Must apply heuristic expiration @@ -299,18 +283,19 @@ sub freshness_lifetime # Default heuristic expiration parameters $opt{h_min} ||= 60; $opt{h_max} ||= 24 * 3600; - $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616 + $opt{h_lastmod_fraction} + ||= 0.10; # 10% since last-mod suggested by RFC2616 $opt{h_default} ||= 3600; # Should give a warning if more than 24 hours according to # RFC 2616 section 13.2.4. Here we just make this the default # maximum value. - if (my $last_modified = $self->last_modified) { - my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction}; - return $opt{h_min} if $h_exp < $opt{h_min}; - return $opt{h_max} if $h_exp > $opt{h_max}; - return $h_exp; + if ( my $last_modified = $self->last_modified ) { + my $h_exp = ( $date - $last_modified ) * $opt{h_lastmod_fraction}; + return $opt{h_min} if $h_exp < $opt{h_min}; + return $opt{h_max} if $h_exp > $opt{h_max}; + return $h_exp; } # default when all else fails @@ -318,29 +303,24 @@ sub freshness_lifetime return $opt{h_default}; } - -sub is_fresh -{ - my($self, %opt) = @_; +sub is_fresh { + my ( $self, %opt ) = @_; $opt{time} ||= time; my $f = $self->freshness_lifetime(%opt); return undef unless defined($f); - return $f > $self->current_age($opt{time}); + return $f > $self->current_age( $opt{time} ); } - -sub fresh_until -{ - my($self, %opt) = @_; +sub fresh_until { + my ( $self, %opt ) = @_; $opt{time} ||= time; my $f = $self->freshness_lifetime(%opt); return undef unless defined($f); - return $f - $self->current_age($opt{time}) + $opt{time}; + return $f - $self->current_age( $opt{time} ) + $opt{time}; } 1; - __END__ =pod diff --git a/lib/HTTP/Status.pm b/lib/HTTP/Status.pm index 7c41355c..ff026d83 100644 --- a/lib/HTTP/Status.pm +++ b/lib/HTTP/Status.pm @@ -8,7 +8,8 @@ our $VERSION = '7.01'; use Exporter 5.57 'import'; our @EXPORT = qw(is_info is_success is_redirect is_error status_message); -our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default status_constant_name status_codes); +our @EXPORT_OK + = qw(is_client_error is_server_error is_cacheable_by_default status_constant_name status_codes); # Note also addition of mnemonics to @EXPORT below @@ -19,9 +20,10 @@ our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default stat my %StatusCode = ( 100 => 'Continue', 101 => 'Switching Protocols', - 102 => 'Processing', # RFC 2518: WebDAV - 103 => 'Early Hints', # RFC 8297: Indicating Hints -# 104 .. 199 + 102 => 'Processing', # RFC 2518: WebDAV + 103 => 'Early Hints', # RFC 8297: Indicating Hints + + # 104 .. 199 200 => 'OK', 201 => 'Created', 202 => 'Accepted', @@ -31,92 +33,102 @@ my %StatusCode = ( 206 => 'Partial Content', # RFC 7233: Range Requests 207 => 'Multi-Status', # RFC 4918: WebDAV 208 => 'Already Reported', # RFC 5842: WebDAV bindings -# 209 .. 225 + + # 209 .. 225 226 => 'IM Used', # RFC 3229: Delta encoding -# 227 .. 299 + + # 227 .. 299 300 => 'Multiple Choices', 301 => 'Moved Permanently', 302 => 'Found', 303 => 'See Other', - 304 => 'Not Modified', # RFC 7232: Conditional Request + 304 => 'Not Modified', # RFC 7232: Conditional Request 305 => 'Use Proxy', - 306 => '(Unused)', # RFC 9110: Previously used and reserved + 306 => '(Unused)', # RFC 9110: Previously used and reserved 307 => 'Temporary Redirect', - 308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect -# 309 .. 399 + 308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect + + # 309 .. 399 400 => 'Bad Request', - 401 => 'Unauthorized', # RFC 7235: Authentication + 401 => 'Unauthorized', # RFC 7235: Authentication 402 => 'Payment Required', 403 => 'Forbidden', 404 => 'Not Found', 405 => 'Method Not Allowed', 406 => 'Not Acceptable', - 407 => 'Proxy Authentication Required', # RFC 7235: Authentication + 407 => 'Proxy Authentication Required', # RFC 7235: Authentication 408 => 'Request Timeout', 409 => 'Conflict', 410 => 'Gone', 411 => 'Length Required', - 412 => 'Precondition Failed', # RFC 7232: Conditional Request + 412 => 'Precondition Failed', # RFC 7232: Conditional Request 413 => 'Content Too Large', 414 => 'URI Too Long', 415 => 'Unsupported Media Type', - 416 => 'Range Not Satisfiable', # RFC 7233: Range Requests + 416 => 'Range Not Satisfiable', # RFC 7233: Range Requests 417 => 'Expectation Failed', - 418 => "I'm a teapot", # RFC 2324: RFC9110 reserved it -# 419 .. 420 - 421 => 'Misdirected Request', # RFC 7540: HTTP/2 - 422 => 'Unprocessable Content', # RFC 9110: WebDAV - 423 => 'Locked', # RFC 4918: WebDAV - 424 => 'Failed Dependency', # RFC 4918: WebDAV - 425 => 'Too Early', # RFC 8470: Using Early Data in HTTP + 418 => "I'm a teapot", # RFC 2324: RFC9110 reserved it + + # 419 .. 420 + 421 => 'Misdirected Request', # RFC 7540: HTTP/2 + 422 => 'Unprocessable Content', # RFC 9110: WebDAV + 423 => 'Locked', # RFC 4918: WebDAV + 424 => 'Failed Dependency', # RFC 4918: WebDAV + 425 => 'Too Early', # RFC 8470: Using Early Data in HTTP 426 => 'Upgrade Required', -# 427 - 428 => 'Precondition Required', # RFC 6585: Additional Codes - 429 => 'Too Many Requests', # RFC 6585: Additional Codes -# 430 - 431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes -# 432 .. 450 - 451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles -# 452 .. 499 + + # 427 + 428 => 'Precondition Required', # RFC 6585: Additional Codes + 429 => 'Too Many Requests', # RFC 6585: Additional Codes + + # 430 + 431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes + + # 432 .. 450 + 451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles + + # 452 .. 499 500 => 'Internal Server Error', 501 => 'Not Implemented', 502 => 'Bad Gateway', 503 => 'Service Unavailable', 504 => 'Gateway Timeout', 505 => 'HTTP Version Not Supported', - 506 => 'Variant Also Negotiates', # RFC 2295: Transparent Ngttn - 507 => 'Insufficient Storage', # RFC 4918: WebDAV - 508 => 'Loop Detected', # RFC 5842: WebDAV bindings -# 509 - 510 => 'Not Extended', # RFC 2774: Extension Framework - 511 => 'Network Authentication Required', # RFC 6585: Additional Codes + 506 => 'Variant Also Negotiates', # RFC 2295: Transparent Ngttn + 507 => 'Insufficient Storage', # RFC 4918: WebDAV + 508 => 'Loop Detected', # RFC 5842: WebDAV bindings + + # 509 + 510 => 'Not Extended', # RFC 2774: Extension Framework + 511 => 'Network Authentication Required', # RFC 6585: Additional Codes # Keep some unofficial codes that used to be in this distribution - 449 => 'Retry with', # microsoft - 509 => 'Bandwidth Limit Exceeded', # Apache / cPanel + 449 => 'Retry with', # microsoft + 509 => 'Bandwidth Limit Exceeded', # Apache / cPanel ); my %StatusCodeName; my $mnemonicCode = ''; -my ($code, $message); -while (($code, $message) = each %StatusCode) { +my ( $code, $message ); +while ( ( $code, $message ) = each %StatusCode ) { next if $message eq '(Unused)'; + # create mnemonic subroutines $message =~ s/I'm/I am/; $message =~ tr/a-z \-/A-Z__/; - my $constant_name = "HTTP_".$message; + my $constant_name = "HTTP_" . $message; $mnemonicCode .= "sub $constant_name () { $code }\n"; - $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy + $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n"; $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; - $StatusCodeName{$code} = $constant_name + $StatusCodeName{$code} = $constant_name; } -eval $mnemonicCode; # only one eval for speed +eval $mnemonicCode; # only one eval for speed die if $@; # backwards compatibility -*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard -push(@EXPORT, "RC_MOVED_TEMPORARILY"); +*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard +push( @EXPORT, "RC_MOVED_TEMPORARILY" ); my %compat = ( UNPROCESSABLE_ENTITY => \&HTTP_UNPROCESSABLE_CONTENT, @@ -128,52 +140,54 @@ my %compat = ( UNORDERED_COLLECTION => \&HTTP_TOO_EARLY, ); -foreach my $name (keys %compat) { - push(@EXPORT, "RC_$name"); - push(@EXPORT_OK, "HTTP_$name"); +foreach my $name ( keys %compat ) { + push( @EXPORT, "RC_$name" ); + push( @EXPORT_OK, "HTTP_$name" ); no strict 'refs'; - *{"RC_$name"} = $compat{$name}; + *{"RC_$name"} = $compat{$name}; *{"HTTP_$name"} = $compat{$name}; } our %EXPORT_TAGS = ( - constants => [grep /^HTTP_/, @EXPORT_OK], - is => [grep /^is_/, @EXPORT, @EXPORT_OK], + constants => [ grep /^HTTP_/, @EXPORT_OK ], + is => [ grep /^is_/, @EXPORT, @EXPORT_OK ], ); +sub status_message ($) { $StatusCode{ $_[0] }; } -sub status_message ($) { $StatusCode{$_[0]}; } sub status_constant_name ($) { - exists($StatusCodeName{$_[0]}) ? $StatusCodeName{$_[0]} : undef; + exists( $StatusCodeName{ $_[0] } ) ? $StatusCodeName{ $_[0] } : undef; } -sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; } -sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; } -sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; } -sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; } -sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; } -sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; } -sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK - || $_[0] == 203 # Non-Authoritative Information - || $_[0] == 204 # No Content - || $_[0] == 206 # Not Acceptable - || $_[0] == 300 # Multiple Choices - || $_[0] == 301 # Moved Permanently - || $_[0] == 308 # Permanent Redirect - || $_[0] == 404 # Not Found - || $_[0] == 405 # Method Not Allowed - || $_[0] == 410 # Gone - || $_[0] == 414 # Request-URI Too Large - || $_[0] == 451 # Unavailable For Legal Reasons - || $_[0] == 501 # Not Implemented - ); +sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; } +sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; } +sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; } +sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; } +sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; } +sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; } + +sub is_cacheable_by_default ($) { + $_[0] && ( + $_[0] == 200 # OK + || $_[0] == 203 # Non-Authoritative Information + || $_[0] == 204 # No Content + || $_[0] == 206 # Not Acceptable + || $_[0] == 300 # Multiple Choices + || $_[0] == 301 # Moved Permanently + || $_[0] == 308 # Permanent Redirect + || $_[0] == 404 # Not Found + || $_[0] == 405 # Method Not Allowed + || $_[0] == 410 # Gone + || $_[0] == 414 # Request-URI Too Large + || $_[0] == 451 # Unavailable For Legal Reasons + || $_[0] == 501 # Not Implemented + ); } -sub status_codes { %StatusCode; } +sub status_codes { %StatusCode; } 1; - __END__ =pod diff --git a/t/common-req.t b/t/common-req.t index 0e4949d6..2a8ec82c 100644 --- a/t/common-req.t +++ b/t/common-req.t @@ -10,103 +10,108 @@ use HTTP::Request::Common; my $r = GET 'http://www.sn.no/'; note $r->as_string; -is($r->method, "GET"); -is($r->uri, "http://www.sn.no/"); +is( $r->method, "GET" ); +is( $r->uri, "http://www.sn.no/" ); $r = HEAD "http://www.sn.no/", - If_Match => 'abc', - From => 'aas@sn.no'; + If_Match => 'abc', + From => 'aas@sn.no'; note $r->as_string; -is($r->method, "HEAD"); -ok($r->uri->eq("http://www.sn.no")); +is( $r->method, "HEAD" ); +ok( $r->uri->eq("http://www.sn.no") ); -is($r->header('If-Match'), "abc"); -is($r->header("from"), "aas\@sn.no"); +is( $r->header('If-Match'), "abc" ); +is( $r->header("from"), "aas\@sn.no" ); $r = HEAD "http://www.sn.no/", - Content => 'foo'; -is($r->content, 'foo'); + Content => 'foo'; +is( $r->content, 'foo' ); $r = HEAD "http://www.sn.no/", - Content => 'foo', - 'Content-Length' => 50; -is($r->content, 'foo'); -is($r->content_length, 50); + Content => 'foo', + 'Content-Length' => 50; +is( $r->content, 'foo' ); +is( $r->content_length, 50 ); $r = PUT "http://www.sn.no", - Content => 'foo'; + Content => 'foo'; note $r->as_string, "\n"; -is($r->method, "PUT"); -is($r->uri->host, "www.sn.no"); +is( $r->method, "PUT" ); +is( $r->uri->host, "www.sn.no" ); -ok(!defined($r->header("Content"))); +ok( !defined( $r->header("Content") ) ); -is(${$r->content_ref}, "foo"); -is($r->content, "foo"); -is($r->content_length, 3); +is( ${ $r->content_ref }, "foo" ); +is( $r->content, "foo" ); +is( $r->content_length, 3 ); $r = PUT "http://www.sn.no", - { foo => "bar" }; -is($r->content, "foo=bar"); + { foo => "bar" }; +is( $r->content, "foo=bar" ); $r = OPTIONS "http://www.sn.no", - Content => 'foo'; + Content => 'foo'; note $r->as_string, "\n"; -is($r->method, "OPTIONS"); -is($r->uri->host, "www.sn.no"); +is( $r->method, "OPTIONS" ); +is( $r->uri->host, "www.sn.no" ); -ok(!defined($r->header("Content"))); +ok( !defined( $r->header("Content") ) ); -is(${$r->content_ref}, "foo"); -is($r->content, "foo"); -is($r->content_length, 3); +is( ${ $r->content_ref }, "foo" ); +is( $r->content, "foo" ); +is( $r->content_length, 3 ); $r = OPTIONS "http://www.sn.no", - { foo => "bar" }; -is($r->content, "foo=bar"); + { foo => "bar" }; +is( $r->content, "foo=bar" ); $r = PATCH "http://www.sn.no", - { foo => "bar" }; -is($r->content, "foo=bar"); + { foo => "bar" }; +is( $r->content, "foo=bar" ); #--- Test POST requests --- -$r = POST "http://www.sn.no", [foo => 'bar;baz', - baz => [qw(a b c)], - foo => 'zoo=&', - "space " => " + ", - "nl" => "a\nb\r\nc\n", - ], - bar => 'foo'; +$r = POST "http://www.sn.no", [ + foo => 'bar;baz', + baz => [qw(a b c)], + foo => 'zoo=&', + "space " => " + ", + "nl" => "a\nb\r\nc\n", + ], + bar => 'foo'; note $r->as_string, "\n"; -is($r->method, "POST"); -is($r->content_type, "application/x-www-form-urlencoded"); -is($r->content_length, 77, 'content_length'); -is($r->header("bar"), "foo", 'bar is foo'); -is($r->content, 'foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+&nl=a%0Ab%0D%0Ac%0A'); +is( $r->method, "POST" ); +is( $r->content_type, "application/x-www-form-urlencoded" ); +is( $r->content_length, 77, 'content_length' ); +is( $r->header("bar"), "foo", 'bar is foo' ); +is( + $r->content, + 'foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+&nl=a%0Ab%0D%0Ac%0A' +); $r = POST "http://example.com"; -is($r->content_length, 0); -is($r->content, ""); +is( $r->content_length, 0 ); +is( $r->content, "" ); $r = POST "http://example.com", []; -is($r->content_length, 0); -is($r->content, ""); +is( $r->content_length, 0 ); +is( $r->content, "" ); $r = POST "mailto:gisle\@aas.no", - Subject => "Heisan", - Content_Type => "text/plain", - Content => "Howdy\n"; + Subject => "Heisan", + Content_Type => "text/plain", + Content => "Howdy\n"; + #note $r->as_string; -is($r->method, "POST"); -is($r->header("Subject"), "Heisan"); -is($r->content, "Howdy\n"); -is($r->content_type, "text/plain"); +is( $r->method, "POST" ); +is( $r->header("Subject"), "Heisan" ); +is( $r->content, "Howdy\n" ); +is( $r->content_type, "text/plain" ); { my @warnings; @@ -118,131 +123,146 @@ is($r->content_type, "text/plain"); # # POST for File upload # -my (undef, $file) = tempfile(); -my $form_file = (File::Spec->splitpath($file))[-1]; -open(FILE, ">$file") or die "Can't create $file: $!"; +my ( undef, $file ) = tempfile(); +my $form_file = ( File::Spec->splitpath($file) )[-1]; +open( FILE, ">$file" ) or die "Can't create $file: $!"; print FILE "foo\nbar\nbaz\n"; close(FILE); $r = POST 'http://www.perl.org/survey.cgi', - Content_Type => 'form-data', - Content => [ name => 'Gisle Aas', - email => 'gisle@aas.no', - gender => 'm', - born => '1964', - file => [$file], - ]; + Content_Type => 'form-data', + Content => [ + name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'm', + born => '1964', + file => [$file], + ]; + #note $r->as_string; unlink($file) or warn "Can't unlink $file: $!"; -is($r->method, "POST"); -is($r->uri->path, "/survey.cgi"); -is($r->content_type, "multipart/form-data"); -ok($r->header('Content_type') =~ /boundary="?([^"]+)"?/); +is( $r->method, "POST" ); +is( $r->uri->path, "/survey.cgi" ); +is( $r->content_type, "multipart/form-data" ); +ok( $r->header('Content_type') =~ /boundary="?([^"]+)"?/ ); my $boundary = $1; my $c = $r->content; $c =~ s/\r//g; -my @c = split(/--\Q$boundary/, $c); +my @c = split( /--\Q$boundary/, $c ); note "$c[5]\n"; -is(@c, 7); -like($c[6], qr/^--\n/); # 5 parts + header & trailer +is( @c, 7 ); +like( $c[6], qr/^--\n/ ); # 5 parts + header & trailer -ok($c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m); -ok($c[2] =~ /^gisle\@aas.no$/m); +ok( $c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m ); +ok( $c[2] =~ /^gisle\@aas.no$/m ); -ok($c[5] =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$form_file"/m); -ok($c[5] =~ /^Content-Type:\s*text\/plain$/m); -ok($c[5] =~ /^foo\nbar\nbaz/m); +ok( $c[5] + =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$form_file"/m +); +ok( $c[5] =~ /^Content-Type:\s*text\/plain$/m ); +ok( $c[5] =~ /^foo\nbar\nbaz/m ); $r = POST 'http://www.perl.org/survey.cgi', - [ file => [ undef, "xxy\"", Content_type => "text/html", Content => "

Hello, world!

" ]], - Content_type => 'multipart/form-data'; + [ + file => [ + undef, "xxy\"", Content_type => "text/html", + Content => "

Hello, world!

" + ] + ], + Content_type => 'multipart/form-data'; + #note $r->as_string; -ok($r->content =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxy\\"/m); -ok($r->content =~ /^Content-Type: text\/html/m); -ok($r->content =~ /^

Hello, world/m); +ok( $r->content + =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxy\\"/m +); +ok( $r->content =~ /^Content-Type: text\/html/m ); +ok( $r->content =~ /^

Hello, world/m ); $r = POST 'http://www.perl.org/survey.cgi', - Content_type => 'multipart/form-data', - Content => [ file => [ undef, undef, Content => "foo"]]; -#note $r->as_string; + Content_type => 'multipart/form-data', + Content => [ file => [ undef, undef, Content => "foo" ] ]; -unlike($r->content, qr/filename=/); +#note $r->as_string; +unlike( $r->content, qr/filename=/ ); # The POST routine can now also take a hash reference. -my %hash = (foo => 42, bar => 24); +my %hash = ( foo => 42, bar => 24 ); $r = POST 'http://www.perl.org/survey.cgi', \%hash; -#note $r->as_string, "\n"; -like($r->content, qr/foo=42/); -like($r->content, qr/bar=24/); -is($r->content_type, "application/x-www-form-urlencoded"); -is($r->content_length, 13); +#note $r->as_string, "\n"; +like( $r->content, qr/foo=42/ ); +like( $r->content, qr/bar=24/ ); +is( $r->content_type, "application/x-www-form-urlencoded" ); +is( $r->content_length, 13 ); # # POST for File upload # use HTTP::Request::Common qw($DYNAMIC_FILE_UPLOAD); -(undef, $file) = tempfile(); -open(FILE, ">$file") or die "Can't create $file: $!"; -for (1..1000) { - print FILE "a" .. "z"; +( undef, $file ) = tempfile(); +open( FILE, ">$file" ) or die "Can't create $file: $!"; +for ( 1 .. 1000 ) { + print FILE "a" .. "z"; } close(FILE); $DYNAMIC_FILE_UPLOAD++; $r = POST 'http://www.perl.org/survey.cgi', - Content_Type => 'form-data', - Content => [ name => 'Gisle Aas', - email => 'gisle@aas.no', - gender => 'm', - born => '1964', - file => [$file], - ]; + Content_Type => 'form-data', + Content => [ + name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'm', + born => '1964', + file => [$file], + ]; + #note $r->as_string, "\n"; -is($r->method, "POST"); -is($r->uri->path, "/survey.cgi"); -is($r->content_type, "multipart/form-data"); -ok($r->header('Content_type') =~ qr/boundary="?([^"]+)"?/); +is( $r->method, "POST" ); +is( $r->uri->path, "/survey.cgi" ); +is( $r->content_type, "multipart/form-data" ); +ok( $r->header('Content_type') =~ qr/boundary="?([^"]+)"?/ ); $boundary = $1; -is(ref($r->content), "CODE"); +is( ref( $r->content ), "CODE" ); -cmp_ok(length($boundary), '>', 10); +cmp_ok( length($boundary), '>', 10 ); my $code = $r->content; my $chunk; my @chunks; -while (defined($chunk = &$code) && length $chunk) { - push(@chunks, $chunk); +while ( defined( $chunk = &$code ) && length $chunk ) { + push( @chunks, $chunk ); } unlink($file) or warn "Can't unlink $file: $!"; -$_ = join("", @chunks); +$_ = join( "", @chunks ); #note int(@chunks), " chunks, total size is ", length($_), " bytes\n"; # should be close to expected size and number of chunks -cmp_ok(abs(@chunks - 6), '<', 3); -cmp_ok(abs(length($_) - 26589), '<', 20); +cmp_ok( abs( @chunks - 6 ), '<', 3 ); +cmp_ok( abs( length($_) - 26589 ), '<', 20 ); $r = POST 'http://www.example.com'; -is($r->as_string, <as_string, < 'form-data', Content => []; -is($r->as_string, < 'form-data', + Content => []; +is( $r->as_string, < 'form-data'; + #note $r->as_string; -is($r->as_string, <as_string, <method, "DELETE"); +is( $r->method, "DELETE" ); $r = HTTP::Request::Common::PUT 'http://www.example.com', - 'Content-Type' => 'application/octet-steam', - 'Content' => 'foobarbaz', - 'Content-Length' => 12; # a slight lie -is($r->header('Content-Length'), 9); + 'Content-Type' => 'application/octet-steam', + 'Content' => 'foobarbaz', + 'Content-Length' => 12; # a slight lie +is( $r->header('Content-Length'), 9 ); $r = HTTP::Request::Common::PATCH 'http://www.example.com', - 'Content-Type' => 'application/octet-steam', - 'Content' => 'foobarbaz', - 'Content-Length' => 12; # a slight lie -is($r->header('Content-Length'), 9); + 'Content-Type' => 'application/octet-steam', + 'Content' => 'foobarbaz', + 'Content-Length' => 12; # a slight lie +is( $r->header('Content-Length'), 9 ); done_testing(); diff --git a/t/headers-auth.t b/t/headers-auth.t index 7fb542ea..3a622ce6 100644 --- a/t/headers-auth.t +++ b/t/headers-auth.t @@ -9,40 +9,50 @@ use HTTP::Response; use HTTP::Headers::Auth; my $res = HTTP::Response->new(401); -$res->push_header(WWW_Authenticate => qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2")); -$res->push_header(WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz)); +$res->push_header( WWW_Authenticate => + qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2") ); +$res->push_header( + WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz) ); note $res->as_string; my %auth = $res->www_authenticate; -is(keys(%auth), 3); +is( keys(%auth), 3 ); -is($auth{basic}{realm}, "WallyWorld"); -is($auth{bar}{realm}, "WallyWorld2"); +is( $auth{basic}{realm}, "WallyWorld" ); +is( $auth{bar}{realm}, "WallyWorld2" ); $a = $res->www_authenticate; -is($a, 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz'); +is( + $a, + 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz' +); $res->www_authenticate("Basic realm=foo1"); note $res->as_string; -$res->www_authenticate(Basic => {realm => "foo2"}); +$res->www_authenticate( Basic => { realm => "foo2" } ); note $res->as_string; -$res->www_authenticate(Basic => [realm => "foo3", foo=>33], - Digest => {nonce=>"bar", foo=>'foo'}); +$res->www_authenticate( + Basic => [ realm => "foo3", foo => 33 ], + Digest => { nonce => "bar", foo => 'foo' } +); note $res->as_string; my $string = $res->as_string; -like($string, qr/WWW-Authenticate: Basic realm="foo3", foo=33/); -like($string, qr/WWW-Authenticate: Digest (nonce=bar, foo=foo|foo=foo, nonce=bar)/); +like( $string, qr/WWW-Authenticate: Basic realm="foo3", foo=33/ ); +like( + $string, + qr/WWW-Authenticate: Digest (nonce=bar, foo=foo|foo=foo, nonce=bar)/ +); $res = HTTP::Response->new(401); my @auth = $res->proxy_authenticate('foo'); -is_deeply(\@auth, []); -@auth = $res->proxy_authenticate('foo', 'bar'); -is_deeply(\@auth, ['foo', {}]); -@auth = $res->proxy_authenticate('foo', {'bar' => '_'}); -is_deeply(\@auth, ['foo', {}, 'bar', {}]); +is_deeply( \@auth, [] ); +@auth = $res->proxy_authenticate( 'foo', 'bar' ); +is_deeply( \@auth, [ 'foo', {} ] ); +@auth = $res->proxy_authenticate( 'foo', { 'bar' => '_' } ); +is_deeply( \@auth, [ 'foo', {}, 'bar', {} ] ); diff --git a/t/headers-etag.t b/t/headers-etag.t index 57692d74..8522be64 100644 --- a/t/headers-etag.t +++ b/t/headers-etag.t @@ -10,36 +10,36 @@ require HTTP::Headers::ETag; my $h = HTTP::Headers->new; $h->etag("tag1"); -is($h->etag, qq("tag1")); +is( $h->etag, qq("tag1") ); $h->etag("w/tag2"); -is($h->etag, qq(W/"tag2")); +is( $h->etag, qq(W/"tag2") ); $h->etag(" w/, weaktag"); -is($h->etag, qq(W/"", "weaktag")); +is( $h->etag, qq(W/"", "weaktag") ); my @list = $h->etag; -is_deeply(\@list, ['W/""', '"weaktag"']); +is_deeply( \@list, [ 'W/""', '"weaktag"' ] ); $h->etag(" w/"); -is($h->etag, qq(W/"")); +is( $h->etag, qq(W/"") ); $h->etag(" "); -is($h->etag, ""); +is( $h->etag, "" ); -$h->if_match(qq(W/"foo", bar, baz), "bar"); +$h->if_match( qq(W/"foo", bar, baz), "bar" ); $h->if_none_match(333); $h->if_range("tag3"); -is($h->if_range, qq("tag3")); +is( $h->if_range, qq("tag3") ); my $t = time; $h->if_range($t); -is($h->if_range, $t); +is( $h->if_range, $t ); note $h->as_string; @list = $h->if_range; -is($#list, 0); -is($list[0], $t); +is( $#list, 0 ); +is( $list[0], $t ); $h->if_range(undef); -is($h->if_range, ''); +is( $h->if_range, '' ); diff --git a/t/headers-util.t b/t/headers-util.t index 7959c911..ef52b408 100644 --- a/t/headers-util.t +++ b/t/headers-util.t @@ -7,42 +7,46 @@ use HTTP::Headers::Util qw(split_header_words join_header_words); my @s_tests = ( - ["foo" => "foo"], - ["foo=bar" => "foo=bar"], - [" foo " => "foo"], - ["foo=" => 'foo=""'], - ["foo=bar bar=baz" => "foo=bar; bar=baz"], - ["foo=bar;bar=baz" => "foo=bar; bar=baz"], - ['foo bar baz' => "foo; bar; baz"], - ['foo="\"" bar="\\\\"' => 'foo="\""; bar="\\\\"'], - ['foo,,,bar' => 'foo, bar'], - ['foo=bar,bar=baz' => 'foo=bar, bar=baz'], - - ['TEXT/HTML; CHARSET=ISO-8859-1' => - 'text/html; charset=ISO-8859-1'], - - ['foo="bar"; port="80,81"; discard, bar=baz' => - 'foo=bar; port="80,81"; discard, bar=baz'], - - ['Basic realm="\"foo\\\\bar\""' => - 'basic; realm="\"foo\\\\bar\""'], + [ "foo" => "foo" ], + [ "foo=bar" => "foo=bar" ], + [ " foo " => "foo" ], + [ "foo=" => 'foo=""' ], + [ "foo=bar bar=baz" => "foo=bar; bar=baz" ], + [ "foo=bar;bar=baz" => "foo=bar; bar=baz" ], + [ 'foo bar baz' => "foo; bar; baz" ], + [ 'foo="\"" bar="\\\\"' => 'foo="\""; bar="\\\\"' ], + [ 'foo,,,bar' => 'foo, bar' ], + [ 'foo=bar,bar=baz' => 'foo=bar, bar=baz' ], + + [ 'TEXT/HTML; CHARSET=ISO-8859-1' => 'text/html; charset=ISO-8859-1' ], + + [ + 'foo="bar"; port="80,81"; discard, bar=baz' => + 'foo=bar; port="80,81"; discard, bar=baz' + ], + + [ 'Basic realm="\"foo\\\\bar\""' => 'basic; realm="\"foo\\\\bar\""' ], ); plan tests => @s_tests + 4; for (@s_tests) { - my($arg, $expect) = @$_; - my @arg = ref($arg) ? @$arg : $arg; + my ( $arg, $expect ) = @$_; + my @arg = ref($arg) ? @$arg : $arg; - my $res = join_header_words(split_header_words(@arg)); - is($res, $expect); + my $res = join_header_words( split_header_words(@arg) ); + is( $res, $expect ); } - note "# Extra tests\n"; + # some extra tests -is(join_header_words("foo" => undef, "bar" => "baz"), "foo; bar=baz"); -is(join_header_words(), ""); -is(join_header_words([]), ""); +is( join_header_words( "foo" => undef, "bar" => "baz" ), "foo; bar=baz" ); +is( join_header_words(), "" ); +is( join_header_words( [] ), "" ); + # ignore bare = -is_deeply(split_header_words("foo; =;bar=baz"), ["foo" => undef, "bar" => "baz"]); +is_deeply( + split_header_words("foo; =;bar=baz"), + [ "foo" => undef, "bar" => "baz" ] +); diff --git a/t/headers.t b/t/headers.t index 2bdf0c72..833df159 100644 --- a/t/headers.t +++ b/t/headers.t @@ -8,92 +8,91 @@ use Test::More; plan tests => 189; -my($h, $h2); -sub j { join("|", @_) } - +my ( $h, $h2 ); +sub j { join( "|", @_ ) } require HTTP::Headers; $h = HTTP::Headers->new; ok($h); -is(ref($h), "HTTP::Headers"); -is($h->as_string, ""); - -$h = HTTP::Headers->new(foo => "bar", foo => "baaaaz", Foo => "baz"); -is($h->as_string, "Foo: bar\nFoo: baaaaz\nFoo: baz\n"); - -$h = HTTP::Headers->new(foo => ["bar", "baz"]); -is($h->as_string, "Foo: bar\nFoo: baz\n"); - -$h = HTTP::Headers->new(foo => 1, bar => 2, foo_bar => 3); -is($h->as_string, "Bar: 2\nFoo: 1\nFoo-Bar: 3\n"); -is($h->as_string(";"), "Bar: 2;Foo: 1;Foo-Bar: 3;"); - -is($h->header("Foo"), 1); -is($h->header("FOO"), 1); -is(j($h->header("foo")), 1); -is($h->header("foo-bar"), 3); -is($h->header("foo_bar"), 3); -is($h->header("Not-There"), undef); -is(j($h->header("Not-There")), ""); -is(eval { $h->header }, undef); +is( ref($h), "HTTP::Headers" ); +is( $h->as_string, "" ); + +$h = HTTP::Headers->new( foo => "bar", foo => "baaaaz", Foo => "baz" ); +is( $h->as_string, "Foo: bar\nFoo: baaaaz\nFoo: baz\n" ); + +$h = HTTP::Headers->new( foo => [ "bar", "baz" ] ); +is( $h->as_string, "Foo: bar\nFoo: baz\n" ); + +$h = HTTP::Headers->new( foo => 1, bar => 2, foo_bar => 3 ); +is( $h->as_string, "Bar: 2\nFoo: 1\nFoo-Bar: 3\n" ); +is( $h->as_string(";"), "Bar: 2;Foo: 1;Foo-Bar: 3;" ); + +is( $h->header("Foo"), 1 ); +is( $h->header("FOO"), 1 ); +is( j( $h->header("foo") ), 1 ); +is( $h->header("foo-bar"), 3 ); +is( $h->header("foo_bar"), 3 ); +is( $h->header("Not-There"), undef ); +is( j( $h->header("Not-There") ), "" ); +is( eval { $h->header }, undef ); ok($@); -is($h->header("Foo", 11), 1); -is($h->header("Foo", [1, 1]), 11); -is($h->header("Foo"), "1, 1"); -is(j($h->header("Foo")), "1|1"); -is($h->header(foo => 11, Foo => 12, bar => 22), 2); -is($h->header("Foo"), "11, 12"); -is($h->header("Bar"), 22); -is($h->header("Bar", undef), 22); -is(j($h->header("bar", 22)), ""); - -$h->push_header(Bar => 22); -is($h->header("Bar"), "22, 22"); -$h->push_header(Bar => [23 .. 25]); -is($h->header("Bar"), "22, 22, 23, 24, 25"); -is(j($h->header("Bar")), "22|22|23|24|25"); +is( $h->header( "Foo", 11 ), 1 ); +is( $h->header( "Foo", [ 1, 1 ] ), 11 ); +is( $h->header("Foo"), "1, 1" ); +is( j( $h->header("Foo") ), "1|1" ); +is( $h->header( foo => 11, Foo => 12, bar => 22 ), 2 ); +is( $h->header("Foo"), "11, 12" ); +is( $h->header("Bar"), 22 ); +is( $h->header( "Bar", undef ), 22 ); +is( j( $h->header( "bar", 22 ) ), "" ); + +$h->push_header( Bar => 22 ); +is( $h->header("Bar"), "22, 22" ); +$h->push_header( Bar => [ 23 .. 25 ] ); +is( $h->header("Bar"), "22, 22, 23, 24, 25" ); +is( j( $h->header("Bar") ), "22|22|23|24|25" ); $h->clear; -$h->header(Foo => 1); -is($h->as_string, "Foo: 1\n"); -$h->init_header(Foo => 2); -$h->init_header(Bar => 2); -is($h->as_string, "Bar: 2\nFoo: 1\n"); -$h->init_header(Foo => [2, 3]); -$h->init_header(Baz => [2, 3]); -is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); - -eval { $h->init_header(A => 1, B => 2, C => 3) }; +$h->header( Foo => 1 ); +is( $h->as_string, "Foo: 1\n" ); +$h->init_header( Foo => 2 ); +$h->init_header( Bar => 2 ); +is( $h->as_string, "Bar: 2\nFoo: 1\n" ); +$h->init_header( Foo => [ 2, 3 ] ); +$h->init_header( Baz => [ 2, 3 ] ); +is( $h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n" ); + +eval { $h->init_header( A => 1, B => 2, C => 3 ) }; ok($@); -is($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n"); - -is($h->clone->remove_header("Foo"), 1); -is($h->clone->remove_header("Bar"), 1); -is($h->clone->remove_header("Baz"), 2); -is($h->clone->remove_header(qw(Foo Bar Baz Not-There)), 4); -is($h->clone->remove_header("Not-There"), 0); -is(j($h->clone->remove_header("Foo")), 1); -is(j($h->clone->remove_header("Bar")), 2); -is(j($h->clone->remove_header("Baz")), "2|3"); -is(j($h->clone->remove_header(qw(Foo Bar Baz Not-There))), "1|2|2|3"); -is(j($h->clone->remove_header("Not-There")), ""); +is( $h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n" ); + +is( $h->clone->remove_header("Foo"), 1 ); +is( $h->clone->remove_header("Bar"), 1 ); +is( $h->clone->remove_header("Baz"), 2 ); +is( $h->clone->remove_header(qw(Foo Bar Baz Not-There)), 4 ); +is( $h->clone->remove_header("Not-There"), 0 ); +is( j( $h->clone->remove_header("Foo") ), 1 ); +is( j( $h->clone->remove_header("Bar") ), 2 ); +is( j( $h->clone->remove_header("Baz") ), "2|3" ); +is( j( $h->clone->remove_header(qw(Foo Bar Baz Not-There)) ), "1|2|2|3" ); +is( j( $h->clone->remove_header("Not-There") ), "" ); $h = HTTP::Headers->new( - allow => "GET", - content => "none", - content_type => "text/html", - content_md5 => "dummy", + allow => "GET", + content => "none", + content_type => "text/html", + content_md5 => "dummy", content_encoding => "gzip", - content_foo => "bar", - last_modified => "yesterday", - expires => "tomorrow", - etag => "abc", - date => "today", - user_agent => "libwww-perl", - zoo => "foo", - ); -is($h->as_string, < "bar", + last_modified => "yesterday", + expires => "tomorrow", + etag => "abc", + date => "today", + user_agent => "libwww-perl", + zoo => "foo", +); +is( $h->as_string, <clone; -is($h->as_string, $h2->as_string); +is( $h->as_string, $h2->as_string ); -is($h->remove_content_headers->as_string, <remove_content_headers->as_string, <as_string, <as_string, <remove_content_headers; -is($h->as_string, $h2->as_string); +is( $h->as_string, $h2->as_string ); $h->clear; -is($h->as_string, ""); +is( $h->as_string, "" ); undef($h2); $h = HTTP::Headers->new; -is($h->header_field_names, 0); -is(j($h->header_field_names), ""); +is( $h->header_field_names, 0 ); +is( j( $h->header_field_names ), "" ); -$h = HTTP::Headers->new( etag => 1, foo => [2,3], - content_type => "text/plain"); -is($h->header_field_names, 3); -is(j($h->header_field_names), "ETag|Content-Type|Foo"); +$h = HTTP::Headers->new( + etag => 1, foo => [ 2, 3 ], + content_type => "text/plain" +); +is( $h->header_field_names, 3 ); +is( j( $h->header_field_names ), "ETag|Content-Type|Foo" ); { my @tmp; - $h->scan(sub { push(@tmp, @_) }); - is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); + $h->scan( sub { push( @tmp, @_ ) } ); + is( j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3" ); @tmp = (); - eval { $h->scan(sub { push(@tmp, @_); die if $_[0] eq "Content-Type" }) }; + eval { + $h->scan( sub { push( @tmp, @_ ); die if $_[0] eq "Content-Type" } ); + }; ok($@); - is(j(@tmp), "ETag|1|Content-Type|text/plain"); + is( j(@tmp), "ETag|1|Content-Type|text/plain" ); @tmp = (); - $h->scan(sub { push(@tmp, @_) }); - is(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3"); + $h->scan( sub { push( @tmp, @_ ) } ); + is( j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3" ); } # CONVENIENCE METHODS $h = HTTP::Headers->new; -is($h->date, undef); -is($h->date(time), undef); -is(j($h->header_field_names), "Date"); -like($h->header("Date"), qr/^[A-Z][a-z][a-z], \d\d .* GMT$/); +is( $h->date, undef ); +is( $h->date(time), undef ); +is( j( $h->header_field_names ), "Date" ); +like( $h->header("Date"), qr/^[A-Z][a-z][a-z], \d\d .* GMT$/ ); { my $off = time - $h->date; - ok($off == 0 || $off == 1); + ok( $off == 0 || $off == 1 ); } -if ($] < 5.006) { - Test::skip("Can't call variable method", 1) for 1..13; +if ( $] < 5.006 ) { + Test::skip( "Can't call variable method", 1 ) for 1 .. 13; } else { -# other date fields -for my $field (qw(expires if_modified_since if_unmodified_since - last_modified)) -{ - eval <<'EOT'; die $@ if $@; + # other date fields + for my $field ( + qw(expires if_modified_since if_unmodified_since + last_modified) + ) { + eval <<'EOT'; die $@ if $@; is($h->$field, undef); is($h->$field(time), undef); like((time - $h->$field), qr/^[01]$/); EOT -} -is(j($h->header_field_names), "Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified"); + } + is( + j( $h->header_field_names ), + "Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified" + ); } $h->clear; -is($h->content_type, ""); -is($h->content_type(""), ""); -is($h->content_type("text/html"), ""); -is($h->content_type, "text/html"); -is($h->content_type(" TEXT / HTML ") , "text/html"); -is($h->content_type, "text/html"); -is(j($h->content_type), "text/html"); -is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "text/html"); -is($h->content_type, "text/html"); -is(j($h->content_type), "text/html|charSet = \"ISO-8859-1\"; Foo=1 "); -is($h->header("content_type"), "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "); -ok($h->content_is_html); -ok(!$h->content_is_xhtml); -ok(!$h->content_is_xml); +is( $h->content_type, "" ); +is( $h->content_type(""), "" ); +is( $h->content_type("text/html"), "" ); +is( $h->content_type, "text/html" ); +is( $h->content_type(" TEXT / HTML "), "text/html" ); +is( $h->content_type, "text/html" ); +is( j( $h->content_type ), "text/html" ); +is( + $h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), + "text/html" +); +is( $h->content_type, "text/html" ); +is( j( $h->content_type ), "text/html|charSet = \"ISO-8859-1\"; Foo=1 " ); +is( + $h->header("content_type"), + "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 " +); +ok( $h->content_is_html ); +ok( !$h->content_is_xhtml ); +ok( !$h->content_is_xml ); $h->content_type("application/vnd.wap.xhtml+xml"); -ok($h->content_is_html); -ok($h->content_is_xhtml); -ok($h->content_is_xml); +ok( $h->content_is_html ); +ok( $h->content_is_xhtml ); +ok( $h->content_is_xml ); $h->content_type("text/xml"); -ok(!$h->content_is_html); -ok(!$h->content_is_xhtml); -ok($h->content_is_xml); +ok( !$h->content_is_html ); +ok( !$h->content_is_xhtml ); +ok( $h->content_is_xml ); $h->content_type("application/xhtml+xml"); -ok($h->content_is_html); -ok($h->content_is_xhtml); -ok($h->content_is_xml); -is($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "application/xhtml+xml"); - -is($h->content_encoding, undef); -is($h->content_encoding("gzip"), undef); -is($h->content_encoding, "gzip"); -is(j($h->header_field_names), "Content-Encoding|Content-Type"); - -is($h->content_language, undef); -is($h->content_language("no"), undef); -is($h->content_language, "no"); - -is($h->title, undef); -is($h->title("This is a test"), undef); -is($h->title, "This is a test"); - -is($h->user_agent, undef); -is($h->user_agent("Mozilla/1.2"), undef); -is($h->user_agent, "Mozilla/1.2"); - -is($h->server, undef); -is($h->server("Apache/2.1"), undef); -is($h->server, "Apache/2.1"); - -is($h->from("Gisle\@ActiveState.com"), undef); -ok($h->header("from", "Gisle\@ActiveState.com")); - -is($h->referer("http://www.example.com"), undef); -is($h->referer, "http://www.example.com"); -is($h->referrer, "http://www.example.com"); -is($h->referer("http://www.example.com/#bar"), "http://www.example.com"); -is($h->referer, "http://www.example.com/"); +ok( $h->content_is_html ); +ok( $h->content_is_xhtml ); +ok( $h->content_is_xml ); +is( + $h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), + "application/xhtml+xml" +); + +is( $h->content_encoding, undef ); +is( $h->content_encoding("gzip"), undef ); +is( $h->content_encoding, "gzip" ); +is( j( $h->header_field_names ), "Content-Encoding|Content-Type" ); + +is( $h->content_language, undef ); +is( $h->content_language("no"), undef ); +is( $h->content_language, "no" ); + +is( $h->title, undef ); +is( $h->title("This is a test"), undef ); +is( $h->title, "This is a test" ); + +is( $h->user_agent, undef ); +is( $h->user_agent("Mozilla/1.2"), undef ); +is( $h->user_agent, "Mozilla/1.2" ); + +is( $h->server, undef ); +is( $h->server("Apache/2.1"), undef ); +is( $h->server, "Apache/2.1" ); + +is( $h->from("Gisle\@ActiveState.com"), undef ); +ok( $h->header( "from", "Gisle\@ActiveState.com" ) ); + +is( $h->referer("http://www.example.com"), undef ); +is( $h->referer, "http://www.example.com" ); +is( $h->referrer, "http://www.example.com" ); +is( $h->referer("http://www.example.com/#bar"), "http://www.example.com" ); +is( $h->referer, "http://www.example.com/" ); { require URI; my $u = URI->new("http://www.example.com#bar"); $h->referer($u); - is($u->as_string, "http://www.example.com#bar"); - is($h->referer->fragment, undef); - is($h->referrer->as_string, "http://www.example.com"); + is( $u->as_string, "http://www.example.com#bar" ); + is( $h->referer->fragment, undef ); + is( $h->referrer->as_string, "http://www.example.com" ); } -is($h->as_string, <as_string, <clear; -is($h->www_authenticate("foo"), undef); -is($h->www_authenticate("bar"), "foo"); -is($h->www_authenticate, "bar"); -is($h->proxy_authenticate("foo"), undef); -is($h->proxy_authenticate("bar"), "foo"); -is($h->proxy_authenticate, "bar"); - -is($h->authorization_basic, undef); -is($h->authorization_basic("u"), undef); -is($h->authorization_basic("u", "p"), "u:"); -is($h->authorization_basic, "u:p"); -is(j($h->authorization_basic), "u|p"); -is($h->authorization, "Basic dTpw"); - -is(eval { $h->authorization_basic("u2:p") }, undef); +is( $h->www_authenticate("foo"), undef ); +is( $h->www_authenticate("bar"), "foo" ); +is( $h->www_authenticate, "bar" ); +is( $h->proxy_authenticate("foo"), undef ); +is( $h->proxy_authenticate("bar"), "foo" ); +is( $h->proxy_authenticate, "bar" ); + +is( $h->authorization_basic, undef ); +is( $h->authorization_basic("u"), undef ); +is( $h->authorization_basic( "u", "p" ), "u:" ); +is( $h->authorization_basic, "u:p" ); +is( j( $h->authorization_basic ), "u|p" ); +is( $h->authorization, "Basic dTpw" ); + +is( eval { $h->authorization_basic("u2:p") }, undef ); ok($@); -is(j($h->authorization_basic), "u|p"); +is( j( $h->authorization_basic ), "u|p" ); -is($h->proxy_authorization_basic("u2", "p2"), undef); -is(j($h->proxy_authorization_basic), "u2|p2"); -is($h->proxy_authorization, "Basic dTI6cDI="); +is( $h->proxy_authorization_basic( "u2", "p2" ), undef ); +is( j( $h->proxy_authorization_basic ), "u2|p2" ); +is( $h->proxy_authorization, "Basic dTI6cDI=" ); -is($h->as_string, <as_string, <new; eval { - $line = __LINE__; $h->header('foo:', 1); + $line = __LINE__; + $h->header( 'foo:', 1 ); }; -like($@, qr/^Illegal field name 'foo:' at \Q$file\E line $line/); +like( $@, qr/^Illegal field name 'foo:' at \Q$file\E line $line/ ); eval { - $line = __LINE__; $h->header('', 2); + $line = __LINE__; + $h->header( '', 2 ); }; -like($@, qr/^Illegal field name '' at \Q$file\E line $line/); - - +like( $@, qr/^Illegal field name '' at \Q$file\E line $line/ ); #---- old tests below ----- $h = HTTP::Headers->new( - mime_version => "1.0", - content_type => "text/html" + mime_version => "1.0", + content_type => "text/html" ); -$h->header(URI => "http://www.oslonett.no/"); +$h->header( URI => "http://www.oslonett.no/" ); -is($h->header("MIME-Version"), "1.0"); -is($h->header('Uri'), "http://www.oslonett.no/"); +is( $h->header("MIME-Version"), "1.0" ); +is( $h->header('Uri'), "http://www.oslonett.no/" ); -$h->header("MY-header" => "foo", - "Date" => "somedate", - "Accept" => ["text/plain", "image/*"], - ); -$h->push_header("accept" => "audio/basic"); +$h->header( + "MY-header" => "foo", + "Date" => "somedate", + "Accept" => [ "text/plain", "image/*" ], +); +$h->push_header( "accept" => "audio/basic" ); -is($h->header("date"), "somedate"); +is( $h->header("date"), "somedate" ); my @accept = $h->header("accept"); -is(@accept, 3); +is( @accept, 3 ); -$h->remove_header("uri", "date"); +$h->remove_header( "uri", "date" ); -my $str = $h->as_string; -my $lines = ($str =~ tr/\n/\n/); -is($lines, 6); +my $str = $h->as_string; +my $lines = ( $str =~ tr/\n/\n/ ); +is( $lines, 6 ); $h2 = $h->clone; -$h->header("accept", "*/*"); +$h->header( "accept", "*/*" ); $h->remove_header("my-header"); @accept = $h2->header("accept"); -is(@accept, 3); +is( @accept, 3 ); @accept = $h->header("accept"); -is(@accept, 1); +is( @accept, 1 ); # Check order of headers, but first remove this one $h2->remove_header('mime_version'); # and add this general header -$h2->header(Connection => 'close'); +$h2->header( Connection => 'close' ); my @x = (); -$h2->scan(sub {push(@x, shift);}); -is(join(";", @x), "Connection;Accept;Accept;Accept;Content-Type;MY-Header"); +$h2->scan( sub { push( @x, shift ); } ); +is( + join( ";", @x ), + "Connection;Accept;Accept;Accept;Content-Type;MY-Header" +); # Check headers with embedded newlines: $h = HTTP::Headers->new( - a => "foo\n\n", - b => "foo\nbar", - c => "foo\n\nbar\n\n", - d => "foo\n\tbar", - e => "foo\n bar ", - f => "foo\n bar\n baz\nbaz", - ); -is($h->as_string("<<\n"), < "foo\n\n", + b => "foo\nbar", + c => "foo\n\nbar\n\n", + d => "foo\n\tbar", + e => "foo\n bar ", + f => "foo\n bar\n baz\nbaz", +); +is( $h->as_string("<<\n"), <new( - a => "foo\r\n\r\nevil body" , - b => "foo\015\012\015\012evil body" , - c => "foo\x0d\x0a\x0d\x0aevil body" , +$h = HTTP::Headers->new( + a => "foo\r\n\r\nevil body", + b => "foo\015\012\015\012evil body", + c => "foo\x0d\x0a\x0d\x0aevil body", ); -is ( +is( $h->as_string(), - "A: foo\r\n evil body\n". - "B: foo\015\012 evil body\n" . - "C: foo\x0d\x0a evil body\n" , - "embedded CRLF are stripped out"); + "A: foo\r\n evil body\n" + . "B: foo\015\012 evil body\n" + . "C: foo\x0d\x0a evil body\n", + "embedded CRLF are stripped out" +); # Check with FALSE $HTML::Headers::TRANSLATE_UNDERSCORE { - local($HTTP::Headers::TRANSLATE_UNDERSCORE); - $HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning + local ($HTTP::Headers::TRANSLATE_UNDERSCORE); + $HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning $h = HTTP::Headers->new; - $h->header(abc_abc => "foo"); - $h->header("abc-abc" => "bar"); - - is($h->header("ABC_ABC"), "foo"); - is($h->header("ABC-ABC"),"bar"); - ok($h->remove_header("Abc_Abc")); - ok(!defined($h->header("abc_abc"))); - is($h->header("ABC-ABC"), "bar"); + $h->header( abc_abc => "foo" ); + $h->header( "abc-abc" => "bar" ); + + is( $h->header("ABC_ABC"), "foo" ); + is( $h->header("ABC-ABC"), "bar" ); + ok( $h->remove_header("Abc_Abc") ); + ok( !defined( $h->header("abc_abc") ) ); + is( $h->header("ABC-ABC"), "bar" ); } # Check if objects as header values works require URI; -$h->header(URI => URI->new("http://www.perl.org")); +$h->header( URI => URI->new("http://www.perl.org") ); -is($h->header("URI")->scheme, "http"); +is( $h->header("URI")->scheme, "http" ); $h->clear; -is($h->as_string, ""); +is( $h->as_string, "" ); $h->content_type("text/plain"); -$h->header(content_md5 => "dummy"); -$h->header("Content-Foo" => "foo"); -$h->header(Location => "http:", xyzzy => "plugh!"); +$h->header( content_md5 => "dummy" ); +$h->header( "Content-Foo" => "foo" ); +$h->header( Location => "http:", xyzzy => "plugh!" ); -is($h->as_string, <as_string, <remove_content_headers; -is($h->as_string, <as_string, <as_string, <as_string, <new; $h->content_type("text/plain"); -$h->header(":foo_bar", 1); -$h->push_header(":content_type", "text/html"); -is(j($h->header_field_names), "Content-Type|:content_type|:foo_bar"); -is($h->header('Content-Type'), "text/plain"); -is($h->header(':Content_Type'), undef); -is($h->header(':content_type'), "text/html"); -is($h->as_string, <header( ":foo_bar", 1 ); +$h->push_header( ":content_type", "text/html" ); +is( j( $h->header_field_names ), "Content-Type|:content_type|:foo_bar" ); +is( $h->header('Content-Type'), "text/plain" ); +is( $h->header(':Content_Type'), undef ); +is( $h->header(':content_type'), "text/html" ); +is( $h->as_string, <new; -ok(!defined $h->warning('foo', 'INIT')); -is($h->warning('bar'), 'foo'); -is($h->warning('baz', 'GET'), 'bar'); -is($h->as_string, <warning( 'foo', 'INIT' ) ); +is( $h->warning('bar'), 'foo' ); +is( $h->warning( 'baz', 'GET' ), 'bar' ); +is( $h->as_string, <new; -ok(!defined $h->header(':foo', 'bar')); -ok(!defined $h->header(':zap', 'bang')); -$h->push_header(':zap', ['kapow', 'shazam']); -is(j($h->header_field_names), ':foo|:zap'); -is(j($h->header_field_names), ':foo|:zap'); -$h->scan(sub { $_[1] .= '!' }); -is(j($h->header(':zap')), 'bang!|kapow!|shazam!'); -is(j($h->header(':foo')), 'bar'); -is($h->as_string, <header( ':foo', 'bar' ) ); +ok( !defined $h->header( ':zap', 'bang' ) ); +$h->push_header( ':zap', [ 'kapow', 'shazam' ] ); +is( j( $h->header_field_names ), ':foo|:zap' ); +is( j( $h->header_field_names ), ':foo|:zap' ); +$h->scan( sub { $_[1] .= '!' } ); +is( j( $h->header(':zap') ), 'bang!|kapow!|shazam!' ); +is( j( $h->header(':foo') ), 'bar' ); +is( $h->as_string, <remove_header(':zap')), 'bang!|kapow!|shazam!'); -$h->push_header(':zap', 'whomp', ':foo', 'quux'); -is(j($h->header(':foo')), 'bar|quux'); +is( j( $h->remove_header(':zap') ), 'bang!|kapow!|shazam!' ); +$h->push_header( ':zap', 'whomp', ':foo', 'quux' ); +is( j( $h->header(':foo') ), 'bar|quux' ); # [RT#30579] IE6 appends "; length = NNNN" on If-Modified-Since (can we handle it) $h = HTTP::Headers->new( - if_modified_since => "Sat, 29 Oct 1994 19:43:31 GMT; length=34343" -); -is(gmtime($h->if_modified_since), "Sat Oct 29 19:43:31 1994"); + if_modified_since => "Sat, 29 Oct 1994 19:43:31 GMT; length=34343" ); +is( gmtime( $h->if_modified_since ), "Sat Oct 29 19:43:31 1994" ); $h = HTTP::Headers->new(); $h->content_type('text/plain'); $h->content_length(4); -$h->push_header('x-foo' => 'bar'); -$h->push_header('x-foo' => 'baz'); -is(0+$h->flatten, 8); +$h->push_header( 'x-foo' => 'bar' ); +$h->push_header( 'x-foo' => 'baz' ); +is( 0 + $h->flatten, 8 ); is_deeply( [ $h->flatten ], [ @@ -520,7 +540,7 @@ is_deeply( subtest 'object that stringifies is a valid value' => sub { my $h = HTTP::Headers->new; - $h->header('X-Password' => Secret->new('hunter2')); + $h->header( 'X-Password' => Secret->new('hunter2') ); my $h2 = $h->clone; - is($h2->as_string, "X-Password: hunter2\n", 'correct headers'); + is( $h2->as_string, "X-Password: hunter2\n", 'correct headers' ); }; diff --git a/t/http-config.t b/t/http-config.t index 0e064674..943f6b86 100644 --- a/t/http-config.t +++ b/t/http-config.t @@ -6,110 +6,125 @@ plan tests => 30; use HTTP::Config; -sub j { join("|", @_) } +sub j { join( "|", @_ ) } my $conf = HTTP::Config->new; -ok($conf->empty); -is($conf->entries, 0); +ok( $conf->empty ); +is( $conf->entries, 0 ); $conf->add_item(42); -ok(!$conf->empty); -is($conf->entries, 1); -is(j($conf->matching_items("http://www.example.com/foo")), 42); -is(j($conf->remove_items), 42); -is(j($conf->remove_items), ''); -is($conf->matching_items("http://www.example.com/foo"), 0); -is($conf->matching_items('foo', 'bar', 'baz'), 0); -$conf->add({item => "http://www.example.com/foo", m_uri__HEAD => undef}); -is($conf->entries, 1); -is($conf->matching_items("http://www.example.com/foo"), 0); +ok( !$conf->empty ); +is( $conf->entries, 1 ); +is( j( $conf->matching_items("http://www.example.com/foo") ), 42 ); +is( j( $conf->remove_items ), 42 ); +is( j( $conf->remove_items ), '' ); +is( $conf->matching_items("http://www.example.com/foo"), 0 ); +is( $conf->matching_items( 'foo', 'bar', 'baz' ), 0 ); +$conf->add( { item => "http://www.example.com/foo", m_uri__HEAD => undef } ); +is( $conf->entries, 1 ); +is( $conf->matching_items("http://www.example.com/foo"), 0 ); SKIP: { - my $res; - eval { $res = $conf->matching_items(0); }; - skip "can fails on non-object", 2 if $@; - is($res, 0); - eval { $res = $conf->matching(0); }; - ok(!defined $res); + my $res; + eval { $res = $conf->matching_items(0); }; + skip "can fails on non-object", 2 if $@; + is( $res, 0 ); + eval { $res = $conf->matching(0); }; + ok( !defined $res ); } $conf = HTTP::Config->new; $conf->add_item("always"); -$conf->add_item("GET", m_method => ["GET", "HEAD"]); -$conf->add_item("POST", m_method => "POST"); -$conf->add_item(".com", m_domain => ".com"); -$conf->add_item("secure", m_secure => 1); -$conf->add_item("not secure", m_secure => 0); -$conf->add_item("slash", m_host_port => "www.example.com:80", m_path_prefix => "/"); -$conf->add_item("u:p", m_host_port => "www.example.com:80", m_path_prefix => "/foo"); -$conf->add_item("success", m_code => "2xx"); -is($conf->find(m_domain => ".com")->{item}, '.com'); -my @found = $conf->find(m_domain => ".com"); -is($#found, 0); -is($found[0]->{item}, '.com'); +$conf->add_item( "GET", m_method => [ "GET", "HEAD" ] ); +$conf->add_item( "POST", m_method => "POST" ); +$conf->add_item( ".com", m_domain => ".com" ); +$conf->add_item( "secure", m_secure => 1 ); +$conf->add_item( "not secure", m_secure => 0 ); +$conf->add_item( + "slash", m_host_port => "www.example.com:80", + m_path_prefix => "/" +); +$conf->add_item( + "u:p", m_host_port => "www.example.com:80", + m_path_prefix => "/foo" +); +$conf->add_item( "success", m_code => "2xx" ); +is( $conf->find( m_domain => ".com" )->{item}, '.com' ); +my @found = $conf->find( m_domain => ".com" ); +is( $#found, 0 ); +is( $found[0]->{item}, '.com' ); use HTTP::Request; -my $request = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar"); -$request->header("User-Agent" => "Moz/1.0"); +my $request = HTTP::Request->new( HEAD => "http://www.example.com/foo/bar" ); +$request->header( "User-Agent" => "Moz/1.0" ); -is(j($conf->matching_items($request)), "u:p|slash|.com|GET|not secure|always"); +is( + j( $conf->matching_items($request) ), + "u:p|slash|.com|GET|not secure|always" +); $request->method("HEAD"); $request->uri->scheme("https"); -is(j($conf->matching_items($request)), ".com|GET|secure|always"); +is( j( $conf->matching_items($request) ), ".com|GET|secure|always" ); -is(j($conf->matching_items("http://activestate.com")), ".com|not secure|always"); +is( + j( $conf->matching_items("http://activestate.com") ), + ".com|not secure|always" +); use HTTP::Response; -my $response = HTTP::Response->new(200 => "OK"); +my $response = HTTP::Response->new( 200 => "OK" ); $response->content_type("text/plain"); $response->content("Hello, world!\n"); $response->request($request); -is(j($conf->matching_items($response)), ".com|success|GET|secure|always"); +is( j( $conf->matching_items($response) ), ".com|success|GET|secure|always" ); -$conf->remove_items(m_secure => 1); -$conf->remove_items(m_domain => ".com"); -is(j($conf->matching_items($response)), "success|GET|always"); +$conf->remove_items( m_secure => 1 ); +$conf->remove_items( m_domain => ".com" ); +is( j( $conf->matching_items($response) ), "success|GET|always" ); -$conf->remove_items; # start fresh -is(j($conf->matching_items($response)), ""); +$conf->remove_items; # start fresh +is( j( $conf->matching_items($response) ), "" ); -$conf->add_item("any", "m_media_type" => "*/*"); -$conf->add_item("text", m_media_type => "text/*"); -$conf->add_item("html", m_media_type => "html"); -$conf->add_item("HTML", m_media_type => "text/html"); -$conf->add_item("xhtml", m_media_type => "xhtml"); +$conf->add_item( "any", "m_media_type" => "*/*" ); +$conf->add_item( "text", m_media_type => "text/*" ); +$conf->add_item( "html", m_media_type => "html" ); +$conf->add_item( "HTML", m_media_type => "text/html" ); +$conf->add_item( "xhtml", m_media_type => "xhtml" ); -is(j($conf->matching_items($response)), "text|any"); +is( j( $conf->matching_items($response) ), "text|any" ); $response->content_type("application/xhtml+xml"); -is(j($conf->matching_items($response)), "xhtml|html|any"); +is( j( $conf->matching_items($response) ), "xhtml|html|any" ); $response->content_type("text/html"); -is(j($conf->matching_items($response)), "HTML|html|text|any"); +is( j( $conf->matching_items($response) ), "HTML|html|text|any" ); $response->request(undef); -is(j($conf->matching_items($response)), "HTML|html|text|any"); +is( j( $conf->matching_items($response) ), "HTML|html|text|any" ); { my @warnings; - local $SIG{__WARN__} = sub { push @warnings, grep { length } @_ }; + local $SIG{__WARN__} = sub { + push @warnings, grep { length } @_; + }; my $conf = HTTP::Config->new; - $conf->add(owner => undef, callback => sub { 'bleah' }); - $conf->remove(owner => undef); + $conf->add( owner => undef, callback => sub { 'bleah' } ); + $conf->remove( owner => undef ); - ok(($conf->empty), 'found and removed the config entry'); - is(scalar(@warnings), 0, 'no warnings') - or diag('got warnings: ', explain(\@warnings)); + ok( ( $conf->empty ), 'found and removed the config entry' ); + is( scalar(@warnings), 0, 'no warnings' ) + or diag( 'got warnings: ', explain( \@warnings ) ); @warnings = (); - $conf->add_item("bond", m_header__user_agent => 'james/0.0.7'); - my $request2 = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar"); - is(j($conf->matching_items($request2)), ''); + $conf->add_item( "bond", m_header__user_agent => 'james/0.0.7' ); + my $request2 + = HTTP::Request->new( HEAD => "http://www.example.com/foo/bar" ); + is( j( $conf->matching_items($request2) ), '' ); - is(scalar(@warnings), 0, 'no warnings') - or diag('got warnings: ', explain(\@warnings)); + is( scalar(@warnings), 0, 'no warnings' ) + or diag( 'got warnings: ', explain( \@warnings ) ); } diff --git a/t/lib/Secret.pm b/t/lib/Secret.pm index 48b2516b..547eea71 100644 --- a/t/lib/Secret.pm +++ b/t/lib/Secret.pm @@ -10,7 +10,7 @@ use overload ( sub new { my ( $class, $s ) = @_; - return bless sub {$s}, $class; + return bless sub { $s }, $class; } sub to_string { shift->(); } diff --git a/t/message-brotli.t b/t/message-brotli.t index 6c396f58..9dcb6a36 100644 --- a/t/message-brotli.t +++ b/t/message-brotli.t @@ -30,8 +30,10 @@ subtest "encoding" => sub { "Hello world!" ); ok( $m->encode("br"), "set encoding to 'br" ); - is( $m->header("Content-Encoding"), - "br", "... and Content-Encoding is set" ); + is( + $m->header("Content-Encoding"), + "br", "... and Content-Encoding is set" + ); isnt( $m->content, "Hello world!", "... and the content has changed" ); is( $m->decoded_content, "Hello world!", "decoded_content() works" ); ok( $m->decode, "decode() works" ); diff --git a/t/message-charset.t b/t/message-charset.t index f6ad9f4f..63a16c11 100644 --- a/t/message-charset.t +++ b/t/message-charset.t @@ -5,120 +5,120 @@ use Test::More; plan tests => 43; use HTTP::Response; -my $r = HTTP::Response->new(200, "OK"); -is($r->content_charset, undef); -is($r->content_type_charset, undef); +my $r = HTTP::Response->new( 200, "OK" ); +is( $r->content_charset, undef ); +is( $r->content_type_charset, undef ); $r->content_type("text/plain"); -is($r->content_charset, undef); +is( $r->content_charset, undef ); $r->content("abc"); -is($r->content_charset, "US-ASCII"); +is( $r->content_charset, "US-ASCII" ); $r->content("f\xE5rep\xF8lse\n"); -is($r->content_charset, "ISO-8859-1"); +is( $r->content_charset, "ISO-8859-1" ); $r->content("f\xC3\xA5rep\xC3\xB8lse\n"); -is($r->content_charset, "UTF-8"); +is( $r->content_charset, "UTF-8" ); $r->content_type("text/html"); $r->content(<<'EOT'); EOT -is($r->content_charset, "UTF-8"); +is( $r->content_charset, "UTF-8" ); $r->content(<<'EOT'); EOT -is($r->content_charset, "UTF-8"); +is( $r->content_charset, "UTF-8" ); $r->content(<<'EOT');