0.11_09 commit r0_11_09
authorTony Cook <tony@develop-help.com>
Fri, 15 Feb 2002 05:55:53 +0000 (05:55 +0000)
committertony <tony@45cb6cf1-00bc-42d2-bb5a-07f51df49f94>
Fri, 15 Feb 2002 05:55:53 +0000 (05:55 +0000)
MANIFEST
Makefile
localinst.perl
site/cgi-bin/modules/BSE/Cfg.pm
site/docs/TODO.pod
site/docs/bse.pod
t/BSE/Test.pm
t/t00smoke.t
t/t10edit.t [new file with mode: 0644]
test.cfg.base

index 1fa0d89..f946072 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -223,3 +223,7 @@ site/util/gen.pl
 site/util/initial.pl
 site/util/mysql.str
 site/util/upgrade_mysql.pl
+t/BSE/Test.pm
+t/t00smoke.t
+t/t10edit.t
+test.cfg.base
index 15eaf54..e740d7b 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-VERSION=0.11_08
+VERSION=0.11_09
 DISTNAME=bse-$(VERSION)
 DISTBUILD=$(DISTNAME)
 DISTTAR=../$(DISTNAME).tar
index 0c3aab5..e5c97b4 100644 (file)
@@ -2,23 +2,19 @@
 use strict;
 #use File::Tree;
 use File::Copy;
+use lib 't';
+use BSE::Test ();
 
 my $dist = shift or die "Usage: $0 distdir [leavedb]";
 my $leavedb = shift or 0;
-my $instbase = shift || "/home/httpd/bsetest";
+my $instbase = shift || BSE::Test::base_dir() || die "No base_dir";
 
-my $mysql = "/usr/local/mysql/bin/mysql";
+my $mysql = BSE::Test::mysql_name;
 
-if (-e "$instbase/cgi-bin/modules/Constants.pm"
-    && !-e "$instbase/Constants.pm") {
-  system "cp $instbase/cgi-bin/modules/Constants.pm $instbase/Constants.pm"
-}
-my $gotconf;
-eval {
-  require $instbase."/Constants.pm";
-  $Constants::BASEDIR . $Constants::URLBASE . $Constants::SECURLBASE;
-  ++$gotconf;
-};
+#  if (-e "$instbase/cgi-bin/modules/Constants.pm"
+#      && !-e "$instbase/Constants.pm") {
+#    system "cp $instbase/cgi-bin/modules/Constants.pm $instbase/Constants.pm"
+#  }
 
 system("rm -rf $instbase/cgi-bin")
   and die "Cannot remove cgi-bin";
@@ -29,7 +25,6 @@ system "rm -f $instbase/htdocs/{*.html,a/*.html,shop/*.html,images/*.jpg}"
 
 system "cp -rf $dist/site/cgi-bin $instbase"
   and die "Cannot copy cgi-bin";
-unlink "$instbase/cgi-bin/bse.cfg";
 
 system "cp -rf $dist/site/htdocs $instbase"
   and die "Cannot copy htdocs";
@@ -39,44 +34,60 @@ system "cp -rf $dist/site/data $instbase"
   and die "Cannot copy data";
 system "cp -rf $dist/site/util $instbase";
 
