[libcgi-test-perl] 01/02: Added header handling in Page, with content-length being special case
Axel Beckert
abe at deuxchevaux.org
Mon Jan 11 00:38:31 UTC 2016
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 <nohuhu at 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 at 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
More information about the Pkg-perl-cvs-commits
mailing list