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 v3
  78   $self->mech->credentials( $self->user, $self->pass );
  79
  80   return $self;
  81 }
  82
  83 =back
  84
  85 =head1 METHODS
  86
  87 =over 4
  88
  89 =item fetch PATHS...
  90
  91 Takes one or more PATHS (Freeside URIs, relative to $self->fsurl, including
  92 query parameters) and downloads them from the web server, into the output
  93 directory. Currently this will write progress messages to standard output.
  94 If you don't like that, it's open source, fix it.
  95
  96 =cut
  97
  98 sub fetch {
  99   my $self = shift;
 100
 101   local $CWD = $self->dir;
 102
 103   my $base_uri = URI->new($self->fsurl);
 104   my $basedirs = () = $base_uri->path_segments;
 105
 106   foreach my $path (@_) {
 107     $path =~ s/^\s+//;
 108     $path =~ s/\s+$//;
 109     next if !$path;
 110
 111     if ($path =~ /^#(.*)/) {
 112       print "$path\n";
 113       next;
 114     }
 115
 116     my $uri = URI->new( $self->fsurl . '/' . $path);
 117     print $uri->path;
 118     my $response = $self->mech->get($uri);
 119     print " - " . $response->code . "\n";
 120     next unless $response->is_success;
 121
 122     local $CWD;
 123     my @dirs = $uri->path_segments;
 124     splice @dirs, 0, $basedirs;
 125
 126     if ( length($uri->query) ) {
 127       # if there's a query string, use the (server-side) file name as the
 128       # last directory, and the query string as the local file name; this
 129       # allows multiple tests that differ only in the query string.
 130       push @dirs, $uri->query;
 131     }
 132     my $file = pop @dirs;
 133     # make the filename safe for inclusion in a makefile/shell script.
 134     # & and ; are both bad; using ":" is reversible and unambiguous (because
 135     # it can't appear in query params)
 136     $file =~ s/&/:/g;
 137     foreach my $dir (@dirs) {
 138       mkdir $dir unless -d $dir;
 139       push @CWD, $dir;
 140     }
 141     write_file($file, {binmode => ':utf8'}, $response->decoded_content);
 142   }
 143 }
 144
 145 1; # End of FS::Test