-if ($gotconf) {
-  print "Updating conf\n";
-  # try to update Constants.pm
-  open CON, "< $instbase/cgi-bin/modules/Constants.pm"
-    or die "Cannot open Constants.pm";
-  my $con = do { local $/; <CON> };
-  close CON;
+print "Updating conf\n";
+# try to update Constants.pm
+open CON, "< $instbase/cgi-bin/modules/Constants.pm"
+  or die "Cannot open Constants.pm";
+my $con = do { local $/; <CON> };
+close CON;
 
-  if (defined $Constants::DB && !defined $Constants::DSN) {
-    $Constants::DSN = 'dbi:mysql:'.$Constants::DB;
-    $Constants::DBCLASS = "BSE::DB::Mysql";
-    $Constants::SESSION_CLASS = "Apache::Session::MySQL";
-  }
-  $con =~ s/(^\$DSN = ')[^']*/$1$Constants::DSN/m;
-  $con =~ s/(^\$DBCLASS = ')[^']*/$1$Constants::DBCLASS/m;
-  $con =~ s/(^\$UN = ')[^']*/$1$Constants::UN/m;
-  $con =~ s/(^\$PW = ')[^']*/$1$Constants::PW/m;
-  $con =~ s/(^\$BASEDIR = ')[^']+/$1$Constants::BASEDIR/m;
-  $con =~ s/(^\$URLBASE = ["'])[^'"]+/$1$Constants::URLBASE/m;
-  $con =~ s/(^\$SECURLBASE = ["'])[^'"]+/$1$Constants::SECURLBASE/m;
-  $con =~ s/(^\$SESSION_CLASS = ["'])[^'"]+/$1$Constants::SESSION_CLASS/m;
-  open CON, "> $instbase/cgi-bin/modules/Constants.pm"
-    or die "Cannot open Constants.pm for write: $!";
-  print CON $con;
-  close CON;
+my $dbuser = BSE::Test::test_dbuser();
+my $dbpass = BSE::Test::test_dbpass();
+
+$con =~ s/(^\$DSN = ')[^']*/$1 . BSE::Test::test_dsn()/me;
+$con =~ s/(^\$DBCLASS = ')[^']*/$1 . BSE::Test::test_dbclass()/me;
+$con =~ s/(^\$UN = ')[^']*/$1$dbuser/m;
+$con =~ s/(^\$PW = ')[^']*/$1$dbpass/m;
+$con =~ s/(^\$BASEDIR = ')[^']+/$1 . BSE::Test::base_dir/me;
+#$con =~ s/(^\$URLBASE = ["'])[^'"]+/$1 . BSE::Test::base_url/me;
+#$con =~ s/(^\$SECURLBASE = ["'])[^'"]+/$1 . BSE::Test::test_securl/me;
+$con =~ s/(^\$SESSION_CLASS = ["'])[^'"]+/$1 . BSE::Test::test_sessionclass()/me;
+open CON, "> $instbase/cgi-bin/modules/Constants.pm"
+  or die "Cannot open Constants.pm for write: $!";
+print CON $con;
+close CON;
 
-  # build the database
-  unless ($leavedb) {
-    if ($Constants::DSN =~ /:mysql:(?:database=)?(\w+)/) {
-      my $db = $1;
-      system "$mysql -u$Constants::UN -p$Constants::PW $db <$dist/schema/bse.sql"
-       and die "Cannot initialize database";
-      system "cd $instbase/util ; perl initial.pl"
-       and die "Cannot load database";
-    }
-    else {
-      print "WARNING: cannot install to $Constants::DSN database\n";
-    }
+# fix bse.cfg
+open CFG, "< $instbase/cgi-bin/bse.cfg"
+  or die "Cannot open $instbase/cgi-bin/bse.cfg: $!";
+my $cfg = do { local $/; <CFG> };
+close CFG;
+$cfg =~ s/^name\s*=.*/name=Test Server/m;
+$cfg =~ s/^url\s*=.*/"url=" . BSE::Test::base_url()/me;
+$cfg =~ s/^secureurl\s*=.*/"secureurl=" . BSE::Test::base_url()/me;
+my $uploads = "$instbase/uploads";
+$cfg =~ s!^downloads\s*=.*!downloads=$uploads!m;
+-d $uploads 
+  or mkdir $uploads, 0777 
+  or die "Cannot find or create upload directory: $!";
+open CFG, "> $instbase/cgi-bin/bse.cfg"
+  or die "Cannot create $instbase/cgi-bin/bse.cfg: $!";
+print CFG $cfg;
+close CFG;
+
+# build the database
+unless ($leavedb) {
+  my $dsn = BSE::Test::test_dsn();
+  if ($dsn =~ /:mysql:(?:database=)?(\w+)/) {
+    my $db = $1;
+    system "$mysql -u$dbuser -p$dbpass $db <$dist/schema/bse.sql"
+      and die "Cannot initialize database";
+    system "cd $instbase/util ; perl initial.pl"
+      and die "Cannot load database";
+  }
+  else {
+    print "WARNING: cannot install to $dsn database\n";
   }
 }
+
   
index ec7b184..6ca1c95 100644 (file)
@@ -44,7 +44,7 @@ sub new {
 
   #my $file = _find_cfg(MAIN_CFG)
   #  or _load_error("Cannot find config file ".MAIN_CFG);
-  my $file = _find_cfg(MAIN_CFG)
+  my $file = _find_cfg(MAIN_CFG) || _find_cfg(MAIN_CFG, ".")
     or return bless { config => {} }, $class;
 
   return $class->_load_cfg($file);
index a5dd1e1..f63bb70 100644 (file)
@@ -132,6 +132,10 @@ change makeIndex.pl to avoid overflowing the fields
 
 add a test suite
 
+=item *
+
+level parameter to add.pl isn't checked for validity
+
 =back
 
 =cut
index 54b85f4..c8c2fc8 100644 (file)
@@ -27,6 +27,16 @@ mail class
 
 work around a bug in the search index builder
 
+=item *
+
+finally added some test code.  This isn't ready for general use yet and
+could damage your system.  So don't use it.
+
+=item *
+
+BSE::Cfg now checks the current directory as well as $FindBin::Bin,
+this lets initial.pl work
+
 =back
 
 =head2 0.11_08
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;
index 0277d55..547c0fd 100644 (file)
@@ -7,7 +7,7 @@ print "1..27\n";
 my $baseurl = base_url;
 ok($baseurl =~ /^http:/, "basic check of base url");
 my $ua = make_ua;
-fetch_ok($ua, "admin menu", "$baseurl/admin/", "Admin");
+fetch_ok($ua, "admin menu - check the site exists at all", "$baseurl/admin/", "Admin");
 fetch_ok($ua, "generate all", "$baseurl/cgi-bin/admin/generate.pl",
        "html", "Refresh: 0; .*/admin/");
 fetch_ok($ua, "generate all verbose", 
diff --git a/t/t10edit.t b/t/t10edit.t
new file mode 100644 (file)
index 0000000..1915ca9
--- /dev/null
@@ -0,0 +1,67 @@
+#!perl -w
+use strict;
+use BSE::Test qw(base_url make_ua fetch_ok skip check_form post_ok ok);
+
+++$|;
+print "1..25\n";
+my $baseurl = base_url;
+my $ua = make_ua;
+my $headers;
+my $content = 
+  fetch_ok($ua, "edit page", 
+          "$baseurl/cgi-bin/admin/add.pl?level=1&parentid=-1",
+          qr!No\s+parent\s+-\s+this\s+is\s+a\s+section
+          .*
+          common/default.tmpl
+          .*
+          Add\s+New\s+Section
+          !xs);
+if ($content) {
+  check_form($content,
+            "edit form",
+            parentid=>[ -1, 'select' ],
+            id => [ '', 'hidden' ],
+            titleImage => [ '', 'select' ],
+            template=> [ 'common/default.tmpl', 'select' ],
+            body => [ '<maximum of 64Kb>', 'textarea' ],
+            listed => [ 1, 'select' ],
+            );
+}
+else {
+  skip("no content to check", 18);
+}
+
+my ($code, $good);
+($content, $code, $good, $headers) = 
+  post_ok($ua, "adding article", "$baseurl/cgi-bin/admin/add.pl",
+         [
+          parentid=>-1,
+          level => 1,
+          title=>"Test Article",
+          titleImage=>'',
+          template=>'common/default.tmpl',
+          body=>'This is a test body',
+          release=>'',
+          expire=>'',
+          summaryLength => '',
+          displayThreshold=>'',
+          keywords=>'',
+          listed=>1,
+          save=>1,
+         ], undef, qr!Refresh:\s+0!);
+if ($good) {
+  $headers =~ /Refresh:\s+\d+\s*;\s+url=(\"?)([^\"\'\n\r;]+)(\1)/
+    or die "Someone lied";
+  my $url = $2;
+  print "# $url\n";
+  ok($url =~ m!/cgi-bin/admin/admin\.pl\?!, "check admin mode url");
+  fetch_ok($ua, "admin mode", $url,
+          qr!
+          <title>Test\ Server\ -\ Test\ Article</title>
+          .*
+          This\ is\ a\ test\ body
+          !xsm);
+}
+else {
+  skip(3);
+}
index 0090bb2..3ef7739 100644 (file)
@@ -1 +1,12 @@
-base_url = http://bsetest.develop-help.com
+# the url of your test sie
+base_url = http://blah.blah.blah
+# where to install the site
+base_dir = /foo/bar/quux
+# the database user/password/dsn
+dbuser = someuser
+dbpass = somepass
+dsn = dbi:blah:blah
+dbclass = BSE::DB::Something
+sessionclass = Apache::Session::MySQL
+# the location of mysql
+mysql = mysql