more robust testing platform, #37340

[freeside.git] / FS / FS / Test.pm

diff --git a/FS/FS/Test.pm b/FS/FS/Test.pm
new file mode 100644 (file)
index 0000000..9854b94
--- /dev/null
+++ b/FS/FS/Test.pm
@@ -0,0 +1,238 @@
+package FS::Test;
+
+use 5.006;
+use strict;
+use warnings FATAL => 'all';
+
+use FS::UID qw(adminsuidsetup);
+use FS::Record;
+use URI;
+use URI::Escape;
+use Class::Accessor 'antlers';
+use Class::Load qw(load_class);
+use File::Spec;
+use HTML::Form;
+
+our $VERSION = '0.03';
+
+=head1 NAME
+
+Freeside testing suite
+
+=head1 SYNOPSIS
+
+  use Test::More 'tests' => 1;
+  use FS::Test;
+  my $FS = FS::Test->new;
+  $FS->post('/edit/cust_main.cgi', ... ); # form fields
+  ok( !$FS->error );
+
+=head1 PROPERTIES
+
+=over 4
+
+=item page
+
+The content of the most recent page fetched from the UI.
+
+=item redirect
+
+The redirect location (relative to the Freeside root) of the redirect
+returned from the UI, if there was one.
+
+=head1 CLASS METHODS
+
+=item new OPTIONS
+
+Creates a test session. OPTIONS may contain:
+
+- user: the Freeside test username [test]
+- base: the fake base URL for Mason to use [http://fake.freeside.biz]
+
+=cut
+
+has user      => ( is => 'rw' );
+has base      => ( is => 'ro' );
+has fs_interp => ( is => 'rw' );
+has path      => ( is => 'rw' );
+has page      => ( is => 'ro' );
+has error     => ( is => 'rw' );
+has dbh       => ( is => 'rw' );
+has redirect  => ( is => 'rw' );
+
+sub new {
+  my $class = shift;
+  my $self = {
+    user  => 'test',
+    page  => '',
+    error => '',
+    base  => 'http://fake.freeside.biz',
+    @_
+  };
+  $self->{base} = URI->new($self->{base});
+  bless $self;
+
+  adminsuidsetup($self->user);
+  load_class('FS::Mason');
+  $self->dbh( FS::UID::dbh() );
+
+  my ($fs_interp) = FS::Mason::mason_interps('standalone',
+    outbuf => \($self->{page})
+  );
+  $fs_interp->error_mode('fatal');
+  $fs_interp->error_format('brief');
+
+  $self->fs_interp( $fs_interp );
+
+  RT::LoadConfig();
+  RT::Init();
+
+  return $self;
+}
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item post PATH, PARAMS
+
+=item post FORM
+
+Submits a request to PATH, through the Mason UI, with arguments in PARAMS.
+This will be converted to a URL query string. Anything returned by the UI
+will be in the C<page()> property. 
+
+Alternatively, takes an L<HTML::Form> object (with fields filled in, via
+the C<param()> method) and submits it.
+
+=cut
+
+sub post {
+  my $self = shift;
+
+  # shut up, CGI
+  local $CGI::LIST_CONTEXT_WARN = 0;
+
+  my ($path, $query);
+  if ( UNIVERSAL::isa($_[0], 'HTML::Form') ) {
+    my $form = shift;
+    my $request = $form->make_request;
+    $path = $request->uri->path;
+    $query = $request->content;
+  } else {
+    $path = shift;
+    my @params = @_;
+    if (scalar(@params) == 0) {
+      # possibly path?query syntax, or else no query string at all
+      ($path, $query) = split('\?', $path);
+    } elsif (scalar(@params) == 1) {
+      $query = uri_escape($params[0]); # keyword style
+    } else {
+      while (@params) {
+        $query .= uri_escape(shift @params) . '=' .
+                  uri_escape(shift @params);
+        $query .= ';' if @params;
+      }
+    }
+  }
+  # remember which page this is
+  $self->path($path);
+
+  local $FS::Mason::Request::FSURL = $self->base->as_string;
+  local $FS::Mason::Request::QUERY_STRING = $query;
+  # because we're going to construct an actual CGI object in here
+  local $ENV{SERVER_NAME} = $self->base->host;
+  local $ENV{SCRIPT_NAME} = $self->base->path . $path;
+  local $@ = '';
+  my $mason_request = $self->fs_interp->make_request(comp => $path);
+  eval {
+    $mason_request->exec();
+  };
+
+  if ( $@ ) {
+    if ( ref $@ eq 'HTML::Mason::Exception' ) {
+      $self->error($@->message);
+    } else {
+      $self->error($@);
+    }
+  } elsif ( $mason_request->notes('error') ) {
+    $self->error($mason_request->notes('error'));
+  } else {
+    $self->error('');
+  }
+
+  if ( my $loc = $mason_request->redirect ) {
+    my $base = $self->base->as_string;
+    $loc =~ s/^$base//;
+    $self->redirect($loc);
+  } else {
+    $self->redirect('');
+  }
+  ''; # return error? HTTP status? something?
+}
+
+=item proceed
+
+If the last request returned a redirect, follow it.
+
+=cut
+
+sub proceed {
+  my $self = shift;
+  if ($self->redirect) {
+    $self->post($self->redirect);
+  }
+  # else do nothing
+}
+
+=item forms
+
+For the most recently returned page, returns a list of L<HTML::Form>s found.
+
+=cut
+
+sub forms {
+  my $self = shift;
+  my $formbase = $self->base->as_string . $self->path;
+  return HTML::Form->parse( $self->page, base => $formbase );
+}
+
+=item form NAME
+
+For the most recently returned page, returns an L<HTML::Form> object
+representing the form named NAME. You can then call methods like
+C<value(inputname, inputvalue)> to set the values of inputs on the form,
+and then pass the form object to L</post> to submit it.
+
+=cut
+
+sub form {
+  my $self = shift;
+  my $name = shift;
+  my ($form) = grep { $_->attr('name') eq $name } $self->forms;
+  $form;
+}
+
+=item qsearch ARGUMENTS
+
+Searches the database, like L<FS::Record::qsearch>.
+
+=item qsearchs ARGUMENTS
+
+Searches the database for a single record, like L<FS::Record::qsearchs>.
+
+=cut
+
+sub qsearch {
+  my $self = shift;
+  FS::Record::qsearch(@_);
+}
+
+sub qsearchs {
+  my $self = shift;
+  FS::Record::qsearchs(@_);
+}
+
+1; # End of FS::Test