tests/lib/Test/Quvi.pm

   1 # quvi
   2 # Copyright (C) 2011  Toni Gundogdu <legatvs@gmail.com>
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2.1 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17 # 02110-1301  USA
  18 #
  19
  20 package Test::Quvi;
  21
  22 use warnings;
  23 use strict;
  24
  25 use version 0.77 (); our $VERSION = version->declare("0.1.0");
  26
  27 require Exporter;
  28 use vars qw(@ISA @EXPORT @EXPORT_OK);
  29
  30 our @ISA    = qw(Exporter);
  31 our @EXPORT = ();
  32
  33 use Getopt::Long qw(:config bundling);
  34 use Carp qw(croak);
  35 use Test::More;
  36 use Test::Deep;
  37 use File::Spec;
  38 use Cwd qw(cwd);
  39
  40 =for comment
  41 Parse command line options, create object(s), etc. Make a note of
  42 default values (e.g. assume quvi(1) to be found in the $PATH if
  43 --quvi-path is not used.
  44 =cut
  45
  46 sub new
  47 {
  48   my ($class, %args) = @_;
  49   my $self = bless {}, $class;
  50
  51   my %config;
  52   GetOptions(
  53           \%config,
  54           'url|u=s',
  55           'quvi_path|quvi-path|quvipath|q=s',
  56           'libquvi_scriptsdir|libquvi-scriptsdir|libquviscriptsdir|b=s',
  57           'quvi_opts|quvi-opts|quviopts|o=s',
  58           'json_file|json-file|jsonfile|j=s',
  59           'dump_json|dump-json|dumpjson|J',
  60           'data_root|data-root|dataroot|d=s',
  61           'ignore|i=s',
  62           'valgrind_path|valgrind-path|valgrindpath|v=s',
  63           'fixme',
  64           'nlfy',
  65           'nsfw',
  66   );
  67   $config{quvi_path} ||= 'quvi';    # Presume it is found in the $PATH.
  68   $config{data_root} ||= cwd;
  69   $self->{config}          = \%config;
  70   $self->{jobj}            = JSON::XS->new if $JSON::XS::VERSION;
  71   $ENV{LIBQUVI_SCRIPTSDIR} = $config{libquvi_scriptsdir}
  72     if $config{libquvi_scriptsdir};
  73   $self;
  74 }
  75
  76 # Reuse the JSON object instead of re-creating one for each test.
  77
  78 sub get_json_obj
  79 {
  80   my ($self) = @_;
  81   $self->{jobj};
  82 }
  83
  84 # A short-hand to access the parsed command line options.
  85
  86 sub get_config
  87 {
  88   my ($self) = @_;
  89   $self->{config};
  90 }
  91
  92 # Find all occurences of '*.json' from the specified paths.
  93
  94 sub find_json
  95 {
  96   my ($self, @paths) = @_;
  97   my @files;
  98   my $d = $self->{config}{data_root};
  99   foreach (@paths)
 100   {
 101     my $p = File::Spec->catfile($d, $_, '*.json');
 102     @files = (@files, glob($p));
 103   }
 104   @files;
 105 }
 106
 107 =for comment
 108 Read the specified JSON file. Prepend $config{data_root} to the file
 109 path if requested, this is needed typically if read_json is called
 110 without a preceeding call to find_json (e.g. t/redirect.t and
 111 t/shortened.t skip find_json).
 112 =cut
 113
 114 sub read_json
 115 {
 116   my ($self, $fpath, $prepend_data_root) = @_;
 117
 118   if ($prepend_data_root)
 119   {
 120     my $d = $self->{config}{data_root};
 121     $fpath = File::Spec->catfile($d, $fpath);
 122   }
 123
 124   note "read $fpath";
 125   open my $fh, "<", "$fpath" or croak "$fpath: $!";
 126   my $e = $self->{jobj}->decode(join '', <$fh>);
 127   close $fh;
 128
 129   # Ignore these by default.
 130   my @ignore = qw(url thumbnail_url);
 131
 132   # Any aditional JSON keys to be ignored.
 133   if ($self->{config}{ignore})
 134   {
 135     @ignore = (@ignore, split /,/, $self->{config}{ignore});
 136   }
 137
 138   mark_ignored($self, \$e, @ignore);
 139   $e;
 140 }
 141
 142 =for comment
 143 Mark those JSON elements that are to be ignored in deep comparison.
 144 Note that 'link' is a special case. We have to also assume that there
 145 could be more than one 'link'.
 146 =cut
 147
 148 sub mark_ignored
 149 {
 150   my ($self, $json, @a) = @_;
 151   for my $i (@a)
 152   {
 153     while (my ($k, $v) = each(%{$$json}))
 154     {
 155       if ($k eq "link")
 156       {
 157         my $n = 0;
 158         for my $l (@{$v})
 159         {
 160           while (my ($kl, $vl) = each(%{$l}))
 161           {
 162             $$json->{$k}[$n]->{$kl} = ignore()
 163               if $kl eq $i;
 164           }
 165           ++$n;
 166         }
 167       }
 168       else
 169       {
 170         $$json->{$k} = ignore() if $k eq $i;
 171       }
 172     }
 173   }
 174 }
 175
 176 # Construct the command to run quvi.
 177
 178 sub _build_cmd
 179 {
 180   my ($self, $url, @extra_args) = @_;
 181   my $q = $self->{config}{quvi_path};
 182   my $c = qq/$q "$url" /;
 183
 184   if ($self->{config}{quvi_opts})
 185   {
 186     $c .= ' ' . $self->{config}{quvi_opts};
 187   }
 188   else
 189   {
 190     $c .= join ' ', @extra_args if @extra_args;
 191   }
 192   $c;
 193 }
 194
 195 # Run the quvi command.
 196
 197 sub _run_cmd
 198 {
 199   my ($self, $cmd) = @_;
 200
 201   note "run: $cmd";
 202
 203   my $o = join '', qx/$cmd/;
 204   my $r = $? >> 8;
 205
 206   print STDERR "\n$o"
 207     if $r == 0 and $self->{config}{dump_json};
 208
 209   ($r, $o);
 210 }
 211
 212 =for comment
 213 Run quvi(1) with the specified options. Return quvi exit status and
 214 the output (printed to stdout).
 215 =cut
 216
 217 sub run
 218 {
 219   my $self = shift;
 220   _run_cmd($self, _build_cmd($self, @_));
 221 }
 222
 223 # Same as above but run quvi through valgrind.
 224
 225 sub run_with_valgrind
 226 {
 227   my $self = shift;
 228   my $c = _build_cmd($self, @_);
 229   if ($self->{config}{valgrind_path})
 230   {
 231     my $v = $self->{config}{valgrind_path};
 232     $c = "libtool --mode=execute $v -q --leak-check=full "
 233       . "--track-origins=yes --error-exitcode=1 $c";
 234   }
 235   _run_cmd($self, $c);
 236 }
 237
 238 sub test_skip
 239 {
 240   return 0 unless $ENV{TEST_SKIP};
 241   my ($self, $var) = @_;
 242   my %h;
 243   $h{$_} = 1 foreach split /,/, $ENV{TEST_SKIP};
 244   $h{$var};
 245 }
 246
 247 1;
 248
 249 # vim: set ts=2 sw=2 tw=72 expandtab: