This is an automated email from the git hooks/post-receive script. abe pushed a commit to annotated tag 1.100 in repository libcgi-test-perl.
commit 8c9a602c286e21388bd2468648c897cfc34587bb Author: Alex Tokarev <noh...@nohuhu.org> Date: Tue Mar 3 23:02:49 2015 -0800 Added header handling in Page, with content-length being special case --- lib/CGI/Test/Page.pm | 35 ++++++++++++++++++++++++ lib/CGI/Test/Page/Real.pm | 30 ++++++++++++--------- t/02_parsing.t | 17 +++++++++++- t/cgi/dumpargs | 3 ++- t/cgi/dumpargs.bat | 4 +-- t/cgi/getform | 69 ++++++++++++++++++++++++++--------------------- t/cgi/getform.bat | 67 +++++++++++++++++++++++++-------------------- 7 files changed, 150 insertions(+), 75 deletions(-) diff --git a/lib/CGI/Test/Page.pm b/lib/CGI/Test/Page.pm index 98ee7c7..be6de35 100644 --- a/lib/CGI/Test/Page.pm +++ b/lib/CGI/Test/Page.pm @@ -47,6 +47,41 @@ sub raw_content_ref { return \$self->{raw_content}; } +sub headers { + my ($self) = @_; + + return $self->{headers} || {}; +} + +sub header { + my ($self, $hdr) = @_; + + my %header = %{ $self->headers }; + + my $value; + + $hdr = lc $hdr; + + # We're not concerned with performance here and would rather save + # the original headers as they were; hence searching instead of + # lowercasing header keys in _read_raw_content. + while ( my ($k, $v) = each %header ) { + if ( $hdr eq lc $k ) { + $value = $v; + last; + } + } + + return $value; +} + +###################################################################### +sub content_length +{ + my $this = shift; + return $this->{content_length}; +} + ###################################################################### sub content_type { diff --git a/lib/CGI/Test/Page/Real.pm b/lib/CGI/Test/Page/Real.pm index f242338..b6804e3 100644 --- a/lib/CGI/Test/Page/Real.pm +++ b/lib/CGI/Test/Page/Real.pm @@ -73,24 +73,30 @@ sub _init # sub _read_raw_content { - my $this = shift; - my ($file) = @_; + my ($self, $file_name) = @_; + + open my $fh, $file_name || die "Can't open $file_name: $!"; + + my %headers; + my $content_length; - local *FILE; - open(FILE, $file) || die "can't open $file: $!"; - my $size = -s FILE; + while (my $line = <$fh>) { + last if $line =~ /^\r?$/; - $this->{raw_content} = ' ' x -s (FILE); # Pre-extend buffer + $line =~ s/\r\n$//; - local $_; - while (<FILE>) - { # Skip header - last if /^\r?$/; + my ($h, $v) = $line =~ /^(.*?):\s+(.*)$/; + $headers{ $h } = $v if defined $h; + + $content_length = $v if $h =~ /content[-_]length/i; } + $self->{headers} = \%headers; + $self->{content_length} = $content_length; + local $/ = undef; # Will slurp remaining - $this->{raw_content} = <FILE>; - close FILE; + $self->{raw_content} = <$fh>; + close $fh; return; } diff --git a/t/02_parsing.t b/t/02_parsing.t index f0321a3..d01424c 100644 --- a/t/02_parsing.t +++ b/t/02_parsing.t @@ -4,7 +4,7 @@ use warnings; use Config; use URI; -use Test::More tests => 44; +use Test::More tests => 49; use CGI::Test; @@ -30,6 +30,21 @@ ok $page->is_ok, "Page OK"; ok !$page->is_error, "No errors in page " . $page->error_code; ok $raw_length, "Got raw content length: $raw_length"; + +my $content_length = $page->content_length; +is $content_length, $raw_length, "Page content-length matches"; + +my $headers = $page->headers; + +is 'HASH', ref($headers), "Headers hashref defined"; +ok exists $headers->{'Content-Type'}, "Content-Type header exists in hashref"; + +$content_length = $page->header('CoNtEnT-LenGTh'); +is $content_length, $raw_length, "Header content-length matches"; + +my $content_type = $page->header('content-type'); +like $content_type, qr|^text/html\b|, "Header Content-Type matches"; + like $page->content_type, qr|^text/html\b|, "Page content type matches"; my $forms = $page->forms; diff --git a/t/cgi/dumpargs b/t/cgi/dumpargs index d81f594..5cf2f86 100755 --- a/t/cgi/dumpargs +++ b/t/cgi/dumpargs @@ -10,6 +10,8 @@ open STDIN, '<&3' or die "Can't reopen STDIN"; print header(-type => "text/plain"); +local $CGI::LIST_CONTEXT_WARN = 0; + foreach my $name (param()) { my @value = param($name); foreach (@value) { tr/\n/ /; } @@ -17,4 +19,3 @@ foreach my $name (param()) { } END_OF_SCRIPT - diff --git a/t/cgi/dumpargs.bat b/t/cgi/dumpargs.bat index 91bcc89..180a469 100644 --- a/t/cgi/dumpargs.bat +++ b/t/cgi/dumpargs.bat @@ -17,13 +17,13 @@ use CGI qw/:standard/; print header(-type => "text/plain"); +local $CGI::LIST_CONTEXT_WARN = 0; + foreach my $name (param()) { my @value = param($name); foreach (@value) { tr/\n/ /; } print "$name\t@value\n"; } - __END__ :endofperl - diff --git a/t/cgi/getform b/t/cgi/getform index 623c3d0..c8dcd15 100755 --- a/t/cgi/getform +++ b/t/cgi/getform @@ -8,74 +8,78 @@ use CGI qw/:standard :no_xhtml/; # 2 argument open here for older Perls open STDIN, '<&3' or die "Can't reopen STDIN"; -$\ = "\n"; +local $CGI::LIST_CONTEXT_WARN = 0; + +my $content = ''; -print header; my $method = param("method") || request_method(); my $action = param("action") || url(); -print start_html("$method form"), h1("$method form"); -print start_form( - -method => $method eq "POST" ? "POST" : "GET", - -enctype => param("enctype") eq "M" ? + +$content .= start_html("$method form"); +$content .= h1("$method form"); +$content .= start_form( + -action => $action, + -method => $method eq "POST" ? "POST" : "GET", + -enctype => param("enctype") eq "M" ? "multipart/form-data" : "application/x-www-form-urlencoded", - -action => $action, ); my $counter = param("counter") + 1; param("counter", $counter); -print hidden("counter"); -print hidden("enctype"); -print "Title: ", radio_group( +$content .= hidden("counter"); +$content .= hidden("enctype"); + +$content .= "Title: " . radio_group( -name => "title", -values => [qw(Mr Ms Miss)], - -default => 'Mr'), br; + -default => 'Mr' +) . br; -print "Name: ", textfield("name"), br; +$content .= "Name: " . textfield("name") . br; -print "Skills: ", checkbox_group( +$content .= "Skills: " . checkbox_group( -name => "skills", -values => [qw(cooking drawing teaching listening)], -defaults => ['listening'], -), br; +) . br; -print "New here: ", checkbox( +$content .= "New here: " . checkbox( -name => "new", -checked => 1, -value => "ON", -label => "click me", -), br; - +) . br; -print "Color: ", popup_menu( +$content .= "Color: " . popup_menu( -name => "color", -values => [qw(white black green red blue)], -default => "white", -), br; +) . br; -print "Note: ", textarea("note"), br; +$content .= "Note: " . textarea("note") . br; -print "Prefers: ", scrolling_list( +$content .= "Prefers: " . scrolling_list( -name => "months", -values => [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)], -size => 5, -multiple => 1, -default => [qw(Jul)], -), br; +) . br; -print "Password: ", password_field( +$content .= "Password: " . password_field( -name => "passwd", -size => 10, -maxlength => 15, -), br; +) . br; -print "Portrait: ", filefield( +$content .= "Portrait: " . filefield( -name => "portrait", -size => 30, -maxlength => 80, -), br; +) . br; -print p( +$content .= p( reset(), defaults("default"), submit("Send"), @@ -89,8 +93,13 @@ print p( ), ); -print end_form; -print end_html; +$content .= end_form; +$content .= end_html; -END_OF_SCRIPT +print header( + -Content_Length => length $content, +); +print $content; + +END_OF_SCRIPT diff --git a/t/cgi/getform.bat b/t/cgi/getform.bat index 313d046..fe25243 100644 --- a/t/cgi/getform.bat +++ b/t/cgi/getform.bat @@ -15,74 +15,78 @@ goto endofperl use CGI qw/:standard :no_xhtml/; -$\ = "\n"; +local $CGI::LIST_CONTEXT_WARN = 0; + +my $content = ''; -print header; my $method = param("method") || request_method(); my $action = param("action") || url(); -print start_html("$method form"), h1("$method form"); -print start_form( - -method => $method eq "POST" ? "POST" : "GET", - -enctype => param("enctype") eq "M" ? + +$content .= start_html("$method form"); +$content .= h1("$method form"); +$content .= start_form( + -action => $action, + -method => $method eq "POST" ? "POST" : "GET", + -enctype => param("enctype") eq "M" ? "multipart/form-data" : "application/x-www-form-urlencoded", - -action => $action, ); my $counter = param("counter") + 1; param("counter", $counter); -print hidden("counter"); -print hidden("enctype"); -print "Title: ", radio_group( +$content .= hidden("counter"); +$content .= hidden("enctype"); + +$content .= "Title: " . radio_group( -name => "title", -values => [qw(Mr Ms Miss)], - -default => 'Mr'), br; + -default => 'Mr' +) . br; -print "Name: ", textfield("name"), br; +$content .= "Name: " . textfield("name") . br; -print "Skills: ", checkbox_group( +$content .= "Skills: " . checkbox_group( -name => "skills", -values => [qw(cooking drawing teaching listening)], -defaults => ['listening'], -), br; +) . br; -print "New here: ", checkbox( +$content .= "New here: " . checkbox( -name => "new", -checked => 1, -value => "ON", -label => "click me", -), br; +) . br; - -print "Color: ", popup_menu( +$content .= "Color: " . popup_menu( -name => "color", -values => [qw(white black green red blue)], -default => "white", -), br; +) . br; -print "Note: ", textarea("note"), br; +$content .= "Note: " . textarea("note") . br; -print "Prefers: ", scrolling_list( +$content .= "Prefers: " . scrolling_list( -name => "months", -values => [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)], -size => 5, -multiple => 1, -default => [qw(Jul)], -), br; +) . br; -print "Password: ", password_field( +$content .= "Password: " . password_field( -name => "passwd", -size => 10, -maxlength => 15, -), br; +) . br; -print "Portrait: ", filefield( +$content .= "Portrait: " . filefield( -name => "portrait", -size => 30, -maxlength => 80, -), br; +) . br; -print p( +$content .= p( reset(), defaults("default"), submit("Send"), @@ -96,9 +100,14 @@ print p( ), ); -print end_form; -print end_html; +$content .= end_form; +$content .= end_html; + +print header( + -Content_Length => length $content, +); +print $content; __END__ :endofperl -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcgi-test-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits