[Rt-commit] r3260 - in HTTP-Server-Simple-Recorder: . lib lib/HTTP
lib/HTTP/Server lib/HTTP/Server/Simple t t/logs
glasser at bestpractical.com
glasser at bestpractical.com
Tue Jun 28 15:05:42 EDT 2005
Author: glasser
Date: Tue Jun 28 15:05:42 2005
New Revision: 3260
Added:
HTTP-Server-Simple-Recorder/Changes
HTTP-Server-Simple-Recorder/MANIFEST
HTTP-Server-Simple-Recorder/Makefile.PL
HTTP-Server-Simple-Recorder/README
HTTP-Server-Simple-Recorder/lib/
HTTP-Server-Simple-Recorder/lib/HTTP/
HTTP-Server-Simple-Recorder/lib/HTTP/Server/
HTTP-Server-Simple-Recorder/lib/HTTP/Server/Simple/
HTTP-Server-Simple-Recorder/lib/HTTP/Server/Simple/Recorder.pm
HTTP-Server-Simple-Recorder/t/
HTTP-Server-Simple-Recorder/t/00.load.t
HTTP-Server-Simple-Recorder/t/01.live.t
HTTP-Server-Simple-Recorder/t/logs/
HTTP-Server-Simple-Recorder/t/logs/.makeme
HTTP-Server-Simple-Recorder/t/pod.t
Log:
HTTP::Server::Simple::Recorder 0.01
Added: HTTP-Server-Simple-Recorder/Changes
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/Changes Tue Jun 28 15:05:42 2005
@@ -0,0 +1,5 @@
+Revision history for HTTP-Server-Simple-Recorder
+
+0.0.1 Tue Jun 28 01:28:38 2005
+ Initial release.
+
Added: HTTP-Server-Simple-Recorder/MANIFEST
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/MANIFEST Tue Jun 28 15:05:42 2005
@@ -0,0 +1,18 @@
+Changes
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/HTTP/Server/Simple/Recorder.pm
+Makefile.PL
+MANIFEST
+META.yml # Will be created by "make dist"
+README
+t/00.load.t
+t/01.live.t
+t/pod.t
+t/logs/.makeme
Added: HTTP-Server-Simple-Recorder/Makefile.PL
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/Makefile.PL Tue Jun 28 15:05:42 2005
@@ -0,0 +1,13 @@
+use inc::Module::Install;
+
+name ('HTTP-Server-Simple-Recorder');
+author ('David Glasser <glasser at bestpractical.com>');
+version_from ('lib/HTTP/Server/Simple/Recorder.pm');
+abstract_from('lib/HTTP/Server/Simple/Recorder.pm');
+license('perl');
+requires('Test::More');
+requires('Test::HTTP::Server::Simple');
+requires('IO::Tee');
+requires('HTTP::Server::Simple' => '0.10');
+
+&WriteAll;
Added: HTTP-Server-Simple-Recorder/README
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/README Tue Jun 28 15:05:42 2005
@@ -0,0 +1,38 @@
+HTTP-Server-Simple-Recorder version 0.0.1
+
+This module allows you to record all HTTP communication between an
+L<HTTP::Server::Simple>-derived server and its clients. It is a mixin, so
+it doesn't itself subclass L<HTTP::Server::Simple>; you need to subclass from
+both L<HTTP::Server::Simple::Recorder> and an actual L<HTTP::Server::Simple> subclass,
+and L<HTTP::Server::Simple::Recorder> should be listed first.
+
+Every time a client connects to your server, this module will open a pair of files and log
+the communication between the file and server to these files. Each connection gets a serial
+number starting at 1. The filename used is C<<$self->recorder_prefix>>, then a period,
+then the connection serial number, then a period, then either "in" or "out".
+C<recorder_prefix> defaults to C</tmp/http-server-simple-recorder>, but you can override that
+in your subclass. For example, you might want to include the process ID.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+
+DEPENDENCIES
+
+IO::Tee, HTTP::Server::Simple 0.10.
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2005, Best Practical Solutions LLC.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
Added: HTTP-Server-Simple-Recorder/lib/HTTP/Server/Simple/Recorder.pm
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/lib/HTTP/Server/Simple/Recorder.pm Tue Jun 28 15:05:42 2005
@@ -0,0 +1,156 @@
+package HTTP::Server::Simple::Recorder;
+
+our $VERSION = '0.01';
+
+use warnings;
+use strict;
+use Carp;
+
+use IO::File;
+
+sub stdio_handle {
+ my $self = shift;
+ if (@_) {
+ my $handle = $_[0];
+ $self->{'_recorder_stdio_handle'} = $handle;
+
+ my $serial = ++ $self->{'_recorder_serial'};
+ my $prefix = $self->recorder_prefix;
+
+ my $infile = "$prefix.$serial.in";
+ my $outfile = "$prefix.$serial.out";
+
+ my $in = IO::File->new("$infile", ">") or die "Couldn't open $infile: $!";
+ $in->autoflush(1);
+ my $out = IO::File->new("$outfile", ">") or die "Couldn't open $outfile: $!";
+ $out->autoflush(1);
+
+ $self->{'_recorder_stdin_handle'} = IO::Tee::Binmode->new($handle, $in);
+ $self->{'_recorder_stdout_handle'} = IO::Tee::Binmode->new($handle, $out);
+ }
+ return $self->{'_recorder_stdio_handle'};
+}
+
+sub stdin_handle {
+ my $self = shift;
+ return $self->{'_recorder_stdin_handle'};
+}
+
+sub stdout_handle {
+ my $self = shift;
+ return $self->{'_recorder_stdout_handle'};
+}
+
+sub recorder_prefix { "/tmp/http-server-simple-recorder"; }
+
+package IO::Tee::Binmode;
+
+use base qw/IO::Tee/;
+
+sub BINMODE {
+ my $self = shift;
+ my $ret = 1;
+ if (@_) {
+ for my $fh (@$self) { undef $ret unless binmode $fh, $_[0] }
+ } else {
+ for my $fh (@$self) { undef $ret unless binmode $fh }
+ }
+ return $ret;
+}
+
+sub READ {
+ my $self = shift;
+ my $bytes = $self->[0]->read(@_);
+ # add the || 0 to silence warnings
+ $bytes and $self->_multiplex_input(substr($_[0], $_[2] || 0, $bytes));
+ $bytes;
+}
+
+
+1; # Magic true value required at end of module
+__END__
+
+=head1 NAME
+
+HTTP::Server::Simple::Recorder - Mixin to record HTTP::Server::Simple's sockets
+
+=head1 SYNOPSIS
+
+ package MyServer;
+ use base qw/HTTP::Server::Simple::Recorder HTTP::Server::Simple::CGI/;
+
+ sub recorder_prefix { "path/to/logs/record" } # defaults to /tmp/http-server-simple-recorder
+
+ # logs to path/to/logs/record.34244.1.in,
+ # path/to/logs/record.34244.1.out,
+ # path/to/logs/record.34244.2.in,
+ # path/to/logs/record.34244.2.out, etc, if 34244 is the PID of the server
+
+=head1 DESCRIPTION
+
+This module allows you to record all HTTP communication between an
+L<HTTP::Server::Simple>-derived server and its clients. It is a mixin, so
+it doesn't itself subclass L<HTTP::Server::Simple>; you need to subclass from
+both L<HTTP::Server::Simple::Recorder> and an actual L<HTTP::Server::Simple> subclass,
+and L<HTTP::Server::Simple::Recorder> should be listed first.
+
+Every time a client connects to your server, this module will open a pair of files and log
+the communication between the file and server to these files. Each connection gets a serial
+number starting at 1. The filename used is C<<$self->recorder_prefix>>, then a period,
+then the connection serial number, then a period, then either "in" or "out".
+C<recorder_prefix> defaults to C</tmp/http-server-simple-recorder>, but you can override that
+in your subclass. For example, you might want to include the process ID.
+
+
+=head1 DEPENDENCIES
+
+L<IO::Tee>, L<HTTP::Server::Simple>.
+
+
+=head1 BUGS AND LIMITATIONS
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-http-server-simple-recorder at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+=head1 SEE ALSO
+
+L<HTTP::Server::Simple>, L<HTTP::Recorder>.
+
+=head1 AUTHOR
+
+David Glasser C<< <glasser at bestpractical.com> >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2005, Best Practical Solutions, LLC. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
Added: HTTP-Server-Simple-Recorder/t/00.load.t
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/t/00.load.t Tue Jun 28 15:05:42 2005
@@ -0,0 +1,7 @@
+use Test::More tests => 1;
+
+BEGIN {
+use_ok( 'HTTP::Server::Simple::Recorder' );
+}
+
+diag( "Testing HTTP::Server::Simple::Recorder $HTTP::Server::Simple::Recorder::VERSION" );
Added: HTTP-Server-Simple-Recorder/t/01.live.t
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/t/01.live.t Tue Jun 28 15:05:42 2005
@@ -0,0 +1,150 @@
+use warnings;
+use strict;
+use Test::More tests => 20;
+
+BEGIN { use_ok 'Test::HTTP::Server::Simple' }
+BEGIN { use_ok 'HTTP::Server::Simple::CGI' }
+BEGIN { use_ok 'Socket' }
+
+# This script assumes that `localhost' will resolve to a local IP
+# address that may be bound to,
+
+use constant PORT => 13432;
+
+unlink map "t/logs/rec.$_", qw/1.in 1.out 2.in 2.out/;
+
+{
+ my $s=MyServer->new(PORT);
+ is($s->port(),PORT,"Constructor set port correctly");
+
+ # XXX TODO FIXME should use File::Spec or whatever
+ is($s->recorder_prefix, "t/logs/rec");
+
+ my $url = started_ok($s);
+
+ select(undef,undef,undef,0.2); # wait a sec
+
+ my $content=fetch("GET / HTTP/1.1", "");
+
+ like($content, qr/Congratulations/, "Returns a page");
+
+ $content=fetch("GET /monkey HTTP/1.1", "");
+
+ like($content, qr/Congratulations/, "Returns a page");
+}
+
+{
+ my $f = "t/logs/rec.1.in";
+ ok((open my $fh, "<$f"), "found a log file") or diag("error opening $f: $!");
+
+ my $text = do { local $/; <$fh> };
+
+ is($text, "GET / HTTP/1.1\015\012\015\012");
+}
+
+{
+ my $f = "t/logs/rec.2.in";
+ ok((open my $fh, "<$f"), "found a log file") or diag("error opening $f: $!");
+
+ my $text = do { local $/; <$fh> };
+
+ is($text, "GET /monkey HTTP/1.1\015\012\015\012");
+}
+
+{
+ my $f = "t/logs/rec.1.out";
+ ok((open my $fh, "<$f"), "found a log file") or diag("error opening $f: $!");
+
+ my $text = do { local $/; <$fh> };
+
+ like($text, qr!^HTTP/1.0 200 OK!);
+ like($text, qr!^Content-Type: text/html!m);
+ like($text, qr!Congratulations!);
+}
+
+{
+ my $f = "t/logs/rec.2.out";
+ ok((open my $fh, "<$f"), "found a log file") or diag("error opening $f: $!");
+
+ my $text = do { local $/; <$fh> };
+
+ like($text, qr!^HTTP/1.0 200 OK!);
+ like($text, qr!^Content-Type: text/html!m);
+ like($text, qr!Congratulations!);
+}
+
+# this function may look excessive, but hopefully will be very useful
+# in identifying common problems
+sub fetch {
+
+ my @response;
+ my $alarm = 0;
+ my $stage = "init";
+
+ my %messages =
+ ( "init" => "inner contemplation",
+ "lookup" => ("lookup of `localhost' - may be caused by a "
+ ."missing hosts entry or broken resolver"),
+ "sockaddr" => "call to sockaddr_in() - ?",
+ "proto" => ("call to getprotobyname() - may be caused by "
+ ."bizarre NSS configurations"),
+ "socket" => "socket creation",
+ "connect" => ("connect() - may be caused by a missing or "
+ ."broken loopback interface, or firewalling"),
+ "send" => "network send()",
+ "recv" => "collection of response",
+ "close" => "closing socket"
+ );
+
+ $SIG{ALRM} = sub {
+ @response = "timed out during $messages{$stage}";
+ $alarm = 1;
+ };
+
+ my ($iaddr, $paddr, $proto, $message);
+
+ $message = join "", map { "$_\015\012" } @_;
+
+ my %states =
+ ( 'init' => sub { "lookup"; },
+ "lookup" => sub { ($iaddr = inet_aton("localhost"))
+ && "sockaddr" },
+ "sockaddr" => sub { ($paddr = sockaddr_in(PORT, $iaddr))
+ && "proto" },
+ "proto" => sub { ($proto = getprotobyname('tcp'))
+ && "socket" },
+ "socket" => sub { socket(SOCK, PF_INET, SOCK_STREAM, $proto)
+ && "connect" },
+ "connect" => sub { connect(SOCK, $paddr) && "send" },
+ "send" => sub { (send SOCK, $message, 0) && "recv" },
+ "recv" => sub {
+ my $line;
+ while (!$alarm and defined($line = <SOCK>)) {
+ push @response, $line;
+ }
+ ($alarm ? undef : "close");
+ },
+ "close" => sub { close SOCK; "done"; },
+ );
+
+ # this entire cycle should finish way before this timer expires
+ alarm(5);
+
+ my $next;
+ $stage = $next
+ while (!$alarm && $stage ne "done"
+ && ($next = $states{$stage}->()));
+
+ warn "early exit from `$stage' stage; $!" unless $next;
+
+ # bank on the test testing for something in the response.
+ return join "", @response;
+
+
+}
+
+package MyServer;
+
+use base qw/HTTP::Server::Simple::Recorder HTTP::Server::Simple::CGI/;
+
+sub recorder_prefix { "t/logs/rec" }
Added: HTTP-Server-Simple-Recorder/t/logs/.makeme
==============================================================================
Added: HTTP-Server-Simple-Recorder/t/pod.t
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple-Recorder/t/pod.t Tue Jun 28 15:05:42 2005
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
More information about the Rt-commit
mailing list