t/BSE/Test.pm

   1 package BSE::Test;
   2 use strict;
   3 use vars qw(@ISA @EXPORT @EXPORT_OK);
   4 use Exporter 'import';
   5 @EXPORT = qw(base_url fetch_ok make_url skip make_ua);
   6 @EXPORT_OK = qw(base_url make_ua fetch_url fetch_ok make_url skip
   7                 make_post check_form post_ok check_content follow_ok
   8                 follow_refresh_ok click_ok config test_actions);
   9 use lib 'site/cgi-bin/modules';
  10 use BSE::Cfg;
  11
  12 my $conffile = $ENV{BSETEST} || 'install.cfg';
  13
  14 my $cfg = BSE::Cfg->new
  15   (
  16    path => "site/cgi-bin",
  17    extra_file => $conffile,
  18   );
  19
  20 sub config {
  21   $cfg;
  22 }
  23
  24 sub base_url {
  25   $cfg->entryVar("site", "url");
  26 }
  27
  28 sub base_securl {
  29   $cfg->entryVar("site", "secureurl");
  30 }
  31
  32 sub base_dir {
  33   $cfg->entryVar("paths", "siteroot");
  34 }
  35
  36 sub mysql_name {
  37   $cfg->entry("binaries", "mysql", "mysql");
  38 }
  39
  40 sub test_dsn {
  41   $cfg->entry("db", "dsn");
  42 }
  43
  44 sub test_dbuser {
  45   $cfg->entry("db", "user");
  46 }
  47
  48 sub test_dbpass {
  49   $cfg->entry("db", "password");
  50 }
  51
  52 sub test_dbclass {
  53   $cfg->entry("db", "class", "BSE::DB::Mysql");
  54 }
  55
  56 sub test_sessionclass {
  57   $cfg->entry("basic", "session_class", "Apache::Session::Mysql");
  58 }
  59
  60 sub test_perl {
  61   $cfg->entry("paths", "perl", $^X);
  62 }
  63
  64 sub test_conffile {
  65   $conffile;
  66 }
  67
  68 sub make_ua {
  69   require WWW::Mechanize;
  70   require "HTTP/Cookies.pm";
  71   my $ua = WWW::Mechanize->new(onerror => undef);
  72   $ua->cookie_jar(HTTP::Cookies->new);
  73
  74   $ua;
  75 }
  76
  77 # in scalar context returns content
  78 # in list context returns ($content, $code)
  79 # $post is any data to be part of a post request
  80 sub fetch_url {
  81   my ($ua, $url, $method, $post) = @_;
  82
  83   $method ||= 'GET';
  84   my $hdrs = HTTP::Headers->new;
  85   $hdrs->header(Content_Length => length $post) if $post;
  86   my $req = HTTP::Request->new($method, $url, $hdrs);
  87   $req->content($post) if $post;
  88   my $resp = $ua->request($req);
  89   if (wantarray) {
  90     return ($resp->content(), $resp->code(), $resp->is_success,
  91             $resp->headers_as_string());
  92   }
  93   else {
  94     return $resp->is_success() ? $resp->content() : undef;
  95   }
  96 }
  97
  98 sub make_url {
  99   my ($base, @data) = @_;
 100
 101   require "URI/Escape.pm";
 102   my @pairs;
 103   while (my ($key, $value) = splice(@data, 0, 2)) {
 104     push(@pairs, "$key=".URI::uri_escape($value));
 105   }
 106   return $base."?".join("&",@pairs);
 107 }
 108
 109 sub check_content {
 110   my ($content, $note, $match) = @_;
 111   my $tb = Test::Builder->new;
 112   local $Test::Builder::Level = $Test::Builder::Level + 1;
 113
 114   return $tb->like($content, qr/$match/s, "$note: match");
 115 }
 116
 117 sub _check_fetch {
 118   my ($content, $code, $ok, $headers,
 119       $note, $match, $headmatch) = @_;
 120
 121   my $tb = Test::Builder->new;
 122   local $Test::Builder::Level = $Test::Builder::Level + 1;
 123
 124   my $good = $ok;
 125   $tb->ok($ok, "$note: fetch ($code)");
 126   SKIP:
 127   {
 128     my $count = 0;
 129     $count++ if $match;
 130     $count++ if $headmatch;
 131     $ok or skip("$note: fetch failed", $count) if $count;
 132     if ($match) {
 133       unless ($tb->like($content, qr/$match/s, "$note: match")) {
 134         #print "# wanted /$match/ got:\n";
 135         #my $copy = $content;
 136         #$copy =~ s/^/# /gm;
 137         #$copy .= "\n" unless $copy =~ /\n\z/;
 138         #print $copy;
 139         $good = 0;
 140       }
 141     }
 142     if ($headmatch) {
 143       unless ($tb->like($headers, qr/$headmatch/s, "$note: headmatch")) {
 144         #print "# wanted /$headmatch/ got:\n";
 145         #my $copy = $headers;
 146         #$copy =~ s/^/# /gm;
 147         #$copy .= "\n" unless $copy =~ /\n\z/;
 148         #print $copy;
 149         $good = 0;
 150       }
 151     }
 152   }
 153
 154   if (wantarray) {
 155     return ($content, $code, $good, $headers);
 156   }
 157   else {
 158     return $good ? $content : undef;
 159   }
 160 }
 161
 162 sub make_post {
 163   my (@data) = @_;
 164
 165   require "URI/Escape.pm";
 166   my @pairs;
 167   while (my ($key, $value) = splice(@data, 0, 2)) {
 168     push(@pairs, "$key=".URI::Escape::uri_escape($value));
 169   }
 170   return join("&",@pairs);
 171 }
 172
 173 sub post_ok {
 174   my ($ua, $note, $url, $data, $match, $headmatch) = @_;
 175
 176   $data = make_post(@$data) if ref $data;
 177
 178   my ($content, $code, $ok, $headers) = fetch_url($ua, $url, POST=>$data);
 179
 180   return _check_fetch($content, $code, $ok, $headers,
 181                       $note, $match, $headmatch)
 182 }
 183
 184 sub fetch_ok {
 185   my ($ua, $note, $url, $match, $headmatch) = @_;
 186
 187   my $resp = $ua->get($url);
 188   my $ok = $resp->is_success;
 189   return _check_fetch($ua->{content}, $ua->{status}, $ok,
 190                       $ua->{res}->headers_as_string, $note,
 191                       $match, $headmatch)
 192 }
 193
 194 sub follow_ok {
 195   my ($ua, $note, $link, $match, $headmatch) = @_;
 196
 197   my $ok;
 198   if (ref $link) {
 199     my $resp = $ua->follow_link(%$link);
 200     $ok = $resp->is_success;
 201   }
 202   else {
 203     $ok = $ua->follow_link(text_regex => qr/\Q$link/);
 204   }
 205
 206   return _check_fetch($ua->{content}, $ua->{status}, $ok,
 207                       $ua->{res}->headers_as_string, $note,
 208                       $match, $headmatch)
 209 }
 210
 211 sub follow_refresh_ok {
 212   my ($ua, $note, $match, $headmatch) = @_;
 213
 214   my $skip = 1;
 215   ++$skip if $match;
 216   ++$headmatch if $headmatch;
 217   my $refresh = $ua->response->header('Refresh');
 218   if (ok($refresh, "$note - refresh header")) {
 219     my $url;
 220     if ($refresh =~ /^\s*\d+\s*;\s*url=\"([^\"]+)\"/
 221        or $refresh =~ /^\s*\d+\s*;\s*url\s*=\s*(\S+)/) {
 222       $url = $1;
 223       $url = URI->new_abs($url, $ua->uri);
 224     }
 225     else {
 226       $url = $ua->uri;
 227     }
 228     print "# refresh to $url\n";
 229     fetch_ok($ua, "$note - fetch", $url);
 230   }
 231   else {
 232     skip("$note - skipped, not a refresh", $skip);
 233   }
 234 }
 235
 236 sub click_ok {
 237   my ($ua, $note, $name, $match, $headmatch) = @_;
 238
 239   local $Test::Builder::Level = $Test::Builder::Level + 1;
 240   my $tb = Test::Builder->new;
 241
 242   my $ok = $tb->ok($ua->click($name), "$note - click");
 243   return _check_fetch($ua->{content}, $ua->{status}, $ok,
 244                       $ua->{res}->headers_as_string, $note,
 245                       $match, $headmatch)
 246 }
 247
 248 sub check_form {
 249   my ($content, $note, %checks) = @_;
 250
 251   require 'HTML/Parser.pm';
 252   require 'HTML/Entities.pm';
 253   my $in;
 254   my $keep;
 255   my $saved = '';
 256   my %todo = %checks;
 257   my $inselect;
 258   my $selname;
 259   my $checked_sel_value;
 260   my $textname;
 261   my %values;
 262
 263   my $tb = Test::Builder->new;
 264   local $Test::Builder::Level = $Test::Builder::Level + 1;
 265
 266   my $text =
 267     sub {
 268       my ($t) = @_;
 269       $saved .= $t if $keep;
 270     };
 271   my $start =
 272     sub {
 273       my ($tagname, $attr) = @_;
 274
 275       if ($tagname eq 'input') {
 276         my $name = $attr->{name};
 277         if ($name && $todo{$name}) {
 278           $tb->ok(1, "$note - $name - field is present");
 279           $values{$name} = $attr->{$name};
 280           if (defined $todo{$name}[0]) {
 281             my $cvalue = $checks{$name}[0];
 282             my $fvalue = $attr->{value};
 283             if (defined $fvalue) {
 284               $tb->ok($cvalue eq $fvalue, "$note - $name - comparing values");
 285             }
 286             else {
 287               $tb->ok(0, "$note - $name - value is not present");
 288             }
 289           }
 290           if (defined $todo{$name}[1]) {
 291             my $ttype = $todo{$name}[1];
 292             my $ftype = $attr->{type};
 293             if (defined $ftype) {
 294               $tb->ok($ttype eq $ftype, "$note - $name - comparing types");
 295             }
 296             else {
 297               $tb->ok(0, "$note - $name - type not present");
 298             }
 299           }
 300           delete $todo{$name};
 301         }
 302       }
 303       elsif ($tagname eq 'select') {
 304         $selname = $attr->{name};
 305
 306         if ($todo{$selname}) {
 307           $tb->ok(1, "$note - $selname - field is present");
 308           $inselect = 1;
 309           if (defined $todo{$selname}[1]) {
 310             $checked_sel_value = 0;
 311             my $ttype = $todo{$selname}[1];
 312             $tb->ok ($ttype eq 'select', "$note - $selname - checking type (select)");
 313           }
 314         }
 315       }
 316       elsif ($tagname eq 'option' && $inselect) {
 317         unless (exists $attr->{value}) {
 318           print "# warning - option in select $selname missing value\n";
 319         }
 320         if (exists $attr->{selected}) {
 321           $checked_sel_value = 1;
 322           $values{$selname} = $attr->{value};
 323           if (defined $todo{$selname}[0]) {
 324             my $fvalue = $attr->{value};
 325             my $tvalue = $todo{$selname}[0];
 326             if (defined $fvalue) {
 327               $tb->ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
 328             }
 329             else {
 330               $tb->ok(0, "$note - $selname - no value supplied");
 331             }
 332           }
 333         }
 334       }
 335       elsif ($tagname eq 'textarea') {
 336         $textname = $attr->{name};
 337         $saved = '';
 338         ++$keep;
 339       }
 340     };
 341   my $end =
 342     sub {
 343       my ($tagname) = @_;
 344
 345       if ($tagname eq 'select' && $inselect) {
 346         if (!$checked_sel_value) {
 347           $tb->ok(0, "$note - $selname - no value selected");
 348         }
 349         delete $todo{$selname};
 350       }
 351       elsif ($tagname eq 'textarea') {
 352         $keep = 0;
 353         if ($todo{$textname}) {
 354           my $fvalue = HTML::Entities::decode_entities($saved);
 355           $values{$textname} = $fvalue;
 356           $tb->ok(1, "$note - $textname - field exists");
 357           if (defined $todo{$textname}[0]) {
 358             my $tvalue = $todo{$textname}[0];
 359             $tb->ok($tvalue eq $fvalue, "$note - $textname - checking value($tvalue vs $fvalue)");
 360           }
 361           if (defined $todo{$textname}[1]) {
 362             $tb->ok ($todo{$textname}[1] eq 'textarea',
 363                 "$note - $textname - check field type");
 364           }
 365           delete $todo{$textname};
 366         }
 367       }
 368     };
 369   my $p = HTML::Parser->new( text_h => [ $text, "dtext" ],
 370                              start_h => [ $start, "tagname, attr" ],
 371                              end_h => [ $end, "tagname" ]);
 372   $p->parse($content);
 373   $p->eof;
 374   for my $name (keys %todo) {
 375     $tb->ok(0, "$note - $name - field doesn't exist");
 376     my $count = 0;
 377     ++$count if defined $todo{$name}[0];
 378     ++$count if defined $todo{$name}[1];
 379   SKIP: {
 380       skip("$note - $name - no field", $count) if $count;
 381     }
 382   }
 383
 384   return %values;
 385 }
 386
 387 # test that all actions have methods for a given dispatcher class
 388 sub test_actions {
 389   my ($class) = @_;
 390
 391   my $tb = Test::Builder->new;
 392   local $Test::Builder::Level = $Test::Builder::Level + 1;
 393
 394   my $obj = $class->new;
 395   my $actions = $obj->actions;
 396   my @bad;
 397   for my $action (sort keys %$actions) {
 398     my $method = "req_$action";
 399     unless ($obj->can($method)) {
 400       push @bad, $action;
 401     }
 402   }
 403   $tb->ok(!@bad, "check all actions have a method for $class");
 404   print STDERR "No method found for $class action $_\n" for @bad;
 405
 406   return !@bad;
 407 }
 408
 409 1;
 410