From 8dc56460d16e09fe1fcb82045f123876753c23d6 Mon Sep 17 00:00:00 2001 From: yoshikazusawa <883514+yoshikazusawa@users.noreply.github.com> Date: Wed, 30 Oct 2024 09:33:22 +0900 Subject: [PATCH 1/3] Tidy up all .pm and .t --- lib/HTTP/Config.pm | 120 ++-- lib/HTTP/Headers.pm | 470 +++++++------- lib/HTTP/Headers/Auth.pm | 138 ++-- lib/HTTP/Headers/ETag.pm | 78 ++- lib/HTTP/Headers/Util.pm | 130 ++-- lib/HTTP/Message.pm | 1140 +++++++++++++++++---------------- lib/HTTP/Request.pm | 133 ++-- lib/HTTP/Request/Common.pm | 466 +++++++------- lib/HTTP/Response.pm | 320 +++++---- lib/HTTP/Status.pm | 164 ++--- t/common-req.t | 279 ++++---- t/headers-auth.t | 42 +- t/headers-etag.t | 24 +- t/headers-util.t | 60 +- t/headers.t | 576 +++++++++-------- t/http-config.t | 141 ++-- t/lib/Secret.pm | 2 +- t/message-brotli.t | 6 +- t/message-charset.t | 94 +-- t/message-decode-brotlibomb.t | 73 ++- t/message-decode-bzipbomb.t | 79 ++- t/message-decode-xml.t | 18 +- t/message-decode-zipbomb.t | 80 ++- t/message-old.t | 77 +-- t/message-parts.t | 130 ++-- t/message.t | 617 +++++++++--------- t/request.t | 69 +- t/request_type_with_data.t | 14 +- t/response.t | 208 +++--- t/status-old.t | 16 +- t/status.t | 96 +-- 31 files changed, 3036 insertions(+), 2824 deletions(-) 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..34ce8b4d 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__ 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..50c7db59 100644 --- a/lib/HTTP/Headers/ETag.pm +++ b/lib/HTTP/Headers/ETag.pm @@ -8,49 +8,47 @@ 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 @@ -61,36 +59,34 @@ sub if_range { # 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');