0.11_09 commit
[bse.git] / t / BSE / Test.pm
index 245f4f8..4ea4b0b 100644 (file)
@@ -4,7 +4,8 @@ use vars qw(@ISA @EXPORT @EXPORT_OK);
 @ISA = qw(Exporter);
 require 'Exporter.pm';
 @EXPORT = qw(base_url ok fetch_ok make_url skip make_ua);
-@EXPORT_OK = qw(base_url ok make_ua fetch_url fetch_ok make_url skip);
+@EXPORT_OK = qw(base_url ok make_ua fetch_url fetch_ok make_url skip 
+                make_post check_form post_ok);
 
 my %conf;
 
@@ -19,6 +20,20 @@ close TESTCFG;
 
 sub base_url { $conf{base_url} or die "No base_url in test config" }
 
+sub base_dir { $conf{base_dir} or die "No base_dir in test config" }
+
+sub mysql_name { $conf{mysql} or die "No mysql in test config" }
+
+sub test_dsn { $conf{dsn} or die "No dsn in test config" }
+
+sub test_dbuser { $conf{dbuser} or die "No dbuser in test config" }
+
+sub test_dbpass { $conf{dbpass} or die "No dbpass in test config" }
+
+sub test_dbclass { $conf{dbclass} or die "No dbclass in test config" }
+
+sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }
+
 my $test_num = 1;
 
 sub ok ($$) {
@@ -28,7 +43,7 @@ sub ok ($$) {
     print "ok $test_num # $desc\n";
   }
   else {
-    print "not ok $test_num # desc ",join(",", caller()),"\n";
+    print "not ok $test_num # $desc ",join(",", caller()),"\n";
   }
   ++$test_num;
   return $ok;
@@ -60,10 +75,10 @@ sub fetch_url {
   my ($ua, $url, $method, $post) = @_;
 
   $method ||= 'GET';
-  my $req = HTTP::Request->new($method, $url);
-  if ($post) {
-    $req->content($post);
-  }
+  my $hdrs = HTTP::Headers->new;
+  $hdrs->header(Content_Length => length $post) if $post;
+  my $req = HTTP::Request->new($method, $url, $hdrs);
+  $req->content($post) if $post;
   my $resp = $ua->request($req);
   if (wantarray) {
     return ($resp->content(), $resp->code(), $resp->is_success, 
@@ -85,11 +100,11 @@ sub make_url {
   return $base."?".join("&",@pairs);
 }
 
-sub fetch_ok {
-  my ($ua, $note, $url, $match, $headmatch) = @_;
-
-  my ($content, $code, $ok, $headers) = fetch_url($ua, $url);
+sub _check_fetch {
+  my ($content, $code, $ok, $headers,
+      $note, $match, $headmatch) = @_;  
 
+  my $good = $ok;
   ok($ok, "$note: fetch ($code)");
   if ($ok) {
     if ($match) {
@@ -99,6 +114,7 @@ sub fetch_ok {
        $copy =~ s/^/# /gm;
        $copy .= "\n" unless $copy =~ /\n\z/;
        print $copy;
+       $good = 0;
       }
     }
     if ($headmatch) {
@@ -108,6 +124,7 @@ sub fetch_ok {
        $copy =~ s/^/# /gm;
        $copy .= "\n" unless $copy =~ /\n\z/;
        print $copy;
+       $good = 0;
       }
     }
   }
@@ -117,6 +134,177 @@ sub fetch_ok {
     $count++ if $headmatch;
     skip("$note: fetch failed", $count) if $count;
   }
+
+  if (wantarray) {
+    return ($content, $code, $good, $headers);
+  }
+  else {
+    return $good ? $content : undef;
+  }
+}
+
+sub make_post {
+  my (@data) = @_;
+
+  require "URI/Escape.pm";
+  my @pairs;
+  while (my ($key, $value) = splice(@data, 0, 2)) {
+    push(@pairs, "$key=".URI::Escape::uri_escape($value));
+  }
+  return join("&",@pairs);
+}
+
+sub post_ok {
+  my ($ua, $note, $url, $data, $match, $headmatch) = @_;
+
+  $data = make_post(@$data) if ref $data;
+
+  my ($content, $code, $ok, $headers) = fetch_url($ua, $url, POST=>$data);
+
+  return _check_fetch($content, $code, $ok, $headers,
+                     $note, $match, $headmatch)
+}
+
+sub fetch_ok {
+  my ($ua, $note, $url, $match, $headmatch) = @_;
+
+  my ($content, $code, $ok, $headers) = fetch_url($ua, $url);
+  return _check_fetch($content, $code, $ok, $headers,
+                     $note, $match, $headmatch)
+}
+
+sub check_form {
+  my ($content, $note, %checks) = @_;
+
+  require 'HTML/Parser.pm';
+  require 'HTML/Entities.pm';
+  my $in;
+  my $keep;
+  my $saved = '';
+  my %todo = %checks;
+  my $inselect;
+  my $selname;
+  my $checked_sel_value;
+  my $textname;
+  my %values;
+
+  my $text =
+    sub {
+      my ($t) = @_;
+      $saved .= $t if $keep;
+    };
+  my $start = 
+    sub {
+      my ($tagname, $attr) = @_;
+
+      if ($tagname eq 'input') {
+       my $name = $attr->{name};
+       if ($name && $todo{$name}) {
+         ok(1, "$note - $name - field is present");
+         $values{$name} = $attr->{$name};
+         if (defined $todo{$name}[0]) {
+           my $cvalue = $checks{$name}[0];
+           my $fvalue = $attr->{value};
+           if (defined $fvalue) {
+             ok($cvalue eq $fvalue, "$note - $name - comparing values");
+           }
+           else {
+             ok(0, "$note - $name - value is not present");
+           }
+         }
+         if (defined $todo{$name}[1]) {
+           my $ttype = $todo{$name}[1];
+           my $ftype = $attr->{type};
+           if (defined $ftype) {
+             ok($ttype eq $ftype, "$note - $name - comparing types");
+           }
+           else {
+             ok(0, "$note - $name - type not present");
+           }
+         }
+         delete $todo{$name};
+       }
+      }
+      elsif ($tagname eq 'select') {
+       $selname = $attr->{name};
+       
+       if ($todo{$selname}) {
+         ok(1, "$note - $selname - field is present");
+         $inselect = 1;
+         if (defined $todo{$selname}[1]) {
+           $checked_sel_value = 0;
+           my $ttype = $todo{$selname}[1];
+           ok ($ttype eq 'select', "$note - $selname - checking type (select)");
+         }
+       }
+      }
+      elsif ($tagname eq 'option' && $inselect) {
+       unless (exists $attr->{value}) {
+         print "# warning - option in select $selname missing value\n";
+       }
+       if (exists $attr->{selected}) {
+         $checked_sel_value = 1;
+         $values{$selname} = $attr->{value};
+         if (defined $todo{$selname}[0]) {
+           my $fvalue = $attr->{value};
+           my $tvalue = $todo{$selname}[0];
+           if (defined $fvalue) {
+             ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
+           }
+           else {
+             ok(0, "$note - $selname - no value supplied");
+           }
+         }
+       }
+      }
+      elsif ($tagname eq 'textarea') {
+       $textname = $attr->{name};
+       $saved = '';
+       ++$keep;
+      }
+    };
+  my $end =
+    sub {
+      my ($tagname) = @_;
+
+      if ($tagname eq 'select' && $inselect) {
+       if (!$checked_sel_value) {
+         ok(0, "$note - $selname - no value selected");
+       }
+       delete $todo{$selname};
+      }
+      elsif ($tagname eq 'textarea') {
+       $keep = 0;
+       if ($todo{$textname}) {
+         my $fvalue = HTML::Entities::decode_entities($saved);
+         $values{$textname} = $fvalue;
+         ok(1, "$note - $textname - field exists");
+         if (defined $todo{$textname}[0]) {
+           my $tvalue = $todo{$textname}[0];
+           ok($tvalue eq $fvalue, "$note - $textname - checking value");
+         }
+         if (defined $todo{$textname}[1]) {
+           ok ($todo{$textname}[1] eq 'textarea',
+               "$note - $textname - check field type");
+         }
+         delete $todo{$textname};
+       }
+      }
+    };
+  my $p = HTML::Parser->new( text_h => [ $text, "dtext" ],
+                            start_h => [ $start, "tagname, attr" ],
+                            end_h => [ $end, "tagname" ]);
+  $p->parse($content);
+  $p->eof;
+  for my $name (keys %todo) {
+    ok(0, "$note - $name - field doesn't exist");
+    my $count = 0;
+    ++$count if defined $todo{$name}[0];
+    ++$count if defined $todo{$name}[1];
+    skip("$note - $name - no field", $count);
+  }
+
+  return %values;
 }
 
 1;