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