[libcgi-emulate-psgi-perl] 04/20: Imported Upstream version 0.12
dom at earth.li
dom at earth.li
Sun Oct 5 09:22:49 UTC 2014
This is an automated email from the git hooks/post-receive script.
dom pushed a commit to branch master
in repository libcgi-emulate-psgi-perl.
commit d43bec865e6e464ecfcc2e370b6740a1a9448bd7
Author: Dominic Hargreaves <dom at earth.li>
Date: Mon Aug 29 13:24:03 2011 +0100
Imported Upstream version 0.12
---
Changes | 7 +
MANIFEST | 4 +
META.yml | 4 +-
Makefile.PL | 1 +
README | 4 +-
README.mkdn | 59 +++++--
inc/Module/Install.pm | 12 +-
inc/Module/Install/Base.pm | 2 +-
inc/Module/Install/Can.pm | 2 +-
inc/Module/Install/Fetch.pm | 2 +-
inc/Module/Install/Include.pm | 2 +-
inc/Module/Install/Makefile.pm | 12 +-
inc/Module/Install/Metadata.pm | 20 ++-
inc/Module/Install/ReadmeFromPod.pm | 34 ++--
inc/Module/Install/ReadmeMarkdownFromPod.pm | 68 ++++++++
inc/Module/Install/Win32.pm | 2 +-
inc/Module/Install/WriteAll.pm | 2 +-
inc/Pod/Markdown.pm | 236 ++++++++++++++++++++++++++++
inc/Test/More.pm | 74 +++++----
inc/Test/Requires.pm | 74 +++++++++
lib/CGI/Emulate/PSGI.pm | 8 +-
lib/CGI/Parse/PSGI.pm | 10 +-
t/02_parse.t | 3 -
t/05_lint.t | 29 ++++
24 files changed, 585 insertions(+), 86 deletions(-)
diff --git a/Changes b/Changes
index ea1925c..45799bb 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,10 @@
+0.12 Thu Jun 9 23:58:10 PDT 2011
+ - Fixed the PSGI header generation to prevent invalid PSGI response headers
+ such as newlines in the value and "Status" key
+
+0.11 Fri Feb 18 21:35:29 PST 2011
+ - Filter psgix.* environment too (mkanat)
+
0.10 Sun May 16 00:39:55 PDT 2010
- Added a possible workaround to deal with Win32 systems to undo :utf8 PerlIO layer
perl #75106 (suggested by Eric Brine)
diff --git a/MANIFEST b/MANIFEST
index ba2487f..4147b11 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -8,9 +8,12 @@ inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/ReadmeMarkdownFromPod.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
+inc/Pod/Markdown.pm
inc/Test/More.pm
+inc/Test/Requires.pm
lib/CGI/Emulate/PSGI.pm
lib/CGI/Parse/PSGI.pm
Makefile.PL
@@ -23,3 +26,4 @@ t/01_simple.t
t/02_parse.t
t/03_socket.t
t/04_utf8.t
+t/05_lint.t
diff --git a/META.yml b/META.yml
index 81c550e..00d0224 100644
--- a/META.yml
+++ b/META.yml
@@ -7,7 +7,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.97'
+generated_by: 'Module::Install version 1.01'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -22,4 +22,4 @@ requires:
perl: 5.8.0
resources:
license: http://dev.perl.org/licenses/
-version: 0.10
+version: 0.12
diff --git a/Makefile.PL b/Makefile.PL
index 04bc0c5..bddf293 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -12,5 +12,6 @@ author_tests 'xt';
readme_from 'lib/CGI/Emulate/PSGI.pm';
readme_markdown_from 'lib/CGI/Emulate/PSGI.pm';
build_requires 'Test::More' => 0.94;
+test_requires 'Test::Requires';
auto_include;
WriteAll;
diff --git a/README b/README
index 82d77af..9e74ad8 100644
--- a/README
+++ b/README
@@ -6,7 +6,7 @@ SYNOPSIS
# Existing CGI code
});
- DESCRIPTION
+DESCRIPTION
This module allows an application designed for the CGI environment to
run in a PSGI environment, and thus on any of the backends that PSGI
supports.
@@ -85,7 +85,7 @@ AUTHOR
Tatsuhiko Miyagawa
COPYRIGHT AND LICENSE
- Copyright (c) 2009 by tokuhirom.
+ Copyright (c) 2009-2010 by tokuhirom.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
diff --git a/README.mkdn b/README.mkdn
index 758de52..ba5d1a2 100644
--- a/README.mkdn
+++ b/README.mkdn
@@ -5,11 +5,10 @@ CGI::Emulate::PSGI - PSGI adapter for CGI
# SYNOPSIS
my $app = CGI::Emulate::PSGI->handler(sub {
- # Existent CGI code, or just:
- do "script.cgi";
+ # Existing CGI code
});
-## DESCRIPTION
+# DESCRIPTION
This module allows an application designed for the CGI environment to
run in a PSGI environment, and thus on any of the backends that PSGI
@@ -18,23 +17,36 @@ supports.
It works by translating the environment provided by the PSGI
specification to one expected by the CGI specification. Likewise, it
captures output as it would be prepared for the CGI standard, and
-translates it to the format expected for the PSGI standard.
+translates it to the format expected for the PSGI standard using
+[CGI::Parse::PSGI](http://search.cpan.org/perldoc?CGI::Parse::PSGI) module.
# CGI.pm
-If your application uses [CGI](http://search.cpan.org/search?mode=module&query=CGI), be sure to cleanup the global
+If your application uses [CGI](http://search.cpan.org/perldoc?CGI), be sure to cleanup the global
variables in the handler loop yourself, so:
my $app = CGI::Emulate::PSGI->handler(sub {
- do "script-that-uses-cgi-pm.cgi";
- CGI::initialize_globals() if defined &CGI::initialize_globals;
+ use CGI;
+ CGI::initialize_globals();
+ my $q = CGI->new;
+ # ...
});
Otherwise previous request variables will be reused in the new
requests.
-Alternatively, you can install and use [CGI::PSGI](http://search.cpan.org/search?mode=module&query=CGI::PSGI) from CPAN, but
-that would require you to slightly change your code from:
+Alternatively, you can install and use [CGI::Compile](http://search.cpan.org/perldoc?CGI::Compile) from CPAN and
+compiles your existing CGI scripts into a sub that is perfectly ready
+to be converted to PSGI application using this module.
+
+ my $sub = CGI::Compile->compile("/path/to/script.cgi");
+ my $app = CGI::Emulate::PSGI->handler($sub);
+
+This will take care of assigning an unique namespace for each script
+etc. See [CGI::Compile](http://search.cpan.org/perldoc?CGI::Compile) for details.
+
+You can also consider using [CGI::PSGI](http://search.cpan.org/perldoc?CGI::PSGI) but that would require you to
+slightly change your code from:
my $q = CGI->new;
# ...
@@ -51,11 +63,29 @@ into:
return [ $q->psgi_header, [ $output ] ];
};
-See [CGI::PSGI](http://search.cpan.org/search?mode=module&query=CGI::PSGI) for details.
+See [CGI::PSGI](http://search.cpan.org/perldoc?CGI::PSGI) for details.
-# SEE ALSO
+# METHODS
+
+- handler
+
+ my $app = CGI::Emulate::PSGI->handler($code);
+
+Creates a PSGI application code reference out of CGI code reference.
-[PSGI](http://search.cpan.org/search?mode=module&query=PSGI).
+- emulate_environment
+
+ my %env = CGI::Emulate::PSGI->emulate_environment($env);
+
+Creates an environment hash out of PSGI environment hash. If your code
+or framework just needs an environment variable emulation, use this
+method like:
+
+ local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env));
+ # run your application
+
+If you use `handler` method to create a PSGI environment hash, this
+is automatically called in the created application.
# AUTHOR
@@ -65,7 +95,7 @@ Tatsuhiko Miyagawa
# COPYRIGHT AND LICENSE
-Copyright (c) 2009 by tokuhirom.
+Copyright (c) 2009-2010 by tokuhirom.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
@@ -73,3 +103,6 @@ it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
+# SEE ALSO
+
+[PSGI](http://search.cpan.org/perldoc?PSGI) [CGI::Compile](http://search.cpan.org/perldoc?CGI::Compile) [CGI::PSGI](http://search.cpan.org/perldoc?CGI::PSGI) [Plack](http://search.cpan.org/perldoc?Plack) [CGI::Parse::PSGI](http://search.cpan.org/perldoc?CGI::Parse::PSGI)
\ No newline at end of file
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 5871e1e..74caf9c 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -22,7 +22,6 @@ use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
-use FindBin;
use vars qw{$VERSION $MAIN};
BEGIN {
@@ -32,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.97';
+ $VERSION = '1.01';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -231,7 +230,12 @@ sub preload {
sub new {
my ($class, %args) = @_;
- FindBin->again;
+ delete $INC{'FindBin.pm'};
+ {
+ # to suppress the redefine warning
+ local $SIG{__WARN__} = sub {};
+ require FindBin;
+ }
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
@@ -463,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2010 Adam Kennedy.
+# Copyright 2008 - 2011 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 754fb90..d3662c9 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 5757a67..276409a 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 4f77e2e..093cb7a 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 83223a1..90cc979 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 20955cd..4c71003 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -4,10 +4,11 @@ package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -364,9 +365,9 @@ sub fix_up_makefile {
. ($self->postamble || '');
local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
@@ -386,7 +387,8 @@ sub fix_up_makefile {
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
@@ -410,4 +412,4 @@ sub postamble {
__END__
-#line 539
+#line 541
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index bebb73f..3b01e09 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -515,6 +515,7 @@ sub __extract_license {
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
@@ -550,9 +551,9 @@ sub license_from {
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
- \Qhttp://rt.cpan.org/\E[^>]+|
- \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
- \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@@ -616,8 +617,15 @@ sub _perl_version {
return $v;
}
-
-
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
######################################################################
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
index d5d89f4..348531e 100644
--- a/inc/Module/Install/ReadmeFromPod.pm
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -1,36 +1,48 @@
#line 1
package Module::Install::ReadmeFromPod;
+use 5.006;
use strict;
use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.08';
+$VERSION = '0.12';
sub readme_from {
my $self = shift;
- return unless $Module::Install::AUTHOR;
- my $file = shift || return;
+ return unless $self->is_admin;
+
+ my $file = shift || $self->_all_from
+ or die "Can't determine file to make readme_from";
my $clean = shift;
+
+ print "Writing README from $file\n";
+
require Pod::Text;
my $parser = Pod::Text->new();
open README, '> README' or die "$!\n";
$parser->output_fh( *README );
$parser->parse_file( $file );
- return 1 unless $clean;
- $self->postamble(<<"END");
-distclean :: license_clean
-
-license_clean:
-\t\$(RM_F) README
-END
+ if ($clean) {
+ $self->clean_files('README');
+ }
return 1;
}
+sub _all_from {
+ my $self = shift;
+ return unless $self->admin->{extensions};
+ my ($metadata) = grep {
+ ref($_) eq 'Module::Install::Metadata';
+ } @{$self->admin->{extensions}};
+ return unless $metadata;
+ return $metadata->{values}{all_from} || '';
+}
+
'Readme!';
__END__
-#line 89
+#line 112
diff --git a/inc/Module/Install/ReadmeMarkdownFromPod.pm b/inc/Module/Install/ReadmeMarkdownFromPod.pm
new file mode 100644
index 0000000..db10146
--- /dev/null
+++ b/inc/Module/Install/ReadmeMarkdownFromPod.pm
@@ -0,0 +1,68 @@
+#line 1
+package Module::Install::ReadmeMarkdownFromPod;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+use base qw(Module::Install::Base);
+
+sub readme_markdown_from {
+ my ($self, $file, $clean) = @_;
+ return unless $Module::Install::AUTHOR;
+ die "syntax: readme_markdown_from $file, [$clean]\n" unless $file;
+
+ # require, not use because otherwise Makefile.PL will complain if
+ # non-authors don't have Pod::Markdown, which would be bad.
+ require Pod::Markdown;
+ $self->admin->copy_package('Pod::Markdown', $INC{'Pod/Markdown.pm'});
+
+ my $parser = Pod::Markdown->new;
+ $parser->parse_from_file($file);
+ open my $fh, '>', 'README.mkdn' or die "$!\n";
+ print $fh $parser->as_markdown;
+ close $fh or die "$!\n";
+
+ return 1 unless $clean;
+ $self->postamble(<<"END");
+distclean :: license_clean
+
+license_clean:
+\t\$(RM_F) README.mkdn
+END
+ 1;
+}
+
+sub readme_markdown_from_pod {
+ my ($self, $clean) = @_;
+ return unless $Module::Install::AUTHOR;
+ unless ($self->Meta->{values}{all_from}) {
+ die "set 'all_from' or use 'readme_markdown_from'\n";
+ }
+ $self->readme_markdown_from($self->Meta->{values}{all_from}, $clean);
+}
+
+sub readme_from_pod {
+ my ($self, $clean) = @_;
+ return unless $Module::Install::AUTHOR;
+ unless ($self->Meta->{values}{all_from}) {
+ die "set 'all_from' or use 'readme_from'\n";
+ }
+ $self->readme_from($self->Meta->{values}{all_from}, $clean);
+}
+
+sub reference_module {
+ my ($self, $file) = @_;
+ die "syntax: reference_module $file\n" unless $file;
+ $self->all_from($file);
+ $self->readme_from($file);
+ $self->readme_markdown_from($file);
+}
+
+1;
+
+__END__
+
+#line 188
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index bbfda8d..3139a63 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index e6afa42..1f724a7 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.97';;
+ $VERSION = '1.01';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Pod/Markdown.pm b/inc/Pod/Markdown.pm
new file mode 100644
index 0000000..d77c354
--- /dev/null
+++ b/inc/Pod/Markdown.pm
@@ -0,0 +1,236 @@
+#line 1
+use 5.008;
+use strict;
+use warnings;
+
+package Pod::Markdown;
+BEGIN {
+ $Pod::Markdown::VERSION = '1.110730';
+}
+# ABSTRACT: Convert POD to Markdown
+use parent qw(Pod::Parser);
+
+sub initialize {
+ my $self = shift;
+ $self->SUPER::initialize(@_);
+ $self->_private;
+ $self;
+}
+
+sub _private {
+ my $self = shift;
+ $self->{_MyParser} ||= {
+ Text => [], # final text
+ Indent => 0, # list indent levels counter
+ ListType => '-', # character on every item
+ searching => '' , # what are we searching for? (title, author etc.)
+ Title => undef, # page title
+ Author => undef, # page author
+ };
+}
+
+sub as_markdown {
+ my ($parser, %args) = @_;
+ my $data = $parser->_private;
+ my $lines = $data->{Text};
+ my @header;
+ if ($args{with_meta}) {
+ @header = $parser->_build_markdown_head;
+ }
+ join("\n" x 2, @header, @{$lines});
+}
+
+sub _build_markdown_head {
+ my $parser = shift;
+ my $data = $parser->_private;
+ my $paragraph = '';
+ if (defined $data->{Title}) {
+ $paragraph .= sprintf '[[meta title="%s"]]', $data->{Title};
+ }
+ if (defined $data->{Author}) {
+ $paragraph .= "\n" . sprintf '[[meta author="%s"]]', $data->{Author};
+ }
+ return $paragraph;
+}
+
+sub _save {
+ my ($parser, $text) = @_;
+ my $data = $parser->_private;
+ $text = $parser->_indent_text($text);
+ push @{ $data->{Text} }, $text;
+ return;
+}
+
+sub _unsave {
+ my $parser = shift;
+ my $data = $parser->_private;
+ return pop @{ $data->{Text} };
+}
+
+sub _indent_text {
+ my ($parser, $text) = @_;
+ my $data = $parser->_private;
+ my $level = $data->{Indent};
+ my $indent = undef;
+ if ($level > 0) {
+ $level--;
+ }
+ $indent = ' ' x ($level * 4);
+ my @lines = map { $indent . $_; } split(/\n/, $text);
+ return wantarray ? @lines : join("\n", @lines);
+}
+
+sub _clean_text {
+ my $text = $_[1];
+ my @trimmed = grep { $_; } split(/\n/, $text);
+ return wantarray ? @trimmed : join("\n", @trimmed);
+}
+
+sub command {
+ my ($parser, $command, $paragraph, $line_num) = @_;
+ my $data = $parser->_private;
+
+ # cleaning the text
+ $paragraph = $parser->_clean_text($paragraph);
+
+ # is it a header ?
+ if ($command =~ m{head(\d)}xms) {
+ my $level = $1;
+
+ $paragraph = $parser->interpolate($paragraph, $line_num);
+
+ # the headers never are indented
+ $parser->_save($parser->format_header($level, $paragraph));
+ if ($level == 1) {
+ if ($paragraph =~ m{NAME}xmsi) {
+ $data->{searching} = 'title';
+ } elsif ($paragraph =~ m{AUTHOR}xmsi) {
+ $data->{searching} = 'author';
+ } else {
+ $data->{searching} = '';
+ }
+ }
+ }
+
+ # opening a list ?
+ elsif ($command =~ m{over}xms) {
+
+ # update indent level
+ $data->{Indent}++;
+
+ # closing a list ?
+ } elsif ($command =~ m{back}xms) {
+
+ # decrement indent level
+ $data->{Indent}--;
+ $data->{searching} = '';
+ } elsif ($command =~ m{item}xms) {
+ $paragraph = $parser->interpolate($paragraph, $line_num);
+ $paragraph =~ s{^\h* \* \h*}{}xms;
+
+ if ($data->{searching} eq 'listpara') {
+ $data->{searching} = 'listheadhuddled';
+ }
+ else {
+ $data->{searching} = 'listhead';
+ }
+
+ if (length $paragraph) {
+ $parser->textblock($paragraph, $line_num);
+ }
+ }
+
+ # ignore other commands
+ return;
+}
+
+sub verbatim {
+ my ($parser, $paragraph) = @_;
+ $parser->_save($paragraph);
+}
+
+sub textblock {
+ my ($parser, $paragraph, $line_num) = @_;
+ my $data = $parser->_private;
+
+ # interpolate the paragraph for embebed sequences
+ $paragraph = $parser->interpolate($paragraph, $line_num);
+
+ # clean the empty lines
+ $paragraph = $parser->_clean_text($paragraph);
+
+ # searching ?
+ if ($data->{searching} =~ m{title|author}xms) {
+ $data->{ ucfirst $data->{searching} } = $paragraph;
+ $data->{searching} = '';
+ } elsif ($data->{searching} =~ m{listhead(huddled)?$}xms) {
+ my $is_huddled = $1;
+ $paragraph = sprintf '%s %s', $data->{ListType}, $paragraph;
+ if ($is_huddled) {
+ $paragraph = $parser->_unsave() . "\n" . $paragraph;
+ }
+ $data->{searching} = 'listpara';
+ } elsif ($data->{searching} eq 'listpara') {
+ $data->{searching} = '';
+ }
+
+ # save the text
+ $parser->_save($paragraph);
+}
+
+sub interior_sequence {
+ my ($seq_command, $seq_argument, $pod_seq) = @_[1..3];
+ my %interiors = (
+ 'I' => sub { return '_' . $_[1] . '_' }, # italic
+ 'B' => sub { return '__' . $_[1] . '__' }, # bold
+ 'C' => sub { return '`' . $_[1] . '`' }, # monospace
+ 'F' => sub { return '`' . $_[1] . '`' }, # system path
+ 'S' => sub { return '`' . $_[1] . '`' }, # code
+ 'E' => sub {
+ my $charname = $_[1];
+ return '<' if $charname eq 'lt';
+ return '>' if $charname eq 'gt';
+ return '|' if $charname eq 'verbar';
+ return '/' if $charname eq 'sol';
+ return "&$charname;";
+ },
+ 'L' => \&_resolv_link,
+ );
+ if (exists $interiors{$seq_command}) {
+ my $code = $interiors{$seq_command};
+ return $code->($seq_command, $seq_argument, $pod_seq);
+ } else {
+ return sprintf '%s<%s>', $seq_command, $seq_argument;
+ }
+}
+
+sub _resolv_link {
+ my ($cmd, $arg) = @_;
+ my $text = $arg =~ s"^(.+?)\|"" ? $1 : '';
+
+ if ($arg =~ m{^http|ftp}xms) { # direct link to a URL
+ $text ||= $arg;
+ return sprintf '[%s](%s)', $text, $arg;
+ } elsif ($arg =~ m{^/(.*)$}) {
+ $text ||= $1;
+ $text = $1;
+ return "[$text](\#pod_$1)";
+ } elsif ($arg =~ m{^(\w+(?:::\w+)*)$}) {
+ $text ||= $1;
+ return "[$text](http://search.cpan.org/perldoc?$1)";
+ } else {
+ return sprintf '%s<%s>', $cmd, $arg;
+ }
+}
+
+sub format_header {
+ my ($level, $paragraph) = @_[1,2];
+ sprintf '%s %s', '#' x $level, $paragraph;
+}
+
+1;
+
+
+__END__
+#line 341
+
diff --git a/inc/Test/More.pm b/inc/Test/More.pm
index 9d41458..a7461e7 100644
--- a/inc/Test/More.pm
+++ b/inc/Test/More.pm
@@ -18,7 +18,7 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.94';
+our $VERSION = '0.98';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
@@ -88,7 +88,7 @@ sub ok ($;$) {
return $tb->ok( $test, $name );
}
-#line 367
+#line 372
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +104,7 @@ sub isnt ($$;$) {
*isn't = \&isnt;
-#line 411
+#line 416
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -112,7 +112,7 @@ sub like ($$;$) {
return $tb->like(@_);
}
-#line 426
+#line 431
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -120,7 +120,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 471
+#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -128,7 +128,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 506
+#line 511
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -162,7 +162,7 @@ sub can_ok ($@) {
return $ok;
}
-#line 572
+#line 577
sub isa_ok ($$;$) {
my( $object, $class, $obj_name ) = @_;
@@ -222,7 +222,7 @@ WHOA
return $ok;
}
-#line 651
+#line 656
sub new_ok {
my $tb = Test::More->builder;
@@ -247,16 +247,16 @@ sub new_ok {
return $obj;
}
-#line 719
+#line 741
-sub subtest($&) {
+sub subtest {
my ($name, $subtests) = @_;
my $tb = Test::More->builder;
return $tb->subtest(@_);
}
-#line 743
+#line 765
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +270,7 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 806
+#line 833
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -332,7 +332,7 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 875
+#line 902
sub require_ok ($) {
my($module) = shift;
@@ -340,7 +340,7 @@ sub require_ok ($) {
my $pack = caller;
- # Try to deterine if we've been given a module name or file.
+ # Try to determine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
@@ -376,7 +376,7 @@ sub _is_module_name {
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
-#line 952
+#line 979
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -476,14 +476,14 @@ sub _type {
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1112
+#line 1139
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +493,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1138
+#line 1165
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1204
+#line 1231
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +527,7 @@ sub skip {
last SKIP;
}
-#line 1288
+#line 1315
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +548,7 @@ sub todo_skip {
last TODO;
}
-#line 1343
+#line 1370
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +557,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1382
+#line 1409
#'#
sub eq_array {
@@ -581,6 +581,8 @@ sub _eq_array {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -591,6 +593,21 @@ sub _eq_array {
return $ok;
}
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
+}
+
sub _deep_check {
my( $e1, $e2 ) = @_;
my $tb = Test::More->builder;
@@ -603,9 +620,6 @@ sub _deep_check {
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -616,7 +630,7 @@ sub _deep_check {
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -683,7 +697,7 @@ WHOA
}
}
-#line 1515
+#line 1556
sub eq_hash {
local @Data_Stack = ();
@@ -706,6 +720,8 @@ sub _eq_hash {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -716,7 +732,7 @@ sub _eq_hash {
return $ok;
}
-#line 1572
+#line 1615
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -741,6 +757,6 @@ sub eq_set {
);
}
-#line 1774
+#line 1817
1;
diff --git a/inc/Test/Requires.pm b/inc/Test/Requires.pm
new file mode 100644
index 0000000..d239935
--- /dev/null
+++ b/inc/Test/Requires.pm
@@ -0,0 +1,74 @@
+#line 1
+package Test::Requires;
+use strict;
+use warnings;
+our $VERSION = '0.06';
+use base 'Test::Builder::Module';
+use 5.006000;
+
+sub import {
+ my $class = shift;
+ my $caller = caller(0);
+
+ # export methods
+ {
+ no strict 'refs';
+ *{"$caller\::test_requires"} = \&test_requires;
+ }
+
+ # test arguments
+ if (@_ == 1 && ref $_[0] && ref $_[0] eq 'HASH') {
+ while (my ($mod, $ver) = each %{$_[0]}) {
+ test_requires($mod, $ver, $caller);
+ }
+ } else {
+ for my $mod (@_) {
+ test_requires($mod, undef, $caller);
+ }
+ }
+}
+
+sub test_requires {
+ my ( $mod, $ver, $caller ) = @_;
+ return if $mod eq __PACKAGE__;
+ if (@_ != 3) {
+ $caller = caller(0);
+ }
+ $ver ||= '';
+
+ eval qq{package $caller; use $mod $ver}; ## no critic.
+ if (my $e = $@) {
+ my $skip_all = sub {
+ my $builder = __PACKAGE__->builder;
+
+ if (not defined $builder->has_plan) {
+ $builder->skip_all(@_);
+ } elsif ($builder->has_plan eq 'no_plan') {
+ $builder->skip(@_);
+ if ( $builder->can('parent') && $builder->parent ) {
+ die bless {} => 'Test::Builder::Exception';
+ }
+ exit 0;
+ } else {
+ for (1..$builder->has_plan) {
+ $builder->skip(@_);
+ }
+ if ( $builder->can('parent') && $builder->parent ) {
+ die bless {} => 'Test::Builder::Exception';
+ }
+ exit 0;
+ }
+ };
+ if ( $e =~ /^Can't locate/ ) {
+ $skip_all->("Test requires module '$mod' but it's not found");
+ }
+ else {
+ $skip_all->("$e");
+ }
+ }
+}
+
+1;
+__END__
+
+#line 128
diff --git a/lib/CGI/Emulate/PSGI.pm b/lib/CGI/Emulate/PSGI.pm
index 37d824b..42a1109 100644
--- a/lib/CGI/Emulate/PSGI.pm
+++ b/lib/CGI/Emulate/PSGI.pm
@@ -7,7 +7,7 @@ use IO::File ();
use SelectSaver;
use 5.00800;
-our $VERSION = '0.10';
+our $VERSION = '0.12';
sub handler {
my ($class, $code, ) = @_;
@@ -47,7 +47,7 @@ sub emulate_environment {
REMOTE_HOST => 'localhost',
REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
# REQUEST_URI => $uri->path_query, # not in RFC 3875
- ( map { $_ => $env->{$_} } grep !/^psgi\./, keys %$env )
+ ( map { $_ => $env->{$_} } grep !/^psgix?\./, keys %$env )
};
return wantarray ? %$environment : $environment;
@@ -66,7 +66,7 @@ CGI::Emulate::PSGI - PSGI adapter for CGI
# Existing CGI code
});
-=head2 DESCRIPTION
+=head1 DESCRIPTION
This module allows an application designed for the CGI environment to
run in a PSGI environment, and thus on any of the backends that PSGI
@@ -157,7 +157,7 @@ Tatsuhiko Miyagawa
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2009 by tokuhirom.
+Copyright (c) 2009-2010 by tokuhirom.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
diff --git a/lib/CGI/Parse/PSGI.pm b/lib/CGI/Parse/PSGI.pm
index 87f9709..69bd489 100644
--- a/lib/CGI/Parse/PSGI.pm
+++ b/lib/CGI/Parse/PSGI.pm
@@ -39,6 +39,8 @@ sub parse_cgi_output {
my $status = $response->header('Status') || 200;
$status =~ s/\s+.*$//; # remove ' OK' in '200 OK'
+ $response->remove_header('Status'); # PSGI doesn't allow having Status header in the response
+
my $remaining = $length - tell( $output );
if ( $response->code == 500 && !$remaining ) {
return [
@@ -67,13 +69,19 @@ sub parse_cgi_output {
+[
map {
my $k = $_;
- map { ( $k => $_ ) } $response->headers->header($_);
+ map { ( $k => _cleanup_newline($_) ) } $response->headers->header($_);
} $response->headers->header_field_names
],
[$response->content],
];
}
+sub _cleanup_newline {
+ local $_ = shift;
+ s/\r?\n//g;
+ return $_;
+}
+
1;
__END__
diff --git a/t/02_parse.t b/t/02_parse.t
index 39f0651..b4d8c4c 100644
--- a/t/02_parse.t
+++ b/t/02_parse.t
@@ -7,8 +7,6 @@ Status: 302
Content-Type: text/html
X-Foo: bar
Location: http://localhost/
-Multiline: Foo
- bar baz
This is the body!
CGI
@@ -24,7 +22,6 @@ while (my($k, $v) = splice @{$r->[1]}, 0, 2) {
is $h->content_length, 18;
is $h->content_type, 'text/html';
is $h->header('Location'), 'http://localhost/';
-is $h->header("Multiline"), "Foo\n bar baz";
is_deeply $r->[2], [ "This is the body!\n" ];
diff --git a/t/05_lint.t b/t/05_lint.t
new file mode 100644
index 0000000..9624dd0
--- /dev/null
+++ b/t/05_lint.t
@@ -0,0 +1,29 @@
+use strict;
+use Test::More;
+use Test::Requires qw( Plack::Test HTTP::Request Plack::Middleware::Lint );
+use Test::Requires {
+ 'Plack' => 0.9981,
+};
+use CGI::Emulate::PSGI;
+
+my $output = <<CGI;
+Status: 302
+Content-Type: text/html
+X-Foo: bar
+Location: http://localhost/
+Multiline: Foo
+ bar baz
+
+This is the body!
+CGI
+
+my $app = CGI::Emulate::PSGI->handler(sub { print $output });
+$app = Plack::Middleware::Lint->wrap($app);
+
+Plack::Test::test_psgi($app, sub {
+ my $cb = shift;
+ my $res = $cb->(HTTP::Request->new(GET => "/"));
+ is $res->code, 302;
+});
+
+done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcgi-emulate-psgi-perl.git
More information about the Pkg-perl-cvs-commits
mailing list