git.maemo.org Git - pkg-perl/blob - deb-src/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/LocalServer.pm

   1 package LocalServer;
   2
   3 # start a fake webserver, fork, and connect to ourselves
   4 use warnings;
   5 use strict;
   6 use Test::More;
   7 use LWP::Simple;
   8 use FindBin;
   9 use File::Spec;
  10 use File::Temp;
  11 use URI::URL qw();
  12 use Carp qw(carp croak);
  13
  14 =head2 C<< Test::HTTP::LocalServer->spawn %ARGS >>
  15
  16 This spawns a new HTTP server. The server will stay running until
  17 C<< $server->stop >> is called.
  18
  19 Valid arguments are:
  20
  21 =over 4
  22
  23 =item * html
  24
  25 scalar containing the page to be served
  26
  27 =item * file
  28
  29 filename containing the page to be served
  30
  31 =item * debug
  32
  33 Set to true to make the spawned server output debug information
  34
  35 =back
  36
  37 All served HTML will have the first %s replaced by the current location.
  38
  39 =cut
  40
  41 sub spawn {
  42   my ($class,%args) = @_;
  43   my $self = { %args };
  44   bless $self,$class;
  45
  46   local $ENV{TEST_HTTP_VERBOSE};
  47   $ENV{TEST_HTTP_VERBOSE} = 1 if delete $args{debug};
  48
  49   $self->{delete} = [];
  50   if (my $html = delete $args{html}) {
  51     # write the html to a temp file
  52     my ($fh,$tempfile) = File::Temp::tempfile();
  53     binmode $fh;
  54     print $fh $html
  55       or die "Couldn't write tempfile $tempfile : $!";
  56     close $fh;
  57     push @{$self->{delete}},$tempfile;
  58     $args{file} = $tempfile;
  59   };
  60   my ($fh,$logfile) = File::Temp::tempfile();
  61   close $fh;
  62   push @{$self->{delete}},$logfile;
  63   $self->{logfile} = $logfile;
  64   my $web_page = delete $args{file};
  65   if (defined $web_page) {
  66     $web_page = qq{"$web_page"}
  67   } else {
  68     $web_page = "";
  69   };
  70
  71   my $server_file = File::Spec->catfile( $FindBin::Bin,'log-server' );
  72
  73   open my $server, qq'$^X "$server_file" "$web_page" "$logfile" |'
  74     or die "Couldn't spawn fake server $server_file : $!";
  75   my $url = <$server>;
  76   chomp $url;
  77   die "Couldn't find fake server url" unless $url;
  78
  79   $self->{_fh} = $server;
  80
  81   my $lhurl = URI::URL->new( $url );
  82   $lhurl->host( 'localhost' );
  83   $self->{_server_url} = $lhurl;
  84
  85   diag "Started $lhurl";
  86
  87   $self;
  88 };
  89
  90 =head2 C<< $server->port >>
  91
  92 This returns the port of the current server. As new instances
  93 will most likely run under a different port, this is convenient
  94 if you need to compare results from two runs.
  95
  96 =cut
  97
  98 sub port {
  99   carp __PACKAGE__ . '::port called without a server' unless $_[0]->{_server_url};
 100   $_[0]->{_server_url}->port
 101 };
 102
 103 =head2 C<< $server->url >>
 104
 105 This returns the url where you can contact the server. This url
 106 is valid until you call
 107 C<< $server->stop >>
 108 or
 109 C<< $server->get_output >>
 110
 111 =cut
 112
 113 sub url {
 114   my $url = $_[0]->{_server_url}->abs;
 115
 116   return $url->as_string;
 117 };
 118
 119 =head2 C<< $server->creds_required >>
 120
 121 This returns a URL for a page that requires HTTP Basic-Auth.  The
 122 content returned is invariant and irrelevant; this method is for
 123 testing credential-passing code.  The username is 'luser' and the
 124 password is 'fnord'.  When these credentials are passed, the returned
 125 status will be 200, otherwise it will be 401.
 126
 127 =cut
 128
 129 sub creds_required {
 130   return $_[0]->{_server_url} . 'creds_required';
 131 }
 132
 133 =head2 C<< $server->stop >>
 134
 135 This stops the server process by requesting a special
 136 url.
 137
 138 =cut
 139
 140 sub stop {
 141   get( $_[0]->{_server_url} . 'quit_server' );
 142   undef $_[0]->{_server_url}
 143 };
 144
 145 =head2 C<< $server->get_output >>
 146
 147 This stops the server by calling C<stop> and then returns the
 148 output of the server process. This output will be a list of
 149 all requests made to the server concatenated together
 150 as a string.
 151
 152 =cut
 153
 154 sub get_output {
 155   my ($self) = @_;
 156   $self->stop;
 157   local $/;
 158   local *LOG;
 159   open LOG, '<', $self->{logfile}
 160     or die "Couldn't retrieve logfile";
 161   return join "", <LOG>;
 162 }
 163
 164 sub DESTROY {
 165     my $self = shift;
 166     $self->stop if $self->{_server_url};
 167     if ( $self->{_fh} ) {
 168         close $self->{_fh};
 169         delete $self->{_fh};
 170     }
 171     for my $file ( @{$self->{delete}} ) {
 172         unlink $file or warn "Couldn't remove tempfile $file : $!\n";
 173     }
 174 }
 175
 176 =head1 EXPORT
 177
 178 None by default.
 179
 180 =head1 COPYRIGHT AND LICENSE
 181
 182 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 183
 184 Copyright (C) 2003 Max Maischein
 185
 186 =head1 AUTHOR
 187
 188 Max Maischein, E<lt>corion@cpan.orgE<gt>
 189
 190 Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome !
 191
 192 =head1 SEE ALSO
 193
 194 L<WWW::Mechanize>,L<WWW::Mechanize::Shell>
 195
 196 =cut
 197
 198 1;