From d231eb5827ba2d292bdfa468ac646162c9e49ebf Mon Sep 17 00:00:00 2001 From: yoshikazusawa <883514+yoshikazusawa@users.noreply.github.com> Date: Wed, 30 Oct 2024 09:40:29 +0900 Subject: [PATCH 1/3] Fix perltidyrc path error on CONTRIBUTING.md --- CONTRIBUTING.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 818642ae..4664dc54 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -37,7 +37,7 @@ You can run tests directly using the `prove` tool: ## Code style and tidying -This distribution contains a `.perltidyrc` file in the root of the repository. +This distribution contains a `perltidyrc` file in the root of the repository. Please install Perl::Tidy and use `perltidy` before submitting patches. However, as this is an old distribution and styling has changed somewhat over the years, please keep your tidying constrained to the portion of code or function in which @@ -48,7 +48,7 @@ you're patching. $ rm my_tidy_copy.pm The above command, for example, would provide you with a copy of `Status.pm` -that has been cleaned according to our `.perltidyrc` settings. You'd then look +that has been cleaned according to our `perltidyrc` settings. You'd then look at the newly created `my_tidy_copy.pm` in the dist root and replace your work with the cleaned up copy if there are differences. From 52281123dcad9433f5061a7586fd69f0313427aa Mon Sep 17 00:00:00 2001 From: yoshikazusawa <883514+yoshikazusawa@users.noreply.github.com> Date: Sun, 3 Nov 2024 10:31:54 +0900 Subject: [PATCH 2/3] Tidy some files that have not been modified in the currently open Pull Requests as of 2024/11/3. comm -23 <(git ls-files | sort) <(echo -n "8,16,23,25,35,93,99,117,122,141" | xargs -d, -I% sh -c 'git diff --name-only master...remotes/pr/%/head' | sort | uniq) | grep -E -e 'lib/' -e 't/.*\.t$' | xargs perltidy -b --- lib/HTTP/Headers/Auth.pm | 138 ++++++++--------- lib/HTTP/Headers/ETag.pm | 78 +++++----- lib/HTTP/Headers/Util.pm | 131 ++++++++-------- t/common-req.t | 283 ++++++++++++++++++---------------- t/headers-auth.t | 39 +++-- t/headers-etag.t | 24 +-- t/headers-util.t | 58 +++---- t/lib/Secret.pm | 2 +- t/message-charset.t | 94 +++++------ t/message-decode-brotlibomb.t | 69 +++++---- t/message-decode-bzipbomb.t | 82 +++++----- t/message-decode-xml.t | 16 +- t/message-decode-zipbomb.t | 77 +++++---- t/message-old.t | 77 ++++----- t/request_type_with_data.t | 14 +- t/response.t | 208 +++++++++++++------------ t/status-old.t | 16 +- t/status.t | 94 +++++------ 18 files changed, 783 insertions(+), 717 deletions(-) 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..0ee6dd41 100644 --- a/lib/HTTP/Headers/Util.pm +++ b/lib/HTTP/Headers/Util.pm @@ -7,90 +7,91 @@ 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/t/common-req.t b/t/common-req.t index 0e4949d6..fe24644c 100644 --- a/t/common-req.t +++ b/t/common-req.t @@ -10,103 +10,102 @@ 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'); +$r = HEAD "http://www.sn.no/", 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'; +$r = PUT "http://www.sn.no", 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"); +$r = PUT "http://www.sn.no", { foo => "bar" }; +is( $r->content, "foo=bar" ); -$r = OPTIONS "http://www.sn.no", - Content => 'foo'; +$r = OPTIONS "http://www.sn.no", 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"); +$r = OPTIONS "http://www.sn.no", { foo => "bar" }; +is( $r->content, "foo=bar" ); -$r = PATCH "http://www.sn.no", - { foo => "bar" }; -is($r->content, "foo=bar"); +$r = PATCH "http://www.sn.no", { 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,123 +117,138 @@ 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, <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..95e23bac 100644 --- a/t/headers-auth.t +++ b/t/headers-auth.t @@ -9,40 +9,47 @@ 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..be62230c 100644 --- a/t/headers-util.t +++ b/t/headers-util.t @@ -7,42 +7,44 @@ 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/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-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');