Add ARM files

[dh-make-perl] / dev / arm / libwww-mechanize-perl / libwww-mechanize-perl-1.34 / t / local / LocalServer.pm

diff --git a/dev/arm/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/LocalServer.pm b/dev/arm/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/LocalServer.pm
new file mode 100644 (file)
index 0000000..b15544e
--- /dev/null
+++ b/dev/arm/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/LocalServer.pm
@@ -0,0 +1,198 @@
+package LocalServer;
+
+# start a fake webserver, fork, and connect to ourselves
+use warnings;
+use strict;
+use Test::More;
+use LWP::Simple;
+use FindBin;
+use File::Spec;
+use File::Temp;
+use URI::URL qw();
+use Carp qw(carp croak);
+
+=head2 C<< Test::HTTP::LocalServer->spawn %ARGS >>
+
+This spawns a new HTTP server. The server will stay running until
+C<< $server->stop >> is called.
+
+Valid arguments are:
+
+=over 4
+
+=item * html
+
+scalar containing the page to be served
+
+=item * file
+
+filename containing the page to be served
+
+=item * debug
+
+Set to true to make the spawned server output debug information
+
+=back
+
+All served HTML will have the first %s replaced by the current location.
+
+=cut
+
+sub spawn {
+  my ($class,%args) = @_;
+  my $self = { %args };
+  bless $self,$class;
+
+  local $ENV{TEST_HTTP_VERBOSE};
+  $ENV{TEST_HTTP_VERBOSE} = 1 if delete $args{debug};
+
+  $self->{delete} = [];
+  if (my $html = delete $args{html}) {
+    # write the html to a temp file
+    my ($fh,$tempfile) = File::Temp::tempfile();
+    binmode $fh;
+    print $fh $html
+      or die "Couldn't write tempfile $tempfile : $!";
+    close $fh;
+    push @{$self->{delete}},$tempfile;
+    $args{file} = $tempfile;
+  };
+  my ($fh,$logfile) = File::Temp::tempfile();
+  close $fh;
+  push @{$self->{delete}},$logfile;
+  $self->{logfile} = $logfile;
+  my $web_page = delete $args{file};
+  if (defined $web_page) {
+    $web_page = qq{"$web_page"}
+  } else {
+    $web_page = "";
+  };
+
+  my $server_file = File::Spec->catfile( $FindBin::Bin,'log-server' );
+
+  open my $server, qq'$^X "$server_file" "$web_page" "$logfile" |'
+    or die "Couldn't spawn fake server $server_file : $!";
+  my $url = <$server>;
+  chomp $url;
+  die "Couldn't find fake server url" unless $url;
+
+  $self->{_fh} = $server;
+
+  my $lhurl = URI::URL->new( $url );
+  $lhurl->host( 'localhost' );
+  $self->{_server_url} = $lhurl;
+
+  diag "Started $lhurl";
+
+  $self;
+};
+
+=head2 C<< $server->port >>
+
+This returns the port of the current server. As new instances
+will most likely run under a different port, this is convenient
+if you need to compare results from two runs.
+
+=cut
+
+sub port {
+  carp __PACKAGE__ . '::port called without a server' unless $_[0]->{_server_url};
+  $_[0]->{_server_url}->port
+};
+
+=head2 C<< $server->url >>
+
+This returns the url where you can contact the server. This url
+is valid until you call
+C<< $server->stop >>
+or
+C<< $server->get_output >>
+
+=cut
+
+sub url {
+  my $url = $_[0]->{_server_url}->abs;
+
+  return $url->as_string;
+};
+
+=head2 C<< $server->creds_required >>
+
+This returns a URL for a page that requires HTTP Basic-Auth.  The
+content returned is invariant and irrelevant; this method is for
+testing credential-passing code.  The username is 'luser' and the
+password is 'fnord'.  When these credentials are passed, the returned
+status will be 200, otherwise it will be 401.
+
+=cut
+
+sub creds_required {
+  return $_[0]->{_server_url} . 'creds_required';
+}
+
+=head2 C<< $server->stop >>
+
+This stops the server process by requesting a special
+url.
+
+=cut
+
+sub stop {
+  get( $_[0]->{_server_url} . 'quit_server' );
+  undef $_[0]->{_server_url}
+};
+
+=head2 C<< $server->get_output >>
+
+This stops the server by calling C<stop> and then returns the
+output of the server process. This output will be a list of
+all requests made to the server concatenated together
+as a string.
+
+=cut
+
+sub get_output {
+  my ($self) = @_;
+  $self->stop;
+  local $/;
+  local *LOG;
+  open LOG, '<', $self->{logfile}
+    or die "Couldn't retrieve logfile";
+  return join "", <LOG>;
+}
+
+sub DESTROY {
+    my $self = shift;
+    $self->stop if $self->{_server_url};
+    if ( $self->{_fh} ) {
+        close $self->{_fh};
+        delete $self->{_fh};
+    }
+    for my $file ( @{$self->{delete}} ) {
+        unlink $file or warn "Couldn't remove tempfile $file : $!\n";
+    }
+}
+
+=head1 EXPORT
+
+None by default.
+
+=head1 COPYRIGHT AND LICENSE
+
+This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+Copyright (C) 2003 Max Maischein
+
+=head1 AUTHOR
+
+Max Maischein, E<lt>corion@cpan.orgE<gt>
+
+Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome !
+
+=head1 SEE ALSO
+
+L<WWW::Mechanize>,L<WWW::Mechanize::Shell>
+
+=cut
+
+1;