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 v3
  83   $self->mech->credentials( $self->user, $self->pass );
  84
  85   return $self;
  86 }
  87
  88 =back
  89
  90 =head1 METHODS
  91
  92 =over 4
  93
  94 =item fetch PATHS...
  95
  96 Takes one or more PATHS (Freeside URIs, relative to $self->fsurl, including
  97 query parameters) and downloads them from the web server, into the output
  98 directory. Currently this will write progress messages to standard output.
  99 If you don't like that, it's open source, fix it.
 100
 101 =cut
 102
 103 sub fetch {
 104   my $self = shift;
 105
 106   local $CWD = $self->dir;
 107
 108   my $base_uri = URI->new($self->fsurl);
 109   my $basedirs = () = $base_uri->path_segments;
 110
 111   foreach my $path (@_) {
 112     $path =~ s/^\s+//;
 113     $path =~ s/\s+$//;
 114     next if !$path;
 115
 116     if ($path =~ /^#(.*)/) {
 117       print "$path\n";
 118       next;
 119     }
 120
 121     my $uri = URI->new( $self->fsurl . '/' . $path);
 122     print $uri->path;
 123     my $response = $self->mech->get($uri);
 124     print " - " . $self->mech->status . "\n";
 125     next unless $response->is_success;
 126
 127     local $CWD;
 128     my @dirs = $uri->path_segments;
 129     splice @dirs, 0, $basedirs;
 130
 131     if ( length($uri->query) ) {
 132       # if there's a query string, use the (server-side) file name as the
 133       # last directory, and the query string as the local file name; this
 134       # allows multiple tests that differ only in the query string.
 135       push @dirs, $uri->query;
 136     }
 137     my $file = pop @dirs;
 138     # make the filename safe for inclusion in a makefile/shell script.
 139     # & and ; are both bad; using ":" is reversible and unambiguous (because
 140     # it can't appear in query params)
 141     $file =~ s/&/:/g;
 142     foreach my $dir (@dirs) {
 143       mkdir $dir unless -d $dir;
 144       push @CWD, $dir;
 145     }
 146     write_file($file, {binmode => ':utf8'}, $response->decoded_content);
 147
 148     # Detect Mason errors and make noise about them; they're presumably
 149     # _never_ correct.  Mason errors have one convenient property: there's no
 150     # <title> element on the page.
 151     if ( $self->mech->ct eq 'text/html' and !$self->mech->title ) {
 152       print "***error***\n";
 153     }
 154   }
 155 }
 156
 157 # what we don't do in here is diff the results.
 158 # Test::HTML::Differences from CPAN would be one way to do that.
 159
 160 1; # End of FS::Test