lib/CXGN/VHost/Test.pm

   1 package CXGN::VHost::Test;
   2 use strict;
   3 use warnings;
   4 use English;
   5 use Carp;
   6
   7 use URI;
   8
   9 use Catalyst::Utils;
  10
  11 use CXGN::DB::Connection;
  12
  13 =head1 NAME
  14
  15 CXGN::VHost::Test - Test CXGN web applications.
  16
  17 =head1 SYNOPSIS
  18
  19     # to run tests
  20     SGN_TEST_SERVER='http://sgn.localhost.localdomain/' prove -r -l lib/ t/
  21
  22     # Tests
  23     use CXGN::VHost::Test;
  24     request('index.html');
  25     get('index.html');
  26
  27
  28 =head1 DESCRIPTION
  29
  30 Test CXGN web applications.  This is basically a copy of
  31 Catalyst::Test, tweaked to work with current CXGN web applications, if
  32 you use this module your test script should be completely
  33 Catalyst-ready.
  34
  35 =head2 METHODS
  36
  37 =head2 get
  38
  39 Returns the content.
  40
  41     my $content = get('foo/bar?test=1');
  42
  43 Note that this method doesn't follow redirects, so to test for a
  44 correctly redirecting page you'll need to use a combination of this
  45 method and the L<request> method below:
  46
  47     my $res = request('/'); # redirects to /y
  48     warn $res->header('location');
  49     use URI;
  50     my $uri = URI->new($res->header('location'));
  51     is ( $uri->path , '/y');
  52     my $content = get($uri->path);
  53
  54 =head2 request
  55
  56 Returns a C<HTTP::Response> object.
  57
  58     my $res = request('foo/bar?test=1');
  59
  60 =cut
  61
  62
  63 use base qw/Exporter/;
  64 our @EXPORT = qw/ request get /;
  65
  66 #< copied from Catalyst::Test
  67
  68
  69 sub get {
  70   request(@_)->content;
  71 }
  72
  73 my $agent;
  74 sub request {
  75
  76     unless( $ENV{SGN_TEST_SERVER} ) {
  77         croak "the SGN_TEST_SERVER environment variable must be set to use ".__PACKAGE__;
  78     }
  79
  80     die "SGN_TEST_SERVER env var must begin with http://\n"
  81         unless $ENV{SGN_TEST_SERVER} =~ m!^http://!;
  82
  83     ## Added an enviromental variable SGN_SERVER_TIMEOUT. In some machines load some pages
  84     ## needs more than 60 s, so if it is better if it can be changed
  85
  86     my $timeout = $ENV{SGN_SERVER_TIMEOUT} || 60;
  87
  88     require LWP::UserAgent;
  89
  90     my $request = Catalyst::Utils::request( shift(@_) );
  91     my $server  = URI->new( $ENV{SGN_TEST_SERVER} );
  92
  93     if ( $server->path =~ m|^(.+)?/$| ) {
  94         my $path = $1;
  95         $server->path("$path") if $path;    # need to be quoted
  96     }
  97
  98     # the request path needs to be sanitised if $server is using a
  99     # non-root path due to potential overlap between request path and
 100     # response path.
 101     if ($server->path) {
 102         # If request path is '/', we have to add a trailing slash to the
 103         # final request URI
 104         my $add_trailing = $request->uri->path eq '/';
 105
 106         my @sp = split '/', $server->path;
 107         my @rp = split '/', $request->uri->path;
 108         shift @sp;shift @rp; # leading /
 109         if (@rp) {
 110             foreach my $sp (@sp) {
 111                 $sp eq $rp[0] ? shift @rp : last
 112             }
 113         }
 114         $request->uri->path(join '/', @rp);
 115
 116
 117
 118         if ( $add_trailing ) {
 119             $request->uri->path( $request->uri->path . '/' );
 120         }
 121     }
 122
 123     $request->uri->scheme( $server->scheme );
 124     $request->uri->host( $server->host );
 125     $request->uri->port( $server->port );
 126     $request->uri->path( $server->path . $request->uri->path );
 127
 128     unless ($agent) {
 129
 130         $agent = LWP::UserAgent->new(
 131             keep_alive   => 1,
 132             max_redirect => 0,
 133             timeout      => $timeout,
 134         );
 135
 136         $agent->env_proxy;
 137     }
 138
 139     return $agent->request($request);
 140 }
 141
 142
 143 =head1 SUBCLASSES
 144
 145 none yet
 146
 147 =head1 METHODS
 148
 149 =head1 MAINTAINER
 150
 151 Robert Buels
 152
 153 =head1 AUTHOR(S)
 154
 155 Robert Buels, E<lt>rmb32@cornell.eduE<gt>
 156
 157 =head1 COPYRIGHT & LICENSE
 158
 159 Copyright 2009 Boyce Thompson Institute for Plant Research
 160
 161 This program is free software; you can redistribute it and/or modify
 162 it under the same terms as Perl itself.
 163
 164 =cut
 165
 166 ###
 167 1;#do not remove
 168 ###