[Bps-public-commit] r13770 - in Test-HTTP-Server-Simple: .

[sartak at bestpractical.com]

Author: sartak
Date: Thu Jul  3 09:05:14 2008
New Revision: 13770

Added:
   Test-HTTP-Server-Simple/lib/Test/HTTP/Server/Simple/
   Test-HTTP-Server-Simple/lib/Test/HTTP/Server/Simple/StashWarnings.pm
Modified:
   Test-HTTP-Server-Simple/   (props changed)
   Test-HTTP-Server-Simple/META.yml
   Test-HTTP-Server-Simple/Makefile.PL

Log:
 r63667 at onn:  sartak | 2008-07-03 09:05:06 -0400
 Add a StashWarnings subclass which stashes warnings and makes them available over a special URL


Modified: Test-HTTP-Server-Simple/META.yml
==============================================================================
--- Test-HTTP-Server-Simple/META.yml	(original)
+++ Test-HTTP-Server-Simple/META.yml	Thu Jul  3 09:05:14 2008
@@ -8,6 +8,7 @@
 requires:     
     HTTP::Server::Simple:          0
     NEXT:                          0
+    Storable:                      0
     Test::Builder:                 0
     Test::Builder::Tester:         1.04
     Test::More:                    0

Modified: Test-HTTP-Server-Simple/Makefile.PL
==============================================================================
--- Test-HTTP-Server-Simple/Makefile.PL	(original)
+++ Test-HTTP-Server-Simple/Makefile.PL	Thu Jul  3 09:05:14 2008
@@ -9,6 +9,7 @@
     ABSTRACT_FROM       => 'lib/Test/HTTP/Server/Simple.pm',
     PL_FILES            => {},
     PREREQ_PM => {
+        'Storable' => 0,
         'Test::More' => 0,
         'Test::Builder' => 0,
         'Test::Builder::Tester' => 1.04,

Added: Test-HTTP-Server-Simple/lib/Test/HTTP/Server/Simple/StashWarnings.pm
==============================================================================
--- (empty file)
+++ Test-HTTP-Server-Simple/lib/Test/HTTP/Server/Simple/StashWarnings.pm	Thu Jul  3 09:05:14 2008
@@ -0,0 +1,72 @@
+#!/usr/bin/env perl
+package Test::HTTP::Server::Simple::StashWarnings;
+use strict;
+use warnings;
+use base 'Test::HTTP::Server::Simple';
+
+use NEXT;
+use Storable ();
+
+sub test_warning_path {
+    my $self = shift;
+    die "You must override test_warning_path in $self to tell " . __PACKAGE__ . " where to provide test warnings.";
+}
+
+sub background {
+    my $self = shift;
+
+    local $SIG{__WARN__} = sub {
+        push @{ $self->{'thss_stashed_warnings'} }, @_;
+    };
+
+    return $self->NEXT::background(@_);
+}
+
+sub handler {
+    my $self = shift;
+
+    if ($self->{thss_test_path_hit}) {
+        my @warnings = splice @{ $self->{'thss_stashed_warnings'} };
+        my $content  = Storable::nfreeze(\@warnings);
+
+        print "HTTP/1.0 200 OK\r\n";
+        print "Content-Type: application/x-perl\r\n";
+        print "Content-Length: ", length($content), "\r\n";
+        print "\r\n";
+        print $content;
+
+        return;
+    }
+
+    return $self->NEXT::handler(@_);
+}
+
+sub setup {
+    my $self = shift;
+    my @copy = @_;
+
+    while (my ($item, $value) = splice @copy, 0, 2) {
+        if ($item eq 'request_uri') {
+            $self->{thss_test_path_hit} = $value eq $self->test_warning_path;
+        }
+    }
+
+    return $self->NEXT::setup(@_);
+}
+
+sub decode_warnings {
+    my $self = shift;
+    my $text = shift;
+
+    return @{ Storable::thaw($text) };
+}
+
+sub DESTROY {
+    my $self = shift;
+    for (@{ $self->{'thss_stashed_warnings'} }) {
+        warn "Unhandled warning: $_";
+    }
+}
+
+1;
+