FS/FS/Test.pm

   1 package FS::Test;
   2
   3 use 5.006;
   4 use strict;
   5 use warnings FATAL => 'all';
   6
   7 use FS::UID qw(adminsuidsetup);
   8 use FS::Record;
   9 use URI;
  10 use URI::Escape;
  11 use Class::Accessor 'antlers';
  12 use Class::Load qw(load_class);
  13 use File::Spec;
  14 use HTML::Form;
  15
  16 our $VERSION = '0.03';
  17
  18 =head1 NAME
  19
  20 Freeside testing suite
  21
  22 =head1 SYNOPSIS
  23
  24   use Test::More 'tests' => 1;
  25   use FS::Test;
  26   my $FS = FS::Test->new;
  27   $FS->post('/edit/cust_main.cgi', ... ); # form fields
  28   ok( !$FS->error );
  29
  30 =head1 PROPERTIES
  31
  32 =over 4
  33
  34 =item page
  35
  36 The content of the most recent page fetched from the UI.
  37
  38 =item redirect
  39
  40 The redirect location (relative to the Freeside root) of the redirect
  41 returned from the UI, if there was one.
  42
  43 =head1 CLASS METHODS
  44
  45 =item new OPTIONS
  46
  47 Creates a test session. OPTIONS may contain:
  48
  49 - user: the Freeside test username [test]
  50 - base: the fake base URL for Mason to use [http://fake.freeside.biz]
  51
  52 =cut
  53
  54 has user      => ( is => 'rw' );
  55 has base      => ( is => 'ro' );
  56 has fs_interp => ( is => 'rw' );
  57 has path      => ( is => 'rw' );
  58 has page      => ( is => 'ro' );
  59 has error     => ( is => 'rw' );
  60 has dbh       => ( is => 'rw' );
  61 has redirect  => ( is => 'rw' );
  62
  63 sub new {
  64   my $class = shift;
  65   my $self = {
  66     user  => 'test',
  67     page  => '',
  68     error => '',
  69     base  => 'http://fake.freeside.biz',
  70     @_
  71   };
  72   $self->{base} = URI->new($self->{base});
  73   bless $self;
  74
  75   adminsuidsetup($self->user);
  76   load_class('FS::Mason');
  77   $self->dbh( FS::UID::dbh() );
  78
  79   my ($fs_interp) = FS::Mason::mason_interps('standalone',
  80     outbuf => \($self->{page})
  81   );
  82   $fs_interp->error_mode('fatal');
  83   $fs_interp->error_format('brief');
  84
  85   $self->fs_interp( $fs_interp );
  86
  87   RT::LoadConfig();
  88   RT::Init();
  89
  90   return $self;
  91 }
  92
  93 =back
  94
  95 =head1 METHODS
  96
  97 =over 4
  98
  99 =item post PATH, PARAMS
 100
 101 =item post FORM
 102
 103 Submits a request to PATH, through the Mason UI, with arguments in PARAMS.
 104 This will be converted to a URL query string. Anything returned by the UI
 105 will be in the C<page()> property.
 106
 107 Alternatively, takes an L<HTML::Form> object (with fields filled in, via
 108 the C<param()> method) and submits it.
 109
 110 =cut
 111
 112 sub post {
 113   my $self = shift;
 114
 115   # shut up, CGI
 116   local $CGI::LIST_CONTEXT_WARN = 0;
 117
 118   my ($path, $query);
 119   if ( UNIVERSAL::isa($_[0], 'HTML::Form') ) {
 120     my $form = shift;
 121     my $request = $form->make_request;
 122     $path = $request->uri->path;
 123     $query = $request->content;
 124   } else {
 125     $path = shift;
 126     my @params = @_;
 127     if (scalar(@params) == 0) {
 128       # possibly path?query syntax, or else no query string at all
 129       ($path, $query) = split('\?', $path);
 130     } elsif (scalar(@params) == 1) {
 131       $query = uri_escape($params[0]); # keyword style
 132     } else {
 133       while (@params) {
 134         $query .= uri_escape(shift @params) . '=' .
 135                   uri_escape(shift @params);
 136         $query .= ';' if @params;
 137       }
 138     }
 139   }
 140   # remember which page this is
 141   $self->path($path);
 142
 143   local $FS::Mason::Request::FSURL = $self->base->as_string;
 144   local $FS::Mason::Request::QUERY_STRING = $query;
 145   # because we're going to construct an actual CGI object in here
 146   local $ENV{SERVER_NAME} = $self->base->host;
 147   local $ENV{SCRIPT_NAME} = $self->base->path . $path;
 148   local $@ = '';
 149   my $mason_request = $self->fs_interp->make_request(comp => $path);
 150   eval {
 151     $mason_request->exec();
 152   };
 153
 154   if ( $@ ) {
 155     if ( ref $@ eq 'HTML::Mason::Exception' ) {
 156       $self->error($@->message);
 157     } else {
 158       $self->error($@);
 159     }
 160   } elsif ( $mason_request->notes('error') ) {
 161     $self->error($mason_request->notes('error'));
 162   } else {
 163     $self->error('');
 164   }
 165
 166   if ( my $loc = $mason_request->redirect ) {
 167     my $base = $self->base->as_string;
 168     $loc =~ s/^$base//;
 169     $self->redirect($loc);
 170   } else {
 171     $self->redirect('');
 172   }
 173   ''; # return error? HTTP status? something?
 174 }
 175
 176 =item proceed
 177
 178 If the last request returned a redirect, follow it.
 179
 180 =cut
 181
 182 sub proceed {
 183   my $self = shift;
 184   if ($self->redirect) {
 185     $self->post($self->redirect);
 186   }
 187   # else do nothing
 188 }
 189
 190 =item forms
 191
 192 For the most recently returned page, returns a list of L<HTML::Form>s found.
 193
 194 =cut
 195
 196 sub forms {
 197   my $self = shift;
 198   my $formbase = $self->base->as_string . $self->path;
 199   return HTML::Form->parse( $self->page, base => $formbase );
 200 }
 201
 202 =item form NAME
 203
 204 For the most recently returned page, returns an L<HTML::Form> object
 205 representing the form named NAME. You can then call methods like
 206 C<value(inputname, inputvalue)> to set the values of inputs on the form,
 207 and then pass the form object to L</post> to submit it.
 208
 209 =cut
 210
 211 sub form {
 212   my $self = shift;
 213   my $name = shift;
 214   my ($form) = grep { ($_->attr('name') || '') eq $name } $self->forms;
 215   $form;
 216 }
 217
 218 =item qsearch ARGUMENTS
 219
 220 Searches the database, like L<FS::Record::qsearch>.
 221
 222 =item qsearchs ARGUMENTS
 223
 224 Searches the database for a single record, like L<FS::Record::qsearchs>.
 225
 226 =cut
 227
 228 sub qsearch {
 229   my $self = shift;
 230   FS::Record::qsearch(@_);
 231 }
 232
 233 sub qsearchs {
 234   my $self = shift;
 235   FS::Record::qsearchs(@_);
 236 }
 237
 238 =item new_customer FIRSTNAME
 239
 240 Returns an L<FS::cust_main> object full of default test data, ready to be inserted.
 241 This doesn't insert the customer, because you might want to change some things first.
 242 FIRSTNAME is recommended so you know which test the customer was used for.
 243
 244 =cut
 245
 246 sub new_customer {
 247   my $self = shift;
 248   my $first = shift || 'No Name';
 249   my $location = FS::cust_location->new({
 250       address1  => '123 Example Street',
 251       city      => 'Sacramento',
 252       state     => 'CA',
 253       country   => 'US',
 254       zip       => '94901',
 255   });
 256   my $cust = FS::cust_main->new({
 257       agentnum      => 1,
 258       refnum        => 1,
 259       last          => 'Customer',
 260       first         => $first,
 261       invoice_email => 'newcustomer@fake.freeside.biz',
 262       bill_location => $location,
 263       ship_location => $location,
 264   });
 265   $cust;
 266 }
 267
 268 1; # End of FS::Test