FS-Test/lib/FS/Test.pm

   1 package FS::Test;
   2
   3 use 5.006;
   4 use strict;
   5 use warnings FATAL => 'all';
   6
   7 #use File::ShareDir 'dist_dir';
   8 use WWW::Mechanize;
   9 use File::chdir;
  10 use URI;
  11 use File::Slurp qw(write_file);
  12 use Class::Accessor 'antlers';
  13 use File::Spec;
  14
  15 our $VERSION = '0.02';
  16
  17 =head1 NAME
  18
  19 Freeside testing suite
  20
  21 =head1 CLASS METHODS
  22
  23 =over 4
  24
  25 =item share_dir
  26
  27 Returns the path to the shared data directory, which contains the reference
  28 database image, the test plan, and probably other stuff.
  29
  30 =cut
  31
  32 sub share_dir {
  33 #  dist_dir('FS-Test')
  34 #  we no longer install this anywhere
  35   my @dirs = File::Spec->splitdir(File::Spec->rel2abs(__FILE__));
  36   splice @dirs, -3; # lib/FS/Test.pm
  37   File::Spec->catdir( @dirs, 'share' );
  38 }
  39
  40 =item new OPTIONS
  41
  42 Creates a test session. OPTIONS must contain 'dir', a directory to save the
  43 output files into (this may eventually default to a temp directory). It can
  44 optionally contain:
  45
  46 - fsurl: the root Freeside url [http://localhost/freeside]
  47 - user: the Freeside test username [test]
  48 - pass: the Freeside test password [test]
  49
  50 =cut
  51
  52 has dir   => ( is => 'rw' );
  53 has fsurl => ( is => 'rw' );
  54 has user  => ( is => 'rw' );
  55 has pass  => ( is => 'rw' );
  56 has mech  => ( is => 'rw' );
  57
  58 sub new {
  59   my $class = shift;
  60   my $self = {
  61     fsurl => 'http://localhost/freeside',
  62     user  => 'test',
  63     pass  => 'test',
  64     @_
  65   };
  66   bless $self;
  67
  68   # strip trailing slash, if any; it causes problems
  69   $self->{fsurl} =~ s(/$)();
  70
  71   die "FS::Test->new: 'dir' required" unless $self->dir;
  72   if ( ! -d $self->dir ) {
  73     mkdir $self->dir
  74       or die "can't create '".$self->dir."': $!";
  75   }
  76   if ( ! -w $self->dir ) {
  77     die "FS::Test->new: can't write to '". $self->dir . "'";
  78   }
  79
  80   $self->mech( WWW::Mechanize->new( autocheck => 0 ) );
  81
  82   #freeside v4_
  83   my $login = $self->fsurl . '/index.html';
  84   $self->mech->get($login)
  85     or die "FS::Test->new: couldn't fetch $login";
  86   $self->mech->submit_form(
  87     with_fields => {
  88       credential_0 => $self->user,
  89       credential_1 => $self->pass,
  90     },
  91   );
  92
  93   return $self;
  94 }
  95
  96 =back
  97
  98 =head1 METHODS
  99
 100 =over 4
 101
 102 =item fetch PATHS...
 103
 104 Takes one or more PATHS (Freeside URIs, relative to $self->fsurl, including
 105 query parameters) and downloads them from the web server, into the output
 106 directory. Currently this will write progress messages to standard output.
 107 If you don't like that, it's open source, fix it.
 108
 109 =cut
 110
 111 sub fetch {
 112   my $self = shift;
 113
 114   local $CWD = $self->dir;
 115
 116   my $base_uri = URI->new($self->fsurl);
 117   my $basedirs = () = $base_uri->path_segments;
 118
 119   foreach my $path (@_) {
 120     $path =~ s/^\s+//;
 121     $path =~ s/\s+$//;
 122     next if !$path;
 123
 124     if ($path =~ /^#(.*)/) {
 125       print "$path\n";
 126       next;
 127     }
 128
 129     my $uri = URI->new( $self->fsurl . '/' . $path);
 130     print $uri->path;
 131     my $response = $self->mech->get($uri);
 132     print " - " . $self->mech->status . "\n";
 133     next unless $response->is_success;
 134
 135     local $CWD;
 136     my @dirs = $uri->path_segments;
 137     splice @dirs, 0, $basedirs;
 138
 139     if ( length($uri->query) ) {
 140       # if there's a query string, use the (server-side) file name as the
 141       # last directory, and the query string as the local file name; this
 142       # allows multiple tests that differ only in the query string.
 143       push @dirs, $uri->query;
 144     }
 145     my $file = pop @dirs;
 146     # make the filename safe for inclusion in a makefile/shell script.
 147     # & and ; are both bad; using ":" is reversible and unambiguous (because
 148     # it can't appear in query params)
 149     $file =~ s/&/:/g;
 150     foreach my $dir (@dirs) {
 151       mkdir $dir unless -d $dir;
 152       push @CWD, $dir;
 153     }
 154     write_file($file, {binmode => ':utf8'}, $response->decoded_content);
 155
 156     # Detect Mason errors and make noise about them; they're presumably
 157     # _never_ correct.  Mason errors have one convenient property: there's no
 158     # <title> element on the page.
 159     if ( $self->mech->ct eq 'text/html' and !$self->mech->title ) {
 160       print "***error***\n";
 161     }
 162   }
 163 }
 164
 165 # what we don't do in here is diff the results.
 166 # Test::HTML::Differences from CPAN would be one way to do that.
 167
 168 1; # End of FS::Test