re-work installation to use a bse.cfg style file
authorTony Cook <tony@develop-help.com>
Sun, 7 Apr 2013 23:57:09 +0000 (09:57 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 8 Apr 2013 00:56:37 +0000 (10:56 +1000)
14 files changed:
.gitignore
MANIFEST
MANIFEST.SKIP
Makefile
install.cfg-dist [new file with mode: 0644]
lib/BSE/Install.pm [new file with mode: 0644]
localinst.perl
site/cgi-bin/bse.cfg
site/cgi-bin/modules/BSE/Session.pm
t/070-user/010-edit.t
t/110-courier/020-auspost.t
t/900-kwalitee/010-strict-warn.t
t/BSE/Test.pm
t/t00smoke.t

index 09c1287..b5239e5 100644 (file)
@@ -1,10 +1,12 @@
-MANIFEST.bak
-test.cfg
-INSTALL.html
-INSTALL.txt
-site/cgi-bin/modules/BSE/Modules.pm
-site/cgi-bin/modules/BSE/Version.pm
+/MANIFEST.bak
+/test.cfg
+/install.cfg
+/INSTALL.html
+/INSTALL.txt
+/site/cgi-bin/modules/BSE/Modules.pm
+/site/cgi-bin/modules/BSE/Version.pm
 .#*
 *~
 
 /cover_db
+/bse-[0-9]*
\ No newline at end of file
index e839289..28f7357 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,9 +1,11 @@
 Artistic
 Changes.txt
 COPYING
+install.cfg
 INSTALL.html
 INSTALL.pod
 INSTALL.txt
+lib/BSE/Install.pm
 localinst.perl                 # simple test installer
 Makefile
 makehtmldocs.pl
index 29e4ea9..574120c 100644 (file)
@@ -8,6 +8,7 @@
 ^\.git/
 ^test\.cfg$
 ^test-.*cfg$
+^install\.cfg$
 ^nswfitc\.cfg$
 ^site/htdocs/images/admin/help\.png$
 ^install.perl$
index 7bc94c0..0ddfd50 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -19,6 +19,9 @@ VERSIONDEPS=$(shell $(PERL) site/util/bse_versiondeps.pl MANIFEST)
 POD2TEXT=$(PERLBIN)/pod2text
 POD2HTML=$(PERLBIN)/pod2html
 
+UTILDIR=$(shell $(PERL) -Ilib -MBSE::Install=util_dir -e 'print util_dir')
+DATADIR=$(shell $(PERL) -Ilib -MBSE::Install=data_dir -e 'print data_dir')
+
 .PHONY: help dist cleantree archive distdir clean docs otherdocs dbinfo
 .PHONY: version modversion testinst test testup checkver regen_known_errors
 .PHONY: manicheck filecheck manifect htmldocs
@@ -106,12 +109,12 @@ $(BSEMODULES): $(MODULES) site/util/make_versions.pl
 testinst: distdir
        $(PERL) localinst.perl $(DISTBUILD)
        $(PERL) -MExtUtils::Command -e rm_rf $(DISTBUILD)
-       cd `$(PERL) -lne 'do { print $$1; exit; } if /^base_dir\s*=\s*(.*)/' test.cfg`/util ; $(PERL) loaddata.pl ../data/db
+       cd $(UTILDIR) ; $(PERL) loaddata.pl $(DATADIR)/db
 
 testup: checkver distdir
        $(PERL) localinst.perl $(DISTBUILD) leavedb
        $(PERL) -MExtUtils::Command -e rm_rf $(DISTBUILD)
-       cd `$(PERL) -lne 'do { print $$1; exit; } if /^base_dir\s*=\s*(.*)/' test.cfg`/util ; $(PERL) upgrade_mysql.pl -b ; $(PERL) loaddata.pl ../data/db
+       cd $(UTILDIR) ; $(PERL) upgrade_mysql.pl -b ; $(PERL) loaddata.pl $(DATADIR)/db
 
 checkver:
        if [ -d .git ] ; then perl site/util/check_versions.pl ; fi
diff --git a/install.cfg-dist b/install.cfg-dist
new file mode 100644 (file)
index 0000000..a66db9b
--- /dev/null
@@ -0,0 +1,32 @@
+[paths]
+siteroot=FIXME
+
+[site]
+secureadmin=1
+url=FIXME
+secret=FIXME
+secureurl=FIXME
+
+[db]
+dsn=dbi:mysql:FIXME
+user=FIXME
+password=FIXME
+class=BSE::DB::Mysql
+
+[basic]
+access_control=0
+ajax=1
+utf8=1
+
+[html]
+charset=utf-8
+
+[editor]
+thumbs_class=BSE::Thumb::Imager
+allow_thumb=1
+check_modified=1
+
+
+[shop]
+to_email=FIXME
+from=FIXME
diff --git a/lib/BSE/Install.pm b/lib/BSE/Install.pm
new file mode 100644 (file)
index 0000000..b6ae3e6
--- /dev/null
@@ -0,0 +1,66 @@
+package BSE::Install;
+use strict;
+use Exporter 'import';
+our @EXPORT_OK = qw(cfg util_dir cgi_dir public_html_dir templates_dir data_dir mysql_name perl);
+use lib 'site/cgi-bin/modules';
+use BSE::Cfg;
+
+our $VERSION = "1.000";
+
+my $conffile = $ENV{BSECONFIG} || 'install.cfg';
+
+my $cfg = BSE::Cfg->new
+  (
+   path => "site/cgi-bin",
+   extra_file => $conffile,
+  );
+
+sub cfg {
+  $cfg;
+}
+
+sub conffile {
+  $conffile;
+}
+
+sub util_dir {
+  $cfg->entryVar("paths", "util");
+}
+
+sub cgi_dir {
+  $cfg->entryVar("paths", "cgi-bin");
+}
+
+sub public_html_dir {
+  $cfg->entryVar("paths", "public_html");
+}
+
+sub templates_dir {
+  $cfg->entryVar("paths", "templates");
+}
+
+sub data_dir {
+  $cfg->entryVar("paths", "data");
+}
+
+sub mysql_name {
+  $cfg->entry("binaries", "mysql", "mysql");
+}
+
+sub perl {
+  $cfg->entry("paths", "perl", $^X);
+}
+
+sub db_dsn {
+  $cfg->entryErr("db", "dsn");
+}
+
+sub db_user {
+  $cfg->entryErr("db", "user");
+}
+
+sub db_password {
+  $cfg->entryErr("db", "password");
+}
+
+1;
index abb88a7..6aec09c 100644 (file)
@@ -2,40 +2,43 @@
 use strict;
 #use File::Tree;
 use File::Copy;
-use lib 't';
-use BSE::Test ();
-require ExtUtils::Manifest;
+use lib 'lib';
+use BSE::Install qw(util_dir cgi_dir public_html_dir templates_dir data_dir mysql_name);
+#use BSE::Test ();
+use ExtUtils::Manifest qw(maniread);
+use File::Copy qw(copy);
+use File::Spec;
+use File::Path qw(make_path);
+use Getopt::Long;
+
+my $verbose;
+GetOptions("v|verbose" => \$verbose);
 
 my $dist = shift or die "Usage: $0 distdir [leavedb]";
 my $leavedb = shift or 0;
-my $instbase = shift || BSE::Test::base_dir() || die "No base_dir";
 
-my $mysql = BSE::Test::mysql_name;
+my $mysql = 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 $cfg = BSE::Install::cfg();
 
-#system("rm -rf $instbase/cgi-bin")
-#  and die "Cannot remove cgi-bin";
-#system "rm -rf $instbase/data"
-#  and die "Cannot remove data";
-#system "rm -f $instbase/htdocs/{*.html,a/*.html,shop/*.html,images/*.jpg}"
-#  and die "Cannot remove htdocs";
+my $manifest = maniread();
 
--d "$instbase/cgi-bin" or mkdir "$instbase/cgi-bin"
-  or die "Cannot create $instbase/cgi-bin: $!";
-system "cp -rf $dist/site/cgi-bin/* $instbase/cgi-bin"
-  and die "Cannot copy cgi-bin";
+install_files("site/htdocs/", public_html_dir());
+install_files("site/templates/", templates_dir());
+install_files("site/cgi-bin", cgi_dir());
+install_files("site/util/", util_dir());
+install_files("site/data/", data_dir());
 
-my $perl = BSE::Test::test_perl();
+my $perl = BSE::Install::perl();
 if ($perl ne '/usr/bin/perl') {
   my $manifest = ExtUtils::Manifest::maniread();
 
   for my $file (keys %$manifest) {
-    (my $work = $file) =~ s!^site!!;
-    my $full = $instbase . $work;
+    (my $work = $file) =~ s!^site/!!;
+    $work =~ s(^(cgi-bin|util)/)()
+      or next;
+    my $base = $work eq "util" ? util_dir() : cgi_dir();
+    my $full = File::Spec->catfile($base, $work);
     open my $script, "<", $full
       or next;
     binmode $script;
@@ -51,95 +54,29 @@ if ($perl ne '/usr/bin/perl') {
   }
 }
 
-system "cp -rf $dist/site/htdocs/* $instbase/htdocs"
-  and die "Cannot copy htdocs";
-system "cp -rf $dist/site/templates/* $instbase/templates"
-  and die "Cannot copy templates";
-system "cp -rf $dist/site/data $instbase"
-  and die "Cannot copy data";
-system "cp -rf $dist/site/util/ $instbase";
-
 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;
-
-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;
-
-
-# rebuild the config file
-# first load values from the test.cfg file
-my $conffile = BSE::Test::test_conffile();
-my %conf;
-$conf{site}{url} = BSE::Test::base_url();
-$conf{site}{secureurl} = BSE::Test::base_securl();
-$conf{paths}{siteroot} = $instbase;
-#my $uploads = "$instbase/uploads";
-#$conf{paths}{downloads} = $uploads;
-#my $templates = "$instbase/templates";
-#$conf{paths}{templates} = $templates;
-#$conf{paths}{public_html} = "$instbase/htdocs";
-open TESTCONF, "< $conffile"
-  or die "Could not open config file $conffile: $!";
-while (<TESTCONF>) {
-  chomp;
-  /^\s*(\w[^=]*\w)\.([\w-]+)\s*=\s*(.*)\s*$/ or next;
-  $conf{lc $1}{$2} = $3;
-}
-
-#$uploads = $conf{paths}{downloads};
-# create installation config
 
-$conf{db}{class} = BSE::Test::test_dbclass();
-$conf{db}{dsn} = BSE::Test::test_dsn();
-$conf{db}{user} = $dbuser;
-$conf{db}{password} = $dbpass;
-
-open CFG, "> $instbase/cgi-bin/bse-install.cfg"
-  or die "Cannot create $instbase/cgi-bin/bse-install.cfg: $!";
-
-print CFG "; DO NOT EDIT - created during installation\n";
-for my $section_name (keys %conf) {
-  print CFG "[$section_name]\n";
-  my $section = $conf{$section_name};
-  for my $key (keys %$section) {
-    print CFG "$key=$section->{$key}\n";
-  }
-  print CFG "\n";
-}
-
-close CFG;
+my $conf_src = BSE::Install::conffile();
+my $conf_dest = File::Spec->catfile(cgi_dir(), "bse-install.cfg");
+copy($conf_src, $conf_dest)
+  or die "Cannot copy $conf_src to $conf_dest: $!\n";
 
 #-d $uploads 
 #  or mkdir $uploads, 0777 
 #  or die "Cannot find or create upload directory: $!";
 
+my $dbuser = BSE::Install::db_user();
+my $dbpass = BSE::Install::db_password();
 
 # build the database
-my $dsn = BSE::Test::test_dsn();
+my $dsn = BSE::Install::db_dsn();
 if ($dsn =~ /:mysql:(?:database=)?(\w+)/) {
   my $db = $1;
 
   unless ($leavedb) {
     system "$mysql -u$dbuser -p$dbpass $db <$dist/schema/bse.sql"
       and die "Cannot initialize database";
-    system "cd $instbase/util ; $perl initial.pl"
+    system "cd ".util_dir." ; $perl initial.pl"
       and die "Cannot load database";
   }
 
@@ -151,4 +88,24 @@ else {
   print "WARNING: cannot install to $dsn database\n";
 }
 
-  
+sub install_files {
+  my ($prefix, $destbase) = @_;
+
+  print "Install $prefix to $destbase\n";
+  for my $file (sort grep /^\Q$prefix/, keys %$manifest) {
+    (my $rel = $file) =~ s/^\Q$prefix//;
+    my $src = File::Spec->catfile($dist, $file);
+    my $dest = File::Spec->catfile($destbase, $rel);
+    my ($destvol, $destdir) = File::Spec->splitpath($dest);
+    my $destpath = File::Spec->catdir($destvol, $destdir);
+    unless (-e $destpath) {
+      make_path($destpath); # croak on error
+    }
+    elsif (!-d $destpath) {
+      die "$destpath isn't a directory!\n";
+    }
+    print "  Copy $rel to $dest\n" if $verbose;
+    copy($src, $dest)
+      or die "Cannot copy $src to $dest: $!\n";
+  }
+}
index 52e4746..2d08d92 100644 (file)
@@ -22,6 +22,8 @@ public_files=$(public_html)/managed_assets
 images=$(public_html)/managed_assets
 data=$(siteroot)/data
 templates=$(siteroot)/templates
+cgi-bin=$(siteroot)/cgi-bin
+util=$(siteroot)/util
 
 [uri]
 images=/managed_assets
index e664207..1387bed 100644 (file)
@@ -4,7 +4,7 @@ use CGI::Cookie;
 use BSE::DB;
 use BSE::CfgInfo qw/custom_class/;
 
-our $VERSION = "1.001";
+our $VERSION = "1.002";
 
 sub _session_require {
   my ($cfg) = @_;
@@ -18,11 +18,7 @@ sub _session_require {
 sub _session_class {
   my ($cfg) = @_;
 
-  eval { require Constants; };
-
-  my $default = $Constants::SESSION_CLASS || 'Apache::Session::MySQL';
-
-  return $cfg->entry('basic', 'session_class', $default);
+  return $cfg->entry('basic', 'session_class', "Apache::Session::MySQL");
 }
 
 sub _send_session_cookie {
index be20480..0853b2d 100644 (file)
@@ -1,11 +1,11 @@
 #!perl -w
 use strict;
-use BSE::Test qw(base_url make_ua skip check_form post_ok ok 
+use Test::More tests => 22;
+use BSE::Test qw(base_url make_ua check_form post_ok
                  check_content follow_ok);
 use URI::QueryParam;
 #use WWW::Mechanize;
 ++$|;
-print "1..22\n";
 my $baseurl = base_url;
 my $ua = make_ua;
 
index 84a3177..b26fcf1 100644 (file)
@@ -146,7 +146,7 @@ my $us_medium_cost_sea = $sea->calculate_shipping
 ok($us_medium_cost_sea, "got a US medium cost");
 like($us_medium_cost_sea, qr/^\d+$/, "it's an integer");
 print "# $us_medium_cost_sea\n";
-cmp_ok($perth_medium_cost, "<=", $us_medium_cost_sea, "perth <= us sea");
+cmp_ok($perth_medium_cost, "<=", $us_medium_cost_air, "perth <= us air");
 
 # too big
 my $too_long = BSE::Shipping::Parcel->new
index 5a56be0..8336945 100644 (file)
@@ -1,7 +1,7 @@
 #!perl -w
 use strict;
-use BSE::Test qw(ok);
 use File::Find;
+use Test::More;
 
 my @files;
 open MANIFEST, "< MANIFEST" or die "Cannot open MANIFEST";
@@ -13,7 +13,7 @@ while (<MANIFEST>) {
 }
 close MANIFEST;
 my @scripts = grep /\.(pl|t)$/, @files;
-print "1..",scalar(@files) + scalar(@scripts),"\n";
+plan tests => scalar(@files) + scalar(@scripts);
 for my $file (@files) {
   open SRC, "< $file" or die "Cannot open $file: $!";
   my $data = do { local $/; <SRC> };
index 0d916c3..ecaefe0 100644 (file)
@@ -1,93 +1,68 @@
 package BSE::Test;
 use strict;
 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 
+use Exporter 'import';
+@EXPORT = qw(base_url fetch_ok make_url skip make_ua);
+@EXPORT_OK = qw(base_url make_ua fetch_url fetch_ok make_url skip 
                 make_post check_form post_ok check_content follow_ok
                 follow_refresh_ok click_ok config test_actions);
+use lib 'site/cgi-bin/modules';
+use BSE::Cfg;
 
-my %conf;
+my $conffile = $ENV{BSETEST} || 'install.cfg';
 
-my $conffile = $ENV{BSETEST} || 'test.cfg';
+my $cfg = BSE::Cfg->new
+  (
+   path => "site/cgi-bin",
+   extra_file => $conffile,
+  );
 
-open TESTCFG, "< $conffile" or die "Cannot open $conffile: $!";
-while (<TESTCFG>) {
-  next if /^\s*[\#;]/;
-  chomp;
-  next unless /^\s*(\w+)\s*=\s*(.*)/ 
-    or  /^\s*(\w[^=]*\w\.\w+)\s*=\s*(.*\S)\s*$/;
-  $conf{$1} = $2;
+sub config {
+  $cfg;
 }
-close TESTCFG;
-
-sub base_url { $conf{base_url} or die "No base_url in test config" }
 
-sub base_securl { 
-  $conf{securl} or $conf{base_url} or die "No securl or base_url in $conffile"
+sub base_url {
+  $cfg->entryVar("site", "url");
 }
 
-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 base_securl {
+  $cfg->entryVar("site", "secureurl");
+}
 
-sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }
-sub test_perl { $conf{perl} or "/usr/bin/perl" }
+sub base_dir {
+  $cfg->entryVar("paths", "siteroot");
+}
 
-sub test_conffile {
-  return $conffile;
+sub mysql_name {
+  $cfg->entry("binaries", "mysql", "mysql");
 }
 
-sub config {
-  my ($name) = @_;
+sub test_dsn {
+  $cfg->entry("db", "dsn");
+}
 
-  $conf{$name};
+sub test_dbuser {
+  $cfg->entry("db", "user");
 }
 
-my $test_num = 1;
+sub test_dbpass {
+  $cfg->entry("db", "password");
+}
 
-sub ok ($$) {
-  my ($ok, $desc) = @_;
+sub test_dbclass {
+  $cfg->entry("db", "class", "BSE::DB::Mysql");
+}
 
-  if ($INC{"Test/More.pm"}) {
-    return Test::More::ok($ok, $desc);
-  }
-  else {
-    if ($ok) {
-      print "ok $test_num # $desc\n";
-    }
-    else {
-      print "not ok $test_num # $desc ",join(",", caller()),"\n";
-    }
-    ++$test_num;
-    return $ok;
-  }
+sub test_sessionclass {
+  $cfg->entry("basic", "session_class", "Apache::Session::Mysql");
 }
 
-sub skip {
-  my ($desc, $count) = @_;
+sub test_perl {
+  $cfg->entry("paths", "perl", $^X);
+}
 
-  if ($INC{"Test/More.pm"}) {
-  SKIP: {
-      Test::More::skip($desc, $count);
-    }
-  }
-  else {
-    $count ||= 1;
-    for my $i (1..$count) {
-      print "ok $test_num # skipped: $desc\n";
-      ++$test_num;
-    }
-  }
+sub test_conffile {
+  $conffile;
 }
 
 sub make_ua {
@@ -133,49 +108,48 @@ sub make_url {
 
 sub check_content {
   my ($content, $note, $match) = @_;
-  unless (ok($content =~ /$match/s, "$note: match")) {
-    print "# wanted /$match/ got:\n";
-    my $copy = $content;
-    $copy =~ s/^/# /gm;
-    $copy .= "\n" unless $copy =~ /\n\z/;
-    print $copy;
-  }
+  my $tb = Test::Builder->new;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  return $tb->like($content, qr/$match/s, "$note: match");
 }
 
 sub _check_fetch {
   my ($content, $code, $ok, $headers,
       $note, $match, $headmatch) = @_;  
 
+  my $tb = Test::Builder->new;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
   my $good = $ok;
-  ok($ok, "$note: fetch ($code)");
-  if ($ok) {
+  $tb->ok($ok, "$note: fetch ($code)");
+  SKIP:
+  {
+    my $count = 0;
+    $count++ if $match;
+    $count++ if $headmatch;
+    $ok or skip("$note: fetch failed", $count) if $count;
     if ($match) {
-      unless (ok($content =~ /$match/s, "$note: match")) {
-       print "# wanted /$match/ got:\n";
-       my $copy = $content;
-       $copy =~ s/^/# /gm;
-       $copy .= "\n" unless $copy =~ /\n\z/;
-       print $copy;
+      unless ($tb->like($content, qr/$match/s, "$note: match")) {
+       #print "# wanted /$match/ got:\n";
+       #my $copy = $content;
+       #$copy =~ s/^/# /gm;
+       #$copy .= "\n" unless $copy =~ /\n\z/;
+       #print $copy;
        $good = 0;
       }
     }
     if ($headmatch) {
-      unless (ok($headers =~ /$headmatch/s, "$note: headmatch")) {
-       print "# wanted /$headmatch/ got:\n";
-       my $copy = $headers;
-       $copy =~ s/^/# /gm;
-       $copy .= "\n" unless $copy =~ /\n\z/;
-       print $copy;
+      unless ($tb->like($headers, qr/$headmatch/s, "$note: headmatch")) {
+       #print "# wanted /$headmatch/ got:\n";
+       #my $copy = $headers;
+       #$copy =~ s/^/# /gm;
+       #$copy .= "\n" unless $copy =~ /\n\z/;
+       #print $copy;
        $good = 0;
       }
     }
   }
-  else {
-    my $count = 0;
-    $count++ if $match;
-    $count++ if $headmatch;
-    skip("$note: fetch failed", $count) if $count;
-  }
 
   if (wantarray) {
     return ($content, $code, $good, $headers);
@@ -262,7 +236,10 @@ sub follow_refresh_ok {
 sub click_ok {
   my ($ua, $note, $name, $match, $headmatch) = @_;
 
-  my $ok = ok($ua->click($name), "$note - click");
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  my $tb = Test::Builder->new;
+
+  my $ok = $tb->ok($ua->click($name), "$note - click");
   return _check_fetch($ua->{content}, $ua->{status}, $ok, 
                      $ua->{res}->headers_as_string, $note, 
                      $match, $headmatch)
@@ -283,6 +260,9 @@ sub check_form {
   my $textname;
   my %values;
 
+  my $tb = Test::Builder->new;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
   my $text =
     sub {
       my ($t) = @_;
@@ -295,26 +275,26 @@ sub check_form {
       if ($tagname eq 'input') {
        my $name = $attr->{name};
        if ($name && $todo{$name}) {
-         ok(1, "$note - $name - field is present");
+         $tb->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");
+             $tb->ok($cvalue eq $fvalue, "$note - $name - comparing values");
            }
            else {
-             ok(0, "$note - $name - value is not present");
+             $tb->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");
+             $tb->ok($ttype eq $ftype, "$note - $name - comparing types");
            }
            else {
-             ok(0, "$note - $name - type not present");
+             $tb->ok(0, "$note - $name - type not present");
            }
          }
          delete $todo{$name};
@@ -324,12 +304,12 @@ sub check_form {
        $selname = $attr->{name};
        
        if ($todo{$selname}) {
-         ok(1, "$note - $selname - field is present");
+         $tb->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)");
+           $tb->ok ($ttype eq 'select', "$note - $selname - checking type (select)");
          }
        }
       }
@@ -344,10 +324,10 @@ sub check_form {
            my $fvalue = $attr->{value};
            my $tvalue = $todo{$selname}[0];
            if (defined $fvalue) {
-             ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
+             $tb->ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
            }
            else {
-             ok(0, "$note - $selname - no value supplied");
+             $tb->ok(0, "$note - $selname - no value supplied");
            }
          }
        }
@@ -364,7 +344,7 @@ sub check_form {
 
       if ($tagname eq 'select' && $inselect) {
        if (!$checked_sel_value) {
-         ok(0, "$note - $selname - no value selected");
+         $tb->ok(0, "$note - $selname - no value selected");
        }
        delete $todo{$selname};
       }
@@ -373,13 +353,13 @@ sub check_form {
        if ($todo{$textname}) {
          my $fvalue = HTML::Entities::decode_entities($saved);
          $values{$textname} = $fvalue;
-         ok(1, "$note - $textname - field exists");
+         $tb->ok(1, "$note - $textname - field exists");
          if (defined $todo{$textname}[0]) {
            my $tvalue = $todo{$textname}[0];
-           ok($tvalue eq $fvalue, "$note - $textname - checking value($tvalue vs $fvalue)");
+           $tb->ok($tvalue eq $fvalue, "$note - $textname - checking value($tvalue vs $fvalue)");
          }
          if (defined $todo{$textname}[1]) {
-           ok ($todo{$textname}[1] eq 'textarea',
+           $tb->ok ($todo{$textname}[1] eq 'textarea',
                "$note - $textname - check field type");
          }
          delete $todo{$textname};
@@ -392,11 +372,13 @@ sub check_form {
   $p->parse($content);
   $p->eof;
   for my $name (keys %todo) {
-    ok(0, "$note - $name - field doesn't exist");
+    $tb->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);
+  SKIP: {
+      skip("$note - $name - no field", $count) if $count;
+    }
   }
 
   return %values;
@@ -407,6 +389,7 @@ sub test_actions {
   my ($class) = @_;
 
   my $tb = Test::Builder->new;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
 
   my $obj = $class->new;
   my $actions = $obj->actions;
index 5428206..08d815a 100644 (file)
@@ -1,9 +1,9 @@
 #!perl -w
 use strict;
-use BSE::Test qw(make_ua ok fetch_ok base_url config);
+use Test::More tests => 62;
+use BSE::Test qw(make_ua fetch_ok base_url config);
 
 ++$|;
-print "1..62\n";
 my $baseurl = base_url;
 ok($baseurl =~ /^http:/, "basic check of base url");
 my $ua = make_ua;
@@ -27,7 +27,7 @@ fetch_ok($ua, "failed search", "$baseurl/cgi-bin/search.pl?q=blargle",
         "No\\s+documents\\s+were\\s+found");
 fetch_ok($ua, "good search", "$baseurl/cgi-bin/search.pl?q=shop",
         qr!You\s+can\s+buy!s);
-if (config('site users.nopassword')) {
+if (config->entry('site users', 'nopassword')) {
   fetch_ok($ua, "not user logon page", "$baseurl/cgi-bin/user.pl",
           qr!Not\s+Authenticated!s);
 }