reorganize test files into categories
authorTony Cook <tony@develop-help.com>
Mon, 3 Sep 2012 13:46:17 +0000 (23:46 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 3 Sep 2012 13:46:17 +0000 (23:46 +1000)
93 files changed:
MANIFEST
t/010-modules/010-dhdates.t [new file with mode: 0644]
t/010-modules/020-validate.t [new file with mode: 0644]
t/010-modules/030-country.t [new file with mode: 0644]
t/010-modules/040-bsesort.t [new file with mode: 0644]
t/010-modules/050-format.t [new file with mode: 0644]
t/010-modules/060-sqldates.t [new file with mode: 0644]
t/010-modules/070-escape.t [new file with mode: 0644]
t/010-modules/080-cfg.t [new file with mode: 0644]
t/010-modules/090-subcalc.t [new file with mode: 0644]
t/020-templater/000-load.t [new file with mode: 0644]
t/020-templater/010-token.t [new file with mode: 0644]
t/020-templater/020-parse.t [new file with mode: 0644]
t/020-templater/030-expr.t [new file with mode: 0644]
t/020-templater/040-original.t [new file with mode: 0644]
t/020-templater/080-parms.t [new file with mode: 0644]
t/030-tags/010-num.t [new file with mode: 0644]
t/030-tags/020-iter.t [new file with mode: 0644]
t/050-local/010-api.t [new file with mode: 0644]
t/050-local/020-article.t [new file with mode: 0644]
t/050-local/030-tags.t [new file with mode: 0644]
t/050-local/040-catalog.t [new file with mode: 0644]
t/050-local/050-dyncat.t [new file with mode: 0644]
t/060-generate/010-generate.t [new file with mode: 0644]
t/060-generate/020-catalog.t [new file with mode: 0644]
t/060-generate/030-thumb.t [new file with mode: 0644]
t/070-user/010-edit.t [new file with mode: 0644]
t/070-user/020-images.t [new file with mode: 0644]
t/080-remote/010-save.t [new file with mode: 0644]
t/080-remote/020-cat.t [new file with mode: 0644]
t/080-remote/030-parent.t [new file with mode: 0644]
t/080-remote/040-steps.t [new file with mode: 0644]
t/100-payment/010-securepayxml.t [new file with mode: 0644]
t/100-payment/020-nabtransactxml.t [new file with mode: 0644]
t/100-payment/030-eway.t [new file with mode: 0644]
t/110-courier/010-fastway.t [new file with mode: 0644]
t/110-courier/020-auspost.t [new file with mode: 0644]
t/110-courier/030-by-unit.t [new file with mode: 0644]
t/120-thumb/00load.t [new file with mode: 0644]
t/120-thumb/10scale.t [new file with mode: 0644]
t/120-thumb/data/scale40x30.png [new file with mode: 0644]
t/120-thumb/data/scale40x30fill.png [new file with mode: 0644]
t/120-thumb/data/simple.png [new file with mode: 0644]
t/900-kwalitee/010-strict-warn.t [new file with mode: 0644]
t/900-kwalitee/020-checktemplates.t [new file with mode: 0644]
t/900-kwalitee/030-messages.t [new file with mode: 0644]
t/900-kwalitee/040-podcheck.t [new file with mode: 0644]
t/courier/by-unit.t [deleted file]
t/t010template.t [deleted file]
t/t011dhdates.t [deleted file]
t/t012validate.t [deleted file]
t/t013country.t [deleted file]
t/t014bsesort.t [deleted file]
t/t020checktemplates.t [deleted file]
t/t050format.t [deleted file]
t/t060parms.t [deleted file]
t/t070sqldates.t [deleted file]
t/t080escape.t [deleted file]
t/t081cfg.t [deleted file]
t/t090tags.t [deleted file]
t/t091iter.t [deleted file]
t/t10edit.t [deleted file]
t/t11save.t [deleted file]
t/t12cat.t [deleted file]
t/t13parent.t [deleted file]
t/t13steps.t [deleted file]
t/t15api.t [deleted file]
t/t16article.t [deleted file]
t/t17tags.t [deleted file]
t/t20gen.t [deleted file]
t/t21gencat.t [deleted file]
t/t30rules.t [deleted file]
t/t40images.t [deleted file]
t/t50subscalc.t [deleted file]
t/t60securepayxml.t [deleted file]
t/t61fastway.t [deleted file]
t/t62auspost.t [deleted file]
t/t63nabtransactxml.t [deleted file]
t/t64eway.t [deleted file]
t/t70thumbim.t [deleted file]
t/t80catalog.t [deleted file]
t/t85message.t [deleted file]
t/t90dyncat.t [deleted file]
t/t98podcheck.t [deleted file]
t/templater/00load.t [deleted file]
t/templater/10token.t [deleted file]
t/templater/20parse.t [deleted file]
t/templater/30expr.t [deleted file]
t/thumb/00load.t [deleted file]
t/thumb/10scale.t [deleted file]
t/thumb/data/scale40x30.png [deleted file]
t/thumb/data/scale40x30fill.png [deleted file]
t/thumb/data/simple.png [deleted file]

index 082ccc2..13f9dc4 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -839,70 +839,70 @@ t-js/10menu.js
 t-js/menu.css
 t-js/test.js
 t-js/tests.css
+t/010-modules/010-dhdates.t
+t/010-modules/020-validate.t
+t/010-modules/030-country.t
+t/010-modules/040-bsesort.t
+t/010-modules/050-format.t
+t/010-modules/060-sqldates.t
+t/010-modules/070-escape.t
+t/010-modules/080-cfg.t
+t/010-modules/090-subcalc.t
+t/020-templater/000-load.t
+t/020-templater/010-token.t
+t/020-templater/020-parse.t
+t/020-templater/030-expr.t
+t/020-templater/040-original.t
+t/020-templater/080-parms.t
+t/030-tags/010-num.t
+t/030-tags/020-iter.t
+t/050-local/010-api.t
+t/050-local/020-article.t
+t/050-local/030-tags.t
+t/050-local/040-catalog.t
+t/050-local/050-dyncat.t
+t/060-generate/010-generate.t
+t/060-generate/020-catalog.t
+t/060-generate/030-thumb.t
+t/070-user/010-edit.t
+t/070-user/020-images.t
+t/080-remote/010-save.t
+t/080-remote/020-cat.t
+t/080-remote/030-parent.t
+t/080-remote/040-steps.t
+t/100-payment/010-securepayxml.t
+t/100-payment/020-nabtransactxml.t
+t/100-payment/030-eway.t
+t/110-courier/010-fastway.t
+t/110-courier/020-auspost.t
+t/110-courier/030-by-unit.t
+t/120-thumb/00load.t
+t/120-thumb/10scale.t
+t/120-thumb/data/scale40x30.png
+t/120-thumb/data/scale40x30fill.png
+t/120-thumb/data/simple.png
+t/900-kwalitee/010-strict-warn.t
+t/900-kwalitee/020-checktemplates.t
+t/900-kwalitee/030-messages.t
+t/900-kwalitee/040-podcheck.t
 t/BSE/Test.pm
 t/cfg/bse.cfg
 t/cfg/cfg/00start.cfg
 t/cfg/cfg/99end.cfg
 t/cfg/isafile.cfg
 t/cfg/t/varinc.cfg
-t/courier/by-unit.t
 t/data/govhouse.jpg
 t/data/known_pod_issues.txt
 t/data/t101.jpg
 t/t000load.t
 t/t00smoke.t                   makes a request to most of the scripts
-t/t010template.t               Tests Squirrel::Template
-t/t011dhdates.t                        Tests DevHelp::Date
-t/t012validate.t
-t/t013country.t
-t/t014bsesort.t
-t/t020checktemplates.t
-t/t050format.t                 DevHelp::Formatter tests
-t/t060parms.t
-t/t070sqldates.t               Test SQL date tools
-t/t080escape.t
-t/t081cfg.t
-t/t090tags.t
-t/t091iter.t
-t/t10edit.t
-t/t11save.t
-t/t12cat.t
-t/t13parent.t
-t/t13steps.t
-t/t15api.t
-t/t16article.t
-t/t17tags.t
-t/t20gen.t
-t/t21gencat.t                  Tests catalog generation
-t/t30rules.t                   Check for use strict and warnings
-t/t40images.t                  Tests image management
-t/t50subscalc.t                        Test subscriptions calculations
-t/t60securepayxml.t
-t/t61fastway.t
-t/t62auspost.t
-t/t63nabtransactxml.t
-t/t64eway.t
-t/t70thumbim.t
-t/t80catalog.t
-t/t85message.t
-t/t90dyncat.t
-t/t98podcheck.t
 t/tags/bse.cfg
-t/templater/00load.t
-t/templater/10token.t
-t/templater/20parse.t
-t/templater/30expr.t
 t/templates/called.tmpl
-t/templates/included.include   Used by t010template.t
+t/templates/included.include
 t/templates/included.recursive
 t/templates/preload.tmpl
 t/templates/wrapinner.tmpl
 t/templates/wrapself.tmpl
-t/templates/wraptest.tmpl      Used by t010template.t
-t/thumb/00load.t
-t/thumb/10scale.t
-t/thumb/data/scale40x30.png
-t/thumb/data/scale40x30fill.png
-t/thumb/data/simple.png
+t/templates/wraptest.tmpl
 test.cfg-dist
 test.cfg.base
diff --git a/t/010-modules/010-dhdates.t b/t/010-modules/010-dhdates.t
new file mode 100644 (file)
index 0000000..142df40
--- /dev/null
@@ -0,0 +1,95 @@
+#!perl -w
+use strict;
+use Test::More tests=>46;
+
+my $gotmodule;
+BEGIN { $gotmodule = use_ok('DevHelp::Date', ':all'); }
+
+SKIP:
+{
+  skip "couldn't load module", 41 unless $gotmodule;
+  my $msg;
+  is_deeply([ dh_parse_time("10:00", \$msg) ], [ 10, 0, 0 ], "parse 10:00");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("10pm", \$msg) ], [ 22, 0, 0 ], "parse 10pm");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("10 05", \$msg) ], [ 10, 5, 0 ], "parse 10 05");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("12am", \$msg) ], [ 0, 0, 0 ], "parse 12am");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("12pm", \$msg) ], [ 12, 0, 0 ], "parse 12pm");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("12.01pm", \$msg) ], [ 12, 1, 0 ], "parse 12.01pm");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("1pm", \$msg) ], [ 13, 0, 0 ], "parse 1pm");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("1.00PM", \$msg) ], [ 13, 0, 0 ], "parse 1.00PM");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("12:59PM", \$msg) ], [ 12, 59, 0 ], 
+           "parse 12:59PM");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("0000", \$msg) ], [ 0, 0, 0 ], "parse 0000");
+  is($msg, undef, "no error");
+  undef $msg;
+  is_deeply([ dh_parse_time("1101", \$msg) ], [ 11, 1, 0 ], "parse 1101");
+  is($msg, undef, "no error");
+
+  is_deeply([ dh_parse_time("11:01:02", \$msg) ], [ 11, 1, 2 ],
+           "parse 11:01:02") or diag $msg;
+  is_deeply([ dh_parse_time("11:01:02pm", \$msg) ], [23, 1, 2 ],
+           "parse 11:01:02pm") or diag $msg;
+
+  # fail a bit
+  undef $msg;
+  is_deeply([ dh_parse_time("xxx", \$msg) ], [], "parse xxx");
+  is($msg, "Unknown time format", "got an error");
+  undef $msg;
+  is_deeply([ dh_parse_time("0pm", \$msg) ], [], "parse 0pm");
+  is($msg, "Hour must be from 1 to 12 for 12 hour time", "got an error");
+  undef $msg;
+  is_deeply([ dh_parse_time("13pm", \$msg) ], [], "parse 13pm");
+  is($msg, "Hour must be from 1 to 12 for 12 hour time", "got an error");
+  undef $msg;
+  is_deeply([ dh_parse_time("12:60am", \$msg) ], [], "parse 12:60am");
+  is($msg, "Minutes must be from 0 to 59", "got an error");
+  undef $msg;
+  is_deeply([ dh_parse_time("2400", \$msg) ], [], "parse 2400");
+  is($msg, "Hour must be from 0 to 23 for 24-hour time", "got an error");
+  undef $msg;
+  is_deeply([ dh_parse_time("1360", \$msg) ], [], "parse 1360");
+  is($msg, "Minutes must be from 0 to 59", "got an error");
+
+  # sql times
+  
+  undef $msg;
+  is(dh_parse_time_sql("2:30pm"), "14:30:00", "2:30pm to sql");
+  is($msg, undef, "no error");
+
+  # parse SQL date
+  is_deeply([ dh_parse_sql_date("2005-07-12") ], [ 2005, 7, 12 ],
+           "simple sql date parse");
+  is_deeply([ dh_parse_sql_date("20") ], [ ],
+           "invalid sql date parse");
+  is_deeply([ dh_parse_sql_datetime("2005-06-30 12:00:05") ],
+           [ 2005, 6, 30, 12, 0, 5 ], "parse SQL date time");
+  is_deeply([ dh_parse_sql_datetime("2005-06-30 12") ],
+           [ ], "invalid parse SQL date time");
+  is(dh_strftime_sql_datetime("%d/%m/%Y", "2005-06-30 12:00:05"),
+     "30/06/2005", "dh_strftime_sql_datetime");
+
+  is(dh_strftime_sql_datetime("%a %U %j %d/%m/%Y", "2005-06-30 12:00:05"),
+     "Thu 26 181 30/06/2005", "dh_strftime_sql_datetime dow check");
+
+  is(dh_strftime("%a %U %j %F %T", 20, 5, 12, 30, 5, 105),
+     "Thu 26 181 2005-06-30 12:05:20",
+     "dh_strftime");
+}
diff --git a/t/010-modules/020-validate.t b/t/010-modules/020-validate.t
new file mode 100644 (file)
index 0000000..37b3a72
--- /dev/null
@@ -0,0 +1,79 @@
+#!perl -w
+use strict;
+use Test::More tests => 16;
+
+BEGIN { use_ok('DevHelp::Validate'); }
+
+{
+  my %built_ins =
+    (
+     oneline =>
+     {
+      rules => "dh_one_line"
+     },
+    );
+  my $val = DevHelp::Validate::Hash->new(fields => \%built_ins);
+  ok($val, "got built-ins validation object");
+  {
+    my %errors;
+    ok($val->validate({ oneline => "abc" }, \%errors), "valid oneline");
+    is_deeply(\%errors, {}, "no errors set");
+  }
+  {
+    my %errors;
+    ok(!$val->validate({ oneline => "\x0D" }, \%errors), "invalid oneline (CR)");
+    ok($errors{oneline}, "message for oneline");
+  }
+  {
+    my %errors;
+    ok(!$val->validate({ oneline => "\x0A" }, \%errors), "invalid oneline (LF)");
+    ok($errors{oneline}, "message for oneline");
+  }
+}
+
+{
+  my %simple_date =
+    (
+     date => 
+     {
+      rules => 'date'
+     },
+    );
+  
+  my $val = DevHelp::Validate::Hash->new(fields => \%simple_date);
+  ok($val, "got validation object");
+  {
+    my %errors;
+    ok($val->validate({ date => "30/12/67" }, \%errors), "valid date");
+  }
+  {
+    my %errors;
+    ok(!$val->validate({ date => "32/12/67" }, \%errors),
+       "obviously invalid date");
+  }
+  {
+    my %errors;
+    ok(!$val->validate({ date => "31/9/67" }, \%errors),
+       "not so obviously invalid date");
+  }
+  {
+    my %errors;
+    ok(!$val->validate({ date => "29/2/67" }, \%errors),
+       "leap year check 29/2/67");
+  }
+  {
+    my %errors;
+    ok($val->validate({ date => "28/2/67" }, \%errors),
+       "leap year check 28/2/67");
+  }
+  {
+    my %errors;
+    ok($val->validate({ date => "29/2/80" }, \%errors),
+       "leap year check 29/2/80");
+  }
+  {
+    my %errors;
+    ok($val->validate({ date => "29/12/2000" }, \%errors),
+       "leap year check 29/2/2000");
+  }
+}
diff --git a/t/010-modules/030-country.t b/t/010-modules/030-country.t
new file mode 100644 (file)
index 0000000..34938ff
--- /dev/null
@@ -0,0 +1,9 @@
+#!perl -w
+use strict;
+use Test::More tests => 3;
+
+use BSE::Countries qw(bse_country_code);
+
+is(bse_country_code("Australia"), "AU", "we know where australia is");
+is(bse_country_code("new zealand"), "NZ", "we know where new zealand is");
+is(bse_country_code("not a country"), undef, "we know how to fail");
diff --git a/t/010-modules/040-bsesort.t b/t/010-modules/040-bsesort.t
new file mode 100644 (file)
index 0000000..9c29202
--- /dev/null
@@ -0,0 +1,23 @@
+#!perl -w
+use strict;
+use Test::More tests => 3;
+
+BEGIN { use_ok("BSE::Sort", "bse_sort"); }
+
+{
+  my $a100 = { a => 100, b => 3 };
+  my $a2 = { a => 2, b => 2 };
+  my $a30 = { a => 30, b => 4 };
+
+  my @in = ( $a2, $a100, $a30 );
+  my %types = qw(a n b n);
+
+  {
+    my @out = bse_sort(\%types, "sort=a", @in);
+    is_deeply(\@out, [ $a2, $a30, $a100 ], "check simple numeric sort");
+  }
+  {
+    my @out = bse_sort(\%types, "filter= b >= 3", @in);
+    is_deeply(\@out, [ $a100, $a30 ], "check simple filtering");
+  }
+}
diff --git a/t/010-modules/050-format.t b/t/010-modules/050-format.t
new file mode 100644 (file)
index 0000000..1d8976e
--- /dev/null
@@ -0,0 +1,351 @@
+#!perl -w
+use strict;
+use Test::More tests => 97;
+
+sub format_test($$$;$);
+sub noformat_test($$$;$);
+
+my $gotmodule = require_ok('DevHelp::Formatter');
+
+SKIP: {
+  skip "couldn't load module", 63 unless $gotmodule;
+  format_test 'acronym[hello]', '<p><acronym>hello</acronym></p>', 'acronym';
+  format_test 'acronym[|hello]', '<p><acronym>hello</acronym></p>', 'acronym with empty title';
+  format_test 'acronym[foo|hello]', '<p><acronym title="foo">hello</acronym></p>', 'acronym with title';
+  format_test 'acronym[foo|bar|hello]', '<p><acronym class="bar" title="foo">hello</acronym></p>', 'acronym with class and title';
+  format_test 'bdo[ltr|hello]', '<p><bdo dir="ltr">hello</bdo></p>', 'bdo with dir';
+  format_test 'code[hello]', '<p><code>hello</code></p>', 'code';
+  format_test 'code[|hello]', '<p><code>hello</code></p>', 'code empty class';
+  format_test 'code[foo|hello]', '<p><code class="foo">hello</code></p>', 'code with class';
+  format_test 'code[var[x]="1"]', '<p><code><var>x</var>=&quot;1&quot;</code></p>', 'code with var';
+  format_test 'blockquote[hello]', '<blockquote><p>hello</p></blockquote>', 'blockquote';
+  format_test 'blockquote[|hello]', '<blockquote><p>hello</p></blockquote>', 'blockquote with empty class';
+  format_test 'blockquote[foo|hello]', '<blockquote class="foo"><p>hello</p></blockquote>', 'blockquote with class';
+  format_test <<IN, <<OUT, 'strong over paras', 'both';
+strong[foo|hello
+
+foo]
+IN
+<p><strong class="foo">hello</strong></p>
+<p><strong class="foo">foo</strong></p>
+OUT
+  format_test <<IN, <<OUT, 'blockquote list h1 var', 'both';
+blockquote[
+** one
+** two
+h1[quux]var[hello
+there]
+
+foo]
+IN
+<blockquote><ul><li>one</li><li>two</li></ul>
+<h1>quux</h1>
+<p><var>hello<br />
+there</var></p>
+<p>foo</p></blockquote>
+OUT
+  format_test <<IN, <<OUT, 'address class h1 abbr over paras', 'both';
+address[foo|h1[bar
+
+quux]abbr[my abbr|hello]
+
+class[foo|b[bold|E=MCsup[2]]]
+
+foo]
+IN
+<address class="foo"><h1>bar</h1>
+<h1>quux</h1>
+<p><abbr title="my abbr">hello</abbr></p>
+<p class="foo"><b class="bold">E=MC<sup>2</sup></b></p>
+<p>foo</p></address>
+OUT
+  format_test <<IN, <<OUT, 'div blockquote h1 class over paras', 'both';
+div[quux|blockquote[foo|h1[bar]
+b[hello]
+class[foo|b[bold|E=MCsup[2
+
+kbd[xxx|super]]]]
+
+foo]]
+IN
+<div class="quux"><blockquote class="foo"><h1>bar</h1>
+<p><b>hello</b><br />
+<span class="foo"><b class="bold">E=MC<sup>2</sup></b></span></p>
+<p class="foo"><b class="bold"><sup><kbd class="xxx">super</kbd></sup></b></p>
+<p>foo</p></blockquote></div>
+OUT
+  format_test <<IN, <<OUT, 'bold', 'both';
+b[hello]
+IN
+<p><b>hello</b></p>
+OUT
+  format_test 'i[hello]', '<p><i>hello</i></p>', 'italic';
+  format_test 'b[i[hello]]', '<p><b><i>hello</i></b></p>', 'bold/italic';
+  format_test <<IN, <<OUT, 'bold over lines', 'both';
+b[hello
+foo]
+IN
+<p><b>hello<br />
+foo</b></p>
+OUT
+  format_test <<IN, <<OUT, 'bold over paras', 'both';
+b[hello
+
+foo]
+IN
+<p><b>hello</b></p>
+<p><b>foo</b></p>
+OUT
+  format_test <<IN, <<OUT, 'combo over paras', 'both';
+i[b[hello
+
+foo
+
+bar]]
+IN
+<p><i><b>hello</b></i></p>
+<p><i><b>foo</b></i></p>
+<p><i><b>bar</b></i></p>
+OUT
+  format_test <<IN, <<OUT, 'link', 'both';
+link[http://foo/|bar
+
+quux]
+IN
+<p><a href="http://foo/">bar</a></p>
+<p><a href="http://foo/">quux</a></p>
+OUT
+  format_test 'tt[hello]', '<p><tt>hello</tt></p>', 'tt';
+  format_test 'font[-1|text]', '<p><font size="-1">text</font></p>', 'fontsize';
+  format_test 'fontcolor[-1|black|text]', '<p><font size="-1" color="black">text</font></p>', 'fontsizecolor';
+  format_test 'anchor[somename]', '<p><a name="somename"></a></p>', 'anchor';
+  format_test <<IN, <<OUT, 'pre', 'both';
+
+
+pre[hello there
+Joe]
+IN
+<pre>hello there
+Joe</pre>
+OUT
+  format_test <<IN, <<OUT, 'pre with bold', 'both';
+pre[b[hello there
+
+Joe]]
+IN
+<pre><b>hello there</b>
+
+<b>Joe</b></pre>
+OUT
+  format_test <<IN, <<OUT, 'html', 'both';
+html[<object foo="bar" />]
+IN
+<object foo="bar" />
+OUT
+
+  format_test 'embed[foo]', '', 'embed1';
+  format_test 'embed[foo,bar]', '', 'embed2';
+  format_test 'embed[foo,bar,quux]', '', 'embed3';
+  format_test 'h1[|text]', '<h1>text</h1>', 'h1';
+  format_test 'h1[someclass|text]', '<h1 class="someclass">text</h1>', 'h1class';
+  format_test 'h6[|te>xt]', '<h6>te&gt;xt</h6>', 'h6';
+  format_test 'h1[|foo]h2[|bar]', "<h1>foo</h1>\n<h2>bar</h2>", 'h1h2';
+  format_test 'h1[|foo]texth2[|bar]', 
+    "<h1>foo</h1>\n<p>text</p>\n<h2>bar</h2>", 'h1texth2';
+  format_test 'align[left|some text]', '<div align="left"><p>some text</p></div>', 'align';
+  format_test 'hr[]', '<hr />', 'hr0';
+  format_test 'hr[80%]', '<hr width="80%" />', 'hr1';
+  format_test 'hr[80%|10]', '<hr width="80%" size="10" />', 'hr2';
+  format_test <<IN, <<OUT, 'table1', 'both';
+table[80%
+bgcolor="black"|quux|blarg
+|hello|there
+]
+IN
+<table width="80%"><tr bgcolor="black"><td>quux</td><td>blarg</td></tr><tr><td>hello</td><td>there</td></tr></table>
+OUT
+  format_test <<IN, <<OUT, 'table2', 'both';
+table[80%|#808080|2|2|Arial
+bgcolor="black"|quux|blarg
+|hello|there
+]
+IN
+<table width="80%" bgcolor="#808080" cellpadding="2"><tr bgcolor="black"><td><font size="2" face="Arial">quux</font></td><td><font size="2" face="Arial">blarg</font></td></tr><tr><td><font size="2" face="Arial">hello</font></td><td><font size="2" face="Arial">there</font></td></tr></table>
+OUT
+  format_test <<IN, <<OUT, 'table3', 'both';
+table[80%|foo]
+IN
+<table width="80%"><tr><td>foo</td></tr></table>
+OUT
+  format_test <<IN, <<OUT, 'ol1', 'both';
+## one
+## two
+IN
+<ol><li>one</li><li>two</li></ol>
+OUT
+  format_test <<IN, <<OUT, 'ol2', 'both';
+## one
+
+## two
+IN
+<ol><li><p>one</p></li><li>two</li></ol>
+OUT
+  format_test <<IN, <<OUT, 'ol1 alpha', 'both';
+%% one
+%% two
+IN
+<ol type="a"><li>one</li><li>two</li></ol>
+OUT
+  format_test <<IN, <<OUT, 'ol2 alpha', 'both';
+%% one
+
+%% two
+IN
+<ol type="a"><li><p>one</p></li><li>two</li></ol>
+OUT
+  format_test <<IN, <<OUT, 'ul1', 'both';
+** one
+** two
+IN
+<ul><li>one</li><li>two</li></ul>
+OUT
+  format_test <<IN, <<OUT, 'ul2', 'both';
+** one
+
+** two
+IN
+<ul><li><p>one</p></li><li>two</li></ul>
+OUT
+
+  format_test <<IN, <<OUT, 'ul indented', 'both';
+  ** one
+**two
+IN
+<ul><li>one</li><li>two</li></ul>
+OUT
+
+  format_test <<IN, <<OUT, "don't ul at end of line", 'both';
+this shouldn't be a bullet ** some text
+
+** this should be a bullet
+** so should this
+IN
+<p>this shouldn't be a bullet ** some text</p>
+<ul><li>this should be a bullet</li><li>so should this</li></ul>
+OUT
+
+  format_test <<IN, <<OUT, 'mixed', 'both';
+** joe
+** bob
+## one
+## two
+IN
+<ul><li>joe</li><li>bob</li></ul><ol><li>one</li><li>two</li></ol>
+OUT
+
+  format_test <<IN, <<OUT, 'spaces between', 'both';
+** joe
+** bob
+
+** jane
+IN
+<ul><li><p>joe</p></li><li><p>bob</p></li><li>jane</li></ul>
+OUT
+
+  format_test 'indent[text]', '<ul>text</ul>', 'indent';
+  format_test 'center[text]', '<center>text</center>', 'center';
+  format_test 'hrcolor[80|10|#FF0000]', <<OUT, 'hrcolor', 'out';
+<table width="80" height="10" border="0" bgcolor="#FF0000" cellpadding="0" cellspacing="0"><tr><td><img src="/images/trans_pixel.gif" width="1" height="1" alt="" /></td></tr></table>
+OUT
+  format_test 'image[foo]', '<p></p>', 'image';
+
+  format_test 'class[xxx|yyy]', '<p class="xxx">yyy</p>', 'class';
+  format_test "class[xxx|yy\n\nzz]", <<EOS, 'class2', 'out';
+<p class="xxx">yy</p>
+<p class="xxx">zz</p>
+EOS
+  format_test 'div[someclass|h1[|foo]barh2[|quux]]', <<EOS, 'divblock', 'out';
+<div class="someclass"><h1>foo</h1>
+<p>bar</p>
+<h2>quux</h2></div>
+EOS
+
+  format_test "h1[#foo|test]", q!<h1 id="foo">test</h1>!, 'h1#id';
+  format_test "h1[#foo bar|test]", q!<h1 id="foo" class="bar">test</h1>!, 'h1#id class';
+  format_test "h1[#foo bar quux|test]", q!<h1 id="foo" class="bar quux">test</h1>!, 'h1#id class class';
+  format_test "h1[text-align: center;|test]", q!<h1 style="text-align: center;">test</h1>!, 'h1 styled';
+  format_test "h1[#foo text-align: center;|test]", q!<h1 id="foo" style="text-align: center;">test</h1>!, 'h1 styled, id';
+
+  format_test "div[text-align: center;|test\n\ntest2]", <<EOS, 'div styled', 'out';
+<div style="text-align: center;"><p>test</p>
+<p>test2</p></div>
+EOS
+
+  format_test "div[#foo|test\n\ntest2]", <<EOS, 'div #id', 'out';
+<div id="foo"><p>test</p>
+<p>test2</p></div>
+EOS
+
+  format_test "abc comment[foo] def", "<p>abc  def</p>", "comment";
+
+  # remove_format() tests
+  noformat_test 'image[foo]', '', 'image';
+  noformat_test 'code[something [bar]]', 'something [bar]', 'nested []';
+
+  noformat_test "abc comment[foo] def", "abc  def", "comment";
+
+  noformat_test 'class[foo|image[bar]]', '', 'class with image content';
+  noformat_test 'abbr[image[bar]]', '', 'abbr[] with image content';
+  noformat_test 'abbr[foo|image[bar]]', '', 'abbr[x|x] with image content';
+  noformat_test 'abbr[|image[bar]]', '', 'abbr[|x] with image content';
+  noformat_test 'strong[image[bar]]', '', 'strong[x] with image content';
+  noformat_test 'strong[|image[bar]]', '', 'strong[|x] with image content';
+  noformat_test 'strong[foo|image[bar]]', '', 'strong[x|x] with image content';
+
+  noformat_test 'div[foo|image[bar]]', '', 'div[x|x] with image content';
+  noformat_test 'comment[image[bar]]', '', 'comment[image[xx]] with image content';
+  noformat_test 'h1[foo|image[bar]]', '', 'h1[x|x] with image content';
+  noformat_test 'h1[|image[bar]]', '', 'h1[|x] with image content';
+  noformat_test 'h1[image[bar]]', '', 'h1[x] with image content';
+  
+  noformat_test 'poplink[xxx|image[bar]]', '', 'poplink[x|x] with image content';
+  noformat_test 'poplink[image[bar]]', '', 'poplink[x] with image content';
+  noformat_test 'link[xxx|image[bar]]', '', 'link[x|x] with image content';
+  noformat_test 'link[image[bar]]', '', 'link[x] with image content';
+  noformat_test 'align[xxx|image[bar]]', '', 'align[x|x] with image content';
+  noformat_test 'font[xxx|image[bar]]', '', 'font[x|x] with image content';
+  noformat_test 'hr[xxx|image[bar]]', '', 'hr[x|x] with image content';
+  noformat_test 'anchor[image[bar]]', '', 'anchor[x] with image content';
+  noformat_test '**image[bar]', '', '** list with image content';
+  noformat_test '%%image[bar]', '', '%% list with image content';
+  noformat_test '##image[bar]', '', '## list with image content';
+}
+
+sub format_test ($$$;$) {
+  my ($in, $out, $desc, $stripnl) = @_;
+
+  $stripnl ||= 'none';
+  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
+  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
+
+  my $formatter = DevHelp::Formatter->new;
+
+  my $result = $formatter->format($in);
+
+  is($result, $out, $desc);
+}
+
+sub noformat_test($$$;$) {
+  my ($in, $out, $desc, $stripnl) = @_;
+
+  $stripnl ||= 'none';
+  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
+  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
+
+  my $formatter = DevHelp::Formatter->new;
+
+  my $result = $formatter->remove_format($in);
+
+  is($result, $out, $desc);
+}
diff --git a/t/010-modules/060-sqldates.t b/t/010-modules/060-sqldates.t
new file mode 100644 (file)
index 0000000..efd0560
--- /dev/null
@@ -0,0 +1,32 @@
+#!perl -w
+use strict;
+use Test::More tests=>11;
+
+use BSE::Util::SQL qw(:all);
+
+is(sql_normal_date("2004/02/10"), "2004-02-10", "separators");
+is(sql_normal_date("2004-02-10 10:00:00"), "2004-02-10", "strip time");
+
+# sql_add_date_months():
+is(sql_add_date_months("2004-02-10", 2), "2004-04-10", 
+   "add months, simple");
+is(sql_add_date_months("2004-02-10", 12), "2005-02-10",
+   "add months, one year");
+is(sql_add_date_months("2004-02-10", 11), "2005-01-10",
+   "add months, 11 months");
+is(sql_add_date_months("2004-02-10", 13), "2005-03-10",
+   "add months, 13 months");
+is(sql_add_date_months("2004-01-30", 1), "2004-02-29",
+   "add months, to a shorter month");
+is(sql_add_date_months("2004-01-30", 13), "2005-02-28",
+   "add months, to a shorter month in non-leap year");
+
+
+# sql_add_date_days():
+is(sql_add_date_days("2004-02-10", 2), "2004-02-12",
+   "add days, simple");
+is(sql_add_date_days("2004-02-29", 1), "2004-03-01",
+   "add days, span month");
+is(sql_add_date_days("2004-12-31", 1), "2005-01-01",
+   "add days, span year");
+
diff --git a/t/010-modules/070-escape.t b/t/010-modules/070-escape.t
new file mode 100644 (file)
index 0000000..8833279
--- /dev/null
@@ -0,0 +1,13 @@
+#!perl -w
+use strict;
+use Test::More tests=>2;
+
+my $gotmodule = require_ok('DevHelp::HTML');
+
+SKIP: {
+  skip "couldn't load module", 9 unless $gotmodule;
+
+  DevHelp::HTML->import('escape_xml');
+
+  is(escape_xml("<&\xE9"), "&lt;&amp;\xE9", "don't escape like html");
+}
diff --git a/t/010-modules/080-cfg.t b/t/010-modules/080-cfg.t
new file mode 100644 (file)
index 0000000..734931f
--- /dev/null
@@ -0,0 +1,52 @@
+#!perl -w
+# BSE::Cfg tests
+use strict;
+use Test::More;
+
+BEGIN {
+  eval "use BSE::Cfg; 1"
+    or plan skip_all => "Cannot load BSE::Cfg";
+}
+
+plan tests => 15;
+
+#ok(chdir "t/cfg", "chdir to cfg dir");
+my $cfg = eval { BSE::Cfg->new(path => "t/cfg") };
+ok($cfg, "made a config");
+is($cfg->entry("alpha", "beta"), "one", "check simple lookup");
+is($cfg->entryVar("var", "varb"), "ab", "simple variable lookup");
+is($cfg->entryVar("var", "varc"), "tt", "complex variable lookup");
+
+is($cfg->entry("isafile", "key"), "value", "value from include");
+
+# values from directory includes, conflict resolution
+is($cfg->entry("conflict", "keya"), "valuez", "conflict resolution");
+
+# utf8
+is($cfg->entry("utf8", "omega"), "\x{2126}", "check utf8 parsed");
+is($cfg->entry("utf8", "omega2"), "\x{2126}", "check utf8 parsed from include");
+
+# missing values
+is($cfg->entry("unknown", "keya"), undef, "missing value no default");
+is($cfg->entry("unknown", "keya", "abc"), "abc", "missing value with default");
+
+# include included by variable name
+is($cfg->entry("varinc", "vara"), "somevalue", "include included by variable name");
+
+# get entire sections
+is_deeply({ $cfg->entriesCS("conflict") },
+         { keya => "valuez" }, "CS section with a value");
+is_deeply([ $cfg->orderCS("conflict") ],
+         [ qw/keya keya/ ], "original case keys in order of appearance");
+
+{
+  my $cfg = BSE::Cfg->new_from_text(text => <<EOS, path => ".");
+[by unit au shipping]
+description=testing
+base=1000
+unit=100
+EOS
+  ok($cfg, "make cfg from text");
+  is($cfg->entry("by unit au shipping", "description"), "testing",
+     "test we got the cfg");
+}
diff --git a/t/010-modules/090-subcalc.t b/t/010-modules/090-subcalc.t
new file mode 100644 (file)
index 0000000..0618674
--- /dev/null
@@ -0,0 +1,142 @@
+#!perl -w
+use strict;
+use Test::More tests=>9;
+
+my $gotmodule = require_ok('BSE::TB::Subscription::Calc');
+
+SKIP: {
+  skip "couldn't load module", 9 unless $gotmodule;
+
+  # simple as it gets
+  my @result = BSE::TB::Subscription::Calc->calculate_period
+    (1,
+     { 
+      orderDate => '2004/02/04 10:00', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 1,
+      product_id => 3,
+      item_id => 2,
+      max_lapsed => 0,
+     }
+    );
+  is(@result, 1, "simple, correct period count");
+  is_deeply(\@result,
+           [
+            { start => '2004-02-04',
+              end => '2004-03-04',
+              duration => 1,
+              order_ids => [ 1 ],
+              product_ids => [ 3 ],
+              item_ids => [ 2 ],
+              max_lapsed => 0,
+            },
+           ], "simple, correct period");
+
+  # overlapping ranges
+  @result = BSE::TB::Subscription::Calc->calculate_period
+    (1,
+     { 
+      orderDate => '2004/02/04', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 1,
+      product_id => 3,
+      item_id => 2,
+      max_lapsed => 0,
+     },
+     {
+      orderDate => '2004/02/28', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 2,
+      product_id => 3,
+      item_id => 4,
+      max_lapsed => 0,
+     },
+    );
+  is(@result, 1, "connected, correct period count");
+  is_deeply(\@result,
+           [
+            { start => '2004-02-04',
+              end => '2004-04-04',
+              duration => 2,
+              order_ids => [ 1, 2 ],
+              product_ids => [ 3, 3 ],
+              item_ids => [ 2, 4 ],
+              max_lapsed => 0,
+            },
+           ], "connected, correct period");
+
+  # completely disconnected ranges
+  @result = BSE::TB::Subscription::Calc->calculate_period
+    (1,
+     { 
+      orderDate => '2004/02/04', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 1,
+      product_id => 3,
+      item_id => 2,
+      max_lapsed => 0,
+     },
+     {
+      orderDate => '2004/03/05', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 2,
+      product_id => 3,
+      item_id => 4,
+      max_lapsed => 0,
+     },
+    );
+  is(@result, 2, "disconnected, correct period count");
+  is_deeply(\@result,
+           [
+            { start => '2004-02-04',
+              end => '2004-03-04',
+              duration => 1,
+              order_ids => [ 1 ],
+              product_ids => [ 3 ],
+              item_ids => [ 2 ],
+              max_lapsed => 0,
+            },
+            { start => '2004-03-05',
+              end => '2004-04-05',
+              duration => 1,
+              order_ids => [ 2 ],
+              product_ids => [ 3 ],
+              item_ids => [ 4 ],
+              max_lapsed => 0,
+            },
+           ], "disconnected, correct period");
+
+  # connected by grace period
+  @result = BSE::TB::Subscription::Calc->calculate_period
+    (1,
+     { 
+      orderDate => '2004/02/04', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 1,
+      product_id => 3,
+      item_id => 2,
+      max_lapsed => 1,
+     },
+     {
+      orderDate => '2004/03/05', # seconds should get stripped in code
+      subscription_period=>1,
+      order_id => 2,
+      product_id => 3,
+      item_id => 4,
+      max_lapsed => 2,
+     },
+    );
+
+  is(@result, 1, "grace period, correct period count");
+  is_deeply(\@result,
+           [
+            { start => '2004-02-04',
+              end => '2004-04-04',
+              duration => 2,
+              order_ids => [ 1, 2 ],
+              product_ids => [ 3, 3 ],
+              item_ids => [ 2, 4 ],
+              max_lapsed => 2,
+            },
+           ], "grace period, correct period");
+}
diff --git a/t/020-templater/000-load.t b/t/020-templater/000-load.t
new file mode 100644 (file)
index 0000000..3b91bb6
--- /dev/null
@@ -0,0 +1,4 @@
+#!perl -w
+use strict;
+use Test::More tests => 1;
+use_ok("Squirrel::Template");
diff --git a/t/020-templater/010-token.t b/t/020-templater/010-token.t
new file mode 100644 (file)
index 0000000..7c00d20
--- /dev/null
@@ -0,0 +1,403 @@
+#!perl -w
+use strict;
+use Test::More tests => 42;
+use Squirrel::Template;
+use Squirrel::Template::Constants qw(:token);
+
+sub test_tokens($$$);
+
+# test the interface
+my $templater = Squirrel::Template->new();
+my $t = Squirrel::Template::Tokenizer->new("content\n<:sometag foo:>", "<test>", $templater);
+
+ok($t, "make a tokenizer");
+
+my $peek = $t->peek;
+my $token = $t->get;
+is_deeply($peek, $token, "peek should be the same as following get");
+is($t->peek_type, "tag", "tag type coming up next");
+$t->unget($token);
+is($t->peek_type, "content", "unget of content means type of next should be content");
+$t->get;
+is($t->peek_type, "tag", "consume, and next should be tag again");
+$t->get;
+is($t->peek_type, "eof", "consume, and next should be eof");
+$t->get;
+is($t->peek_type, "", "consume, and next type should be empty string");
+is($t->peek, undef, "peek should be nothing");
+is($t->get, undef, "get should be nothing");
+
+
+# test the token stream
+
+test_tokens("abc",
+           [
+            [ content => "abc", 1, '<string>' ],
+            [ eof => "", 1, "<string>" ]
+           ], "simple");
+test_tokens("abc\n",
+           [
+            [ content => "abc\n", 1, '<string>' ],
+            [ eof => "", 2, "<string>" ]
+           ], "simple nl");
+test_tokens("<:foo:>",
+           [
+            [ tag => "<:foo:>", 1, "<string>", "foo", "" ],
+            [ eof => "", 1, "<string>" ],
+           ], "simple tag");
+test_tokens("<:foo\nsplit\nover lines:>",
+           [
+            [ tag => "<:foo\nsplit\nover lines:>", 1, "<string>", "foo", "split\nover lines" ],
+            [ eof => "", 3, "<string>" ],
+           ], "simple tag split over lines");
+           
+test_tokens("<:ifFoo:>TRUE\n<:or:>FALSE\n<:eif\n:>\n",
+           [
+            [ if => "<:ifFoo:>", 1, "<string>", "Foo", "" ],
+            [ content => "TRUE\n", 1, "<string>" ],
+            [ or => "<:or:>", 2, "<string>", "" ],
+            [ content => "FALSE\n", 2, "<string>" ],
+            [ eif => "<:eif\n:>", 3, "<string>", "" ],
+            [ content => "\n", 4, "<string>" ],
+            [ eof => "", 5, "<string>" ],
+           ], "tight cond");
+
+test_tokens("<:if Foo:>YES\n<:or Foo:>NO\n<:eif\nFoo:>\n",
+           [
+            [ if => "<:if Foo:>", 1, "<string>", "Foo", "" ],
+            [ content => "YES\n", 1, "<string>" ],
+            [ or => "<:or Foo:>", 2, "<string>", "Foo" ],
+            [ content => "NO\n", 2, "<string>" ],
+            [ eif => "<:eif\nFoo:>", 3, "<string>", "Foo" ],
+            [ content => "\n", 4, "<string>" ],
+            [ eof => "", 5, "<string>" ],
+           ], "loose cond");
+
+test_tokens("<:ifFoo args:><:if Bar more args:>",
+           [
+            [ if => "<:ifFoo args:>", 1, "<string>", "Foo", "args" ],
+            [ if => "<:if Bar more args:>", 1, "<string>", "Bar", "more args" ],
+            [ eof => "", 1, "<string>" ],
+           ], "tight cond");
+
+test_tokens("<:if!Foo bar:><:if!Foo:>",
+           [
+            [ ifnot => "<:if!Foo bar:>", 1, "<string>", "Foo", "bar"],
+            [ ifnot => "<:if!Foo:>", 1, "<string>", "Foo", ""],
+            [ eof => "", 1, "<string>" ],
+           ], "notcond");
+
+test_tokens("<:include notfoundfile:>",
+           [
+            [ error => "<:include notfoundfile:>", 1, "<string>",
+              "cannot find include notfoundfile in path" ],
+            [ eof => "", 1, "<string>" ],
+           ], "failed include");
+test_tokens("<:include notfoundfile optional:>",
+           [
+            [ eof => "", 1, "<string>" ],
+           ], "failed optional include");
+test_tokens("<:include notfoundfile optional:>abc",
+           [
+            [ content => "abc", 1, "<string>" ],
+            [ eof => "", 1, "<string>" ],
+           ], "failed optional include with following content");
+test_tokens("<:include included.include:>",
+           [
+            [ content => "y", 1, "t/templates/included.include" ],
+            [ eof => "", 1, "<string>" ],
+           ], "successful include");
+test_tokens("<:include included.recursive:>",
+           [
+            [ error => "<:include included.recursive:>", 1,
+              "t/templates/included.recursive", "Too many levels of includes" ],
+            [ eof => "", 1, "<string>" ],
+           ], "include loop");
+test_tokens(<<EOS,
+<:iterator begin foo test -:>
+stuff here
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo test -:>\n", 1, "<string>",
+              "foo", "test" ],
+            [ content => "stuff here\n", 2, "<string>" ],
+            [ itend => "<:iterator end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple iterator");
+
+test_tokens(<<EOS,
+<:iterator begin foo test -:>
+stuff here
+<:iterator separator foo:>
+more stuff
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo test -:>\n", 1, "<string>",
+              "foo", "test" ],
+            [ content => "stuff here\n", 2, "<string>" ],
+            [ itsep => "<:iterator separator foo:>", 3, "<string>", "foo" ],
+            [ content => "\nmore stuff\n", 3, "<string>" ],
+            [ itend => "<:iterator end foo:>", 5, "<string>", "foo" ],
+            [ content => "\n", 5, "<string>" ],
+            [ eof => "", 6, "<string>" ],
+           ], "iterator with sep");
+
+test_tokens(<<EOS,
+<:iterator begin foo:>
+stuff here
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo:>", 1, "<string>", "foo", "" ],
+            [ content => "\nstuff here\n", 1, "<string>" ],
+            [ itend => "<:iterator end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple iterator, no args");
+
+test_tokens(<<EOS,
+<:with begin foo:>
+stuff here
+<:with end foo:>
+EOS
+           [
+            [ withbegin => "<:with begin foo:>", 1, "<string>", "foo", "" ],
+            [ content => "\nstuff here\n", 1, "<string>" ],
+            [ withend => "<:with end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple with, no args");
+
+test_tokens(<<EOS,
+<:with begin foo blargh:>
+EOS
+           [
+            [ withbegin => "<:with begin foo blargh:>", 1, "<string>", "foo", "blargh" ],
+            [ content => "\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "simple with, with args");
+
+test_tokens(<<EOS,
+<:switch:>
+<:case Foo y -:>
+<:case Bar x:>
+<:case !Quux:>
+<:case !Qaax z:>
+<:case default:>
+<:endswitch -:>
+EOS
+           [
+            [ switch => "<:switch:>", 1, "<string>", "" ],
+            [ content => "\n", 1, "<string>" ],
+            [ case => "<:case Foo y -:>\n", 2, "<string>", "Foo", "y" ],
+            [ case => "<:case Bar x:>", 3, "<string>", "Bar", "x" ],
+            [ content => "\n", 3, "<string>" ],
+            [ casenot => "<:case !Quux:>", 4, "<string>", "Quux", "" ],
+            [ content => "\n", 4, "<string>" ],
+            [ casenot => "<:case !Qaax z:>", 5, "<string>", "Qaax", "z" ],
+            [ content => "\n", 5, "<string>" ],
+            [ case => "<:case default:>", 6, "<string>", "default", "" ],
+            [ content => "\n", 6, "<string>" ],
+            [ endswitch => "<:endswitch -:>\n", 7, "<string>", "" ],
+            [ eof => "", 8, "<string>" ],
+           ], "switch");
+
+test_tokens(<<EOS,
+<:wrap foo.tmpl a => 1, b => "2", c => [test]:>
+<:wrap bar.tmpl :>
+<:param a:>
+EOS
+           [
+            [ wrap => '<:wrap foo.tmpl a => 1, b => "2", c => [test]:>', 1, "<string>",
+              "foo.tmpl", 'a => 1, b => "2", c => [test]' ],
+            [ content => "\n", 1, "<string>" ],
+            [ wrap => '<:wrap bar.tmpl :>', 2, "<string>", "bar.tmpl", '' ],
+            [ content => "\n", 2, "<string>" ],
+            [ tag => "<:param a:>", 3, "<string>", "param", "a" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "top wrap");
+
+test_tokens(<<EOS,
+alpha <:wrap here:> beta
+EOS
+           [
+            [ content => "alpha ", 1, "<string>" ],
+            [ wraphere => "<:wrap here:>", 1, "<string>" ],
+            [ content => " beta\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "wrap here");
+
+test_tokens("<:= some expression:>",
+           [
+            [ expr => "<:= some expression:>", 1, "<string>", "some expression", "" ],
+            [ eof => "", 1, "<string>" ],
+           ], "expr tag");
+
+test_tokens("<: .set varname = some value:>",
+           [
+            [ set => "<: .set varname = some value:>", 1, "<string>", "varname", "some value" ],
+            [ eof => "", 1, "<string>" ],
+           ], "set tag");
+test_tokens("<:.if some.expression:>",
+           [
+            [ ext_if => "<:.if some.expression:>", 1, "<string>", "some.expression" ],
+            [ eof => "", 1, "<string>" ],
+           ], ".if tag");
+
+test_tokens("<:.define some/code:>",
+           [
+            [ define => "<:.define some/code:>", 1, "<string>", "some/code" ],
+            [ eof => "", 1, "<string>" ],
+           ], ".define tag");
+
+test_tokens("<:.call some/code, a=1, b=2:><:.call other :>",
+           [
+            [ call => "<:.call some/code, a=1, b=2:>", 1, "<string>", "some/code, a=1, b=2" ],
+            [ call => "<:.call other :>", 1, "<string>", "other" ],
+            [ eof => "", 1, "<string>" ],
+           ], ".define tag");
+
+test_tokens("<:.end:><:.end if:>",
+           [
+            [ end => "<:.end:>", 1, "<string>", "" ],
+            [ end => "<:.end if:>", 1, "<string>", "if" ],
+            [ eof => "", 1, "<string>" ],
+           ], ".end tag");
+
+test_tokens(<<EOS,
+<: rubbish
+EOS
+           [
+            [ error => "<: rubbish\n", 1, "<string>", "Unclosed tag 'rubbish'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag with name");
+
+test_tokens(<<EOS,
+<:
+EOS
+           [
+            [ error => "<:\n", 1, "<string>", "Unclosed tag '(no name found)'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag without name");
+
+test_tokens(<<EOS,
+some content <:
+EOS
+           [
+            [ content => "some content ", 1, "<string>" ],
+            [ error => "<:\n", 1, "<string>", "Unclosed tag '(no name found)'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag without name, with some content before");
+
+test_tokens(<<EOS,
+<:iterator xbegin foo:>
+EOS
+           [
+            [ error => "<:iterator xbegin foo:>", 1, "<string>", "Syntax error: incorrect use of 'iterator'" ],
+            [ content => "\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "syntax error - bad use of reserved word with bad syntax");
+
+test_tokens(<<EOS,
+<:*&:>
+<:*&*&*&*&*&*&*&*&*&*&*&:>
+EOS
+           [
+            [ error => "<:*&:>", 1, "<string>", "Syntax error: unknown tag start '*&'" ],
+            [ content => "\n", 1, "<string>" ],
+            [ error => "<:*&*&*&*&*&*&*&*&*&*&*&:>", 2, "<string>", "Syntax error: unknown tag start '*&*&*&*&*&*&*&*&*...'" ],
+            [ content => "\n", 2, "<string>" ],
+            [ eof => "", 3, "<string>" ],
+           ], "syntax error - unknown tag start");
+
+test_tokens(<<EOS,
+<:# some comment text:>
+<:#
+  multi-line
+  comment
+:>
+EOS
+           [
+            [ comment => "<:# some comment text:>", 1, "<string>", "some comment text" ],
+            [ content => "\n", 1, "<string>" ],
+            [ comment => "<:#\n  multi-line\n  comment\n:>", 2, "<string>",
+              "multi-line\n  comment" ],
+            [ content => "\n", 5, "<string>" ],
+            [ eof => "", 6, "<string>" ],
+           ], "comment");
+
+sub test_tokens($$$) {
+  my ($text, $tokens, $name) = @_;
+
+  my $tmpl = Squirrel::Template->new(template_dir=>'t/templates');
+  my $tok = Squirrel::Template::Tokenizer->new($text, "<string>", $tmpl);
+
+  my @rtokens;
+  while (my $token = $tok->get) {
+    push @rtokens, $token;
+  }
+  #use Data::Dumper;
+  #diag(Dumper \@rtokens);
+  my $result = 1;
+  my $tb= Test::Builder->new;
+  my $cmp_index = @rtokens < @$tokens ? $#rtokens : $#$tokens;
+  CMP: for my $i (0 .. $cmp_index) {
+    my $fe = _format_token($tokens->[$i]);
+    my $ff = _format_token($rtokens[$i]);
+    if ($fe ne $ff) {
+      $result = $tb->ok(0, $name);
+      diag(<<EOS);
+Mismatch at index $i:
+Expected: $fe
+Found   : $ff
+EOS
+      last CMP;
+    }
+  }
+  if ($result) {
+    if (@rtokens < @$tokens) {
+      $result = $tb->ok(0, $name);
+      my $fe = _format_token($tokens->[$cmp_index+1]);
+      diag(<<EOS)
+Found shorter than expected:
+Expected: $fe
+Found   : no entry
+EOS
+    }
+    elsif (@rtokens > @$tokens) {
+      $result = $tb->ok(0, $name);
+      my $ff = _format_token($rtokens[$cmp_index+1]);
+      diag(<<EOS)
+Found longer than expected:
+Expected: no entry
+Found   : $ff
+EOS
+    }
+  }
+  if ($result) {
+    $tb->ok(1, $name);
+  }
+  #print "F: ", _format_token($_), "\n" for @rtokens;
+  #print "E: ", _format_token($_), "\n" for @$tokens;
+
+  #is_deeply(\@rtokens, $tokens, $name);
+
+  return $result;
+}
+
+sub _format_token {
+  my ($token) = @_;
+
+  if (!$token) {
+    return "undef";
+  }
+  else {
+    my $result = "[ {" . join('}{', @$token) . "} ]";
+    $result =~ s/\n/\\n/g;
+    return $result;
+  }
+}
diff --git a/t/020-templater/020-parse.t b/t/020-templater/020-parse.t
new file mode 100644 (file)
index 0000000..6033753
--- /dev/null
@@ -0,0 +1,439 @@
+#!perl -w
+use strict;
+use Test::More tests => 37;
+use Squirrel::Template;
+
+sub test_parse($$$);
+
+{
+  # test the API
+  my $templater = Squirrel::Template->new();
+  my $t = Squirrel::Template::Tokenizer->new(<<EOS, "<text>", $templater);
+test <:foo bar:><:with end bar:><:with unknown:>
+EOS
+  my $p = Squirrel::Template::Parser->new($t, $templater);
+  ok($p, "make a parser");
+  my $tree = $p->parse;
+  is_deeply($tree,
+           [ comp => "", 1, "<text>",
+             [ content => "test ", 1, "<text>" ],
+             [ tag => "<:foo bar:>", 1, "<text>", "foo", "bar" ],
+             [ error => "<:with end bar:>", 1, "<text>", "Expected eof but found withend" ],
+             [ error => "<:with unknown:>", 1, "<text>", "Syntax error: incorrect use of 'with'" ],
+             [ content => "\n", 1, "<text>" ],
+           ], "check parse result");
+  is_deeply([ $p->errors ],
+           [
+             [ error => "<:with end bar:>", 1, "<text>", "Expected eof but found withend" ],
+            [ error => "<:with unknown:>", 1, "<text>", "Syntax error: incorrect use of 'with'" ],
+           ], "check errors");
+}
+
+test_parse(<<EOS,
+simple text
+EOS
+          [ "content", "simple text\n", 1, "<string>" ], "simple");
+
+test_parse(<<EOS,
+tag test <:sometag foo -:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ content => "tag test ", 1, "<string>" ],
+            [ tag => "<:sometag foo -:>\n", 1, "<string>", "sometag", "foo" ]
+          ], "simple tag");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or:>FALSE<:eif -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ content => "FALSE", 1, "<string>" ],
+            [ or => "<:or:>", 1, "<string>", '' ],
+            [ eif => "<:eif -:>\n", 1, "<string>", '' ],
+          ], "simple cond");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or Foo:>FALSE<:eif Foo -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ content => "FALSE", 1, "<string>" ],
+            [ or => "<:or Foo:>", 1, "<string>", 'Foo' ],
+            [ eif => "<:eif Foo -:>\n", 1, "<string>", 'Foo' ],
+          ], "named cond with named or/eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:eif -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ eif => "<:eif -:>\n", 1, "<string>", "" ],
+          ], "simple cond, no else");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or -:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ or => "<:or -:>\n", 1, "<string>", '' ],
+              [ eif => "<:eif:>", 2, "<string>" ], # synthesized
+            ],
+            [ error => "", 2, "<string>", "Expected 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE\n", 1, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ eif => "", 2, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'or' or 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or Bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "\n", 1, "<string>" ],
+              [ or => "<:or Bar:>", 1, "<string>", "Bar" ],
+              [ eif => "<:eif:>", 2, "<string>" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'or Bar'" ],
+            [ error => "", 2, "<string>", "Expected 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse("<:if Foo:>TRUE<:or Bar:>FALSE<:eif:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "FALSE", 1, "<string>" ],
+              [ or => "<:or Bar:>", 1, "<string>", "Bar" ],
+              [ eif => "<:eif:>", 1, "<string>", "" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'or Bar'" ],
+          ], "if with or name mismatch");
+
+test_parse("<:if Foo:>TRUE<:or:>FALSE<:eif Bar:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "FALSE", 1, "<string>" ],
+              [ or => "<:or:>", 1, "<string>", "" ],
+              [ eif => "<:eif Bar:>", 1, "<string>", "Bar" ],
+            ],
+            [ error => "", 1, "<string>", "'eif' for 'if Foo' starting <string>:1 expected but found 'eif Bar'" ],
+          ], "if with or, eif name mismatch");
+
+test_parse("<:if Foo:>TRUE<:eif Bar:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ eif => "<:eif Bar:>", 1, "<string>", "Bar" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'eif Bar'" ],
+          ], "if with no or, eif name mismatch");
+
+test_parse("<:if Foo:>TRUE<:eif Foo:>",
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ eif => "<:eif Foo:>", 1, "<string>", "Foo" ],
+          ], "if with no or, eif name matches");
+
+test_parse("<:if !Foo:>TRUE<:eif:>",
+          [ condnot => "<:if !Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            undef, undef,
+            [ eif => "<:eif:>", 1, "<string>", "" ],
+          ], "if! base");
+
+test_parse("<:if !Foo:>TRUE<:eif Foo:>",
+          [ condnot => "<:if !Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            undef, undef,
+            [ eif => "<:eif Foo:>", 1, "<string>", "Foo" ],
+          ], "if! with labelled eif");
+
+test_parse("<:if !Foo:>TRUE<:eif Bar:>",
+          [ comp => "", 1, "<string>",
+            [ condnot => "<:if !Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              undef, undef,
+              [ eif => "<:eif Bar:>", 1, "<string>", "Bar" ],
+            ],
+            [ error => "", 1, "<string>", "'eif' for 'if !Foo' starting <string>:1 expected but found 'eif Bar'" ],
+          ], "if! with mis-labelled eif");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ itend => "\n<:- iterator end foo:>", 1, "<string>", "foo" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple iterator");
+
+test_parse(<<EOS,
+<:iterator begin foo [bar]:>LOOP
+<:- iterator separator foo:>SEP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo [bar]:>", 1, "<string>", "foo", "[bar]",
+              [ content => "LOOP", 1, "<string>" ],
+              [ content => "SEP", 2, "<string>" ],
+              [ itsep => "\n<:- iterator separator foo:>", 1, "<string>", "foo" ],
+              [ itend => "\n<:- iterator end foo:>", 2, "<string>", "foo" ],
+            ],
+            [ content => "\n", 3, "<string>" ]
+          ], "iterator with sep");
+
+test_parse(<<EOS,
+<:iterator begin foo [bar]:>LOOP
+<:- iterator separator bar:>SEP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo [bar]:>", 1, "<string>", "foo", "[bar]",
+              [ content => "LOOP", 1, "<string>" ],
+              [ content => "SEP", 2, "<string>" ],
+              [ itsep => "\n<:- iterator separator bar:>", 1, "<string>", "bar" ],
+              [ itend => "\n<:- iterator end foo:>", 2, "<string>", "foo" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'iterator separator foo' for 'iterator begin foo' at <string>:1 but found 'iterator separator bar'" ],
+            [ content => "\n", 3, "<string>" ]
+          ], "iterator with sep with name mismatch");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:- iterator end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ itend => "\n<:- iterator end bar:>", 1, "<string>", "bar" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found 'iterator end bar'" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple iterator, name mismatch");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+MORE
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\nMORE\n", 1, "<string>" ],
+              [ empty => "", 3, "<string>" ],
+              [ empty => "", 3, "<string>" ],
+              [ itend => "<:iterator end foo:>", 3, "<string>" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator separator foo' or 'iterator end foo' for 'iterator begin foo' at <string>:1 but found eof" ],
+          ], "simple iterator, unterminated");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:iterator separator foo:>MORE
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ content => "MORE\n", 2, "<string>" ],
+              [ itsep => "<:iterator separator foo:>", 2, "<string>", "foo" ],
+              [ itend => "<:iterator end foo:>", 3, "<string>" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found eof" ],
+          ], "iterator with separator, unterminated");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:iterator separator foo:>MORE
+<:iterator end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ content => "MORE\n", 2, "<string>" ],
+              [ itsep => "<:iterator separator foo:>", 2, "<string>", "foo" ],
+              [ itend => "<:iterator end bar:>", 3, "<string>", "bar" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found 'iterator end bar'" ],
+            [ content => "\n", 3, "<string>" ],
+          ], "iterator with separator, name mismatch on end");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+<:- with end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ withend => "\n<:- with end foo:>", 1, "<string>", "foo" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple wwith");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+<:- with end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ withend => "\n<:- with end bar:>", 1, "<string>", "bar" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'with end foo' for 'with begin foo' at <string>:1 but found 'with end bar'" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple with, name mismatch");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ withend => "<:with end foo:>", 2, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'with end foo' for 'with begin foo' at <string>:1 but found eof" ],
+          ], "simple with, unterminated");
+
+test_parse(<<EOS,
+<:switch:>IGNORED
+<:case Foo:>FOO
+<:case Bar x:>BAR
+<:case default:>DEFAULT
+<:endswitch:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ switch => "<:switch:>", 1, "<string>", "",
+              [ 
+               [ 
+                [ case => "<:case Foo:>", 2, "<string>", "Foo", "" ],
+                [ content => "FOO\n", 2, "<string>" ],
+               ],
+               [
+                [ case => "<:case Bar x:>", 3, "<string>", "Bar", "x" ],
+                [ content => "BAR\n", 3, "<string>" ],
+               ],
+               [
+                [ case => "<:case default:>", 4, "<string>", "default", "" ],
+                [ content => "DEFAULT\n", 4, "<string>" ],
+               ],
+              ],
+              [ endswitch => "<:endswitch:>", 5, "<string>", "" ],
+            ],
+            [ content => "\n", 5, "<string>" ]
+          ], "simple switch");
+
+test_parse("<:switch:><:case Foo:>",
+          [ comp => "", 1, "<string>",
+            [ switch => "<:switch:>", 1, "<string>", "",
+              [
+               [
+                [ case => "<:case Foo:>", 1, "<string>", "Foo", "" ],
+                [ empty => "", 1, "<string>" ],
+               ]
+              ],
+              [ endswitch => "<:endswitch:>", 1, "<string>" ],
+            ],
+            [ error => "", 1, "<string>", "Expected case or endswitch for switch starting <string>:1 but found eof" ],
+          ], "unterminated switch");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+EOS
+          [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+            'base.tmpl', 'foo => "1"',
+            [ content => "WRAPPED\n", 1, "<string>" ],
+          ], "endless wrap");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+<:endwrap:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+              'base.tmpl', 'foo => "1"',
+              [ content => "WRAPPED\n", 1, "<string>" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "ended wrap");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+<:with end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+              'base.tmpl', 'foo => "1"',
+              [ content => "WRAPPED\n", 1, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'endwrap' or eof for wrap started <string>:1 but found withend" ],
+            [ error => "<:with end foo:>", 2, "<string>", "Expected eof but found withend" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "badly terminated wrap");
+
+test_parse("abc <:with end foo:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ error => "<:with end foo:>", 1, "<string>", "Expected eof but found withend" ],
+            [ content => " def", 1, "<string>" ],
+          ], "with end without with");
+
+test_parse("abc <:*&:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ error => "<:*&:>", 1, "<string>", "Syntax error: unknown tag start '*&'" ],
+            [ content => " def", 1, "<string>" ],
+          ], "passthrough of error tokens");
+
+test_parse("abc <:# some comment:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ content => " def", 1, "<string>" ],
+          ], "comment tags are dropped");
+
+test_parse("abc <:wrap here:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ wraphere => "<:wrap here:>", 1, "<string>" ],
+            [ content => " def", 1, "<string>" ],
+          ], "wrap here");
+
+sub test_parse($$$) {
+  my ($text, $parse, $name) = @_;
+
+  my $tmpl = Squirrel::Template->new();
+  my $tok = Squirrel::Template::Tokenizer->new($text, "<string>", $tmpl);
+  my $parser = Squirrel::Template::Parser->new($tok, $tmpl);
+
+  my $rtree = $parser->parse;
+
+  use Data::Dumper;
+$Data::Dumper::Indent = 0;
+print Dumper($rtree), "\n", Dumper($parse), "\n";
+
+  print Squirrel::Template::Deparser->deparse($rtree), "\n";
+
+  return is_deeply($rtree, $parse, $name);
+}
diff --git a/t/020-templater/030-expr.t b/t/020-templater/030-expr.t
new file mode 100644 (file)
index 0000000..50ef25e
--- /dev/null
@@ -0,0 +1,221 @@
+#!perl -w
+use strict;
+use Squirrel::Template::Expr;
+use Test::More tests => 18;
+use Data::Dumper;
+
+test_tok("abc",
+        [
+         [ id => "abc", "abc" ],
+         [ eof => "" ],
+        ], "simple id");
+
+test_tok("a.b + 1.0",
+        [
+         [ id => "a", "a" ],
+         [ "op." => "." ],
+         [ id => "b ", "b" ],
+         [ "op+" => "+ " ],
+         [ num => "1.0", "1.0" ],
+         [ eof => "" ],
+        ], "simple expr");
+
+test_tok("1 .1 1e+10 .1e-10 5e2 0xff 0b101 0o11",
+        [
+         [ num => "1 ", 1 ],
+         [ num => ".1 ", ".1" ],
+         [ num => "1e+10 ", "1e+10" ],
+         [ num => ".1e-10 ", ".1e-10" ],
+         [ num => "5e2 ", "5e2" ],
+         [ num => "0xff ", 255 ],
+         [ num => "0b101 ", 5 ],
+         [ num => "0o11", 9 ],
+         [ eof => "" ],
+        ], "numbers");
+
+test_tok('"-\n-\"-\N{LATIN CAPITAL LETTER A}-\x41-\x{0041}-"',
+        [
+         [ str => '"-\n-\"-\N{LATIN CAPITAL LETTER A}-\x41-\x{0041}-"', 
+           "-\n-\"-A-A-A-" ],
+         [ eof => "" ],
+        ], "string with escapes");
+
+test_tok(" 'abc' ",
+        [
+         [ str => " 'abc' ", 'abc' ],
+         [ eof => "" ],
+        ], "no escape strings");
+
+test_tok("+ - == != > >= < <= eq ne lt le gt ge . _",
+        [
+         [ "op+" => "+ " ],
+         [ "op-" => "- " ],
+         [ "op==" => "== " ],
+         [ "op!=" => "!= " ],
+         [ "op>" => "> " ],
+         [ "op>=", => ">= " ],
+         [ "op<", "< " ],
+         [ "op<=", "<= " ],
+         [ "opeq" => "eq " ],
+         [ "opne" => "ne " ],
+         [ "oplt" => "lt " ],
+         [ "ople" => "le " ],
+         [ "opgt" => "gt " ],
+         [ "opge" => "ge " ],
+         [ "op." => ". " ],
+         [ "op_" => "_" ],
+         [ eof => "" ],
+        ], "operators");
+
+test_parse("1+1",
+          [ "add",
+            [ const => 1 ],
+            [ const => 1 ],
+          ], "add");
+
+test_parse("a+b*c",
+          [ "add",
+            [ var => "a" ],
+            [ "mult",
+              [ var => "b" ],
+              [ var => "c" ],
+            ]
+          ], "bin + and *");
+
+test_parse("a-b/c",
+          [ "subtract",
+            [ var => "a" ],
+            [ "fdiv",
+              [ var => "b" ],
+              [ var => "c" ],
+            ]
+          ], "bin - and /");
+
+test_parse("a div b mod c",
+          [ "mod",
+            [ "div",
+              [ var => "a" ],
+              [ var => "b" ],
+            ],
+            [ var => "c" ],
+          ], "div and mod");
+
+test_parse("a/(b*c)",
+          [ "fdiv",
+            [ var => "a" ],
+            [ "mult",
+              [ var => "b" ],
+              [ var => "c" ],
+            ]
+          ], "() precedence");
+
+test_parse("a _ 'abc'",
+          [ "concat",
+            [ var => "a" ],
+            [ const => "abc" ],
+          ], "string concat");
+
+test_parse("a[b]",
+          [ "subscript",
+            [ var => "a" ],
+            [ var => "b" ],
+          ], "subscript");
+
+test_parse("+a * -b",
+          [ "mult",
+            [ var => "a" ],
+            [ uminus =>
+              [ var => "b" ],
+            ]
+          ], "uminus/plus");
+
+test_parse("!a and not b or c < d",
+          [ "or",
+            [ and =>
+              [ not =>
+                [ var => "a" ],
+              ],
+              [ not =>
+                [ var => "b" ],
+              ],
+            ],
+            [ "nlt" =>
+              [ var => "c" ],
+              [ var => "d" ],
+            ]
+          ], "boolean and rel ops");
+
+test_parse("[ a, b .. c, d ]",
+          [ "list",
+            [
+             [ var => "a" ],
+             [ range =>
+               [ var => "b" ],
+               [ var => "c" ],
+             ],
+             [ var => "d" ],
+            ],
+          ], "list with range");
+
+
+test_parse("a.b.c().d(1).e(1,2)",
+          [ call =>
+            "e",
+            [ call =>
+              "d",
+              [ call =>
+                "c",
+                [ call =>
+                  "b",
+                  [ var => "a" ],
+                  [ ]
+                ],
+                []
+              ],
+              [
+               [ const => 1 ]
+              ]
+            ],
+            [
+             [ const => 1 ],
+             [ const => 2 ],
+            ]
+          ], "method calls");
+
+test_parse('a.b =~ /a.*\/b/',
+          [ "match" =>
+            [ call =>
+              "b",
+              [ var => "a" ],
+              []
+            ],
+            [ const => qr(a.*\/b) ],
+          ], "regexp match");
+
+sub test_tok {
+  my ($str, $tokens, $name) = @_;
+
+  my $tok = Squirrel::Template::Expr::Tokenizer->new($str);
+  my @result;
+  while (my $t = $tok->get) {
+    push @result, $t;
+  }
+
+  unless(is_deeply(\@result, $tokens, $name)) {
+    print Dumper \@result;
+  }
+}
+
+sub test_parse {
+  my ($str, $expr, $name) = @_;
+
+  eval {
+    my $parser = Squirrel::Template::Expr::Parser->new;
+    my $got = $parser->parse($str);
+    unless (is_deeply($got, $expr, $name)) {
+      print Dumper($got);
+    }
+  } and return 1;
+  fail($name);
+  diag Dumper($@);
+}
diff --git a/t/020-templater/040-original.t b/t/020-templater/040-original.t
new file mode 100644 (file)
index 0000000..805c40c
--- /dev/null
@@ -0,0 +1,680 @@
+#!perl -w
+# Basic tests for Squirrel::Template
+use strict;
+use Test::More tests => 112;
+
+sub template_test($$$$;$$);
+
+my $gotmodule = require_ok('Squirrel::Template');
+
+SKIP: {
+  skip "couldn't load module", 15 unless $gotmodule;
+
+  my $flag = 0;
+  my $str = "ABC";
+  my $str2 = "DEF";
+  my ($repeat_limit, $repeat_value);
+
+  my %acts =
+    (
+     ifEq => \&tag_ifeq,
+     iterate_repeat_reset =>
+     [ \&iter_repeat_reset, \$repeat_limit, \$repeat_value ],
+     iterate_repeat =>
+     [ \&iter_repeat, \$repeat_limit, \$repeat_value ],
+     repeat => \$repeat_value,
+     strref => \$str,
+     str => $str,
+     str2 => $str2,
+     with_upper => \&tag_with_upper,
+     cat => \&tag_cat,
+     ifFalse => 0,
+     dead => sub { die "foo\n" },
+     noimpl => sub { die "ENOIMPL\n" },
+    );
+  my %vars =
+    (
+     a =>
+     {
+      b =>
+      {
+       c => "CEE"
+      }
+     },
+     str => $str,
+     somelist => [ 'a' .. 'f' ],
+     somehash => { qw(a 11 b 12 c 14 e 8) },
+     num1 => 101,
+     num2 => 202,
+     testclass => Squirrel::Template::Expr::WrapClass->new("TestClass"),
+     error =>
+     {
+      noimpl => sub { die "ENOIMPL\n" },
+     },
+    );
+  template_test("<:str:>", "ABC", "simple", \%acts);
+  template_test("<:strref:>", "ABC", "scalar ref", \%acts);
+  $str = "DEF";
+  template_test("<:strref:>", "DEF", "scalar ref2", \%acts);
+  template_test(<<TEMPLATE, "12345", "iterate", \%acts, "in");
+<:iterator begin repeat 1 5:><:repeat:><:iterator end repeat:>
+TEMPLATE
+  template_test(<<TEMPLATE, "1|2|3|4|5", "iterate sep", \%acts, "in");
+<:iterator begin repeat 1 5:><:repeat:><:
+iterator separator repeat:>|<:iterator end repeat:>
+TEMPLATE
+  template_test('<:ifEq [str] "ABC":>YES<:or:>NO<:eif:>', "YES", 
+               "cond1", \%acts);
+  template_test('<:if Eq [str] "ABC":>YES<:or Eq:>NO<:eif Eq:>', "YES", 
+               "cond2", \%acts);
+  template_test("<:dead:>", "* foo\n *", "dead", \%acts);
+  template_test("<:noimpl:>", "<:noimpl:>", "noimpl", \%acts);
+  template_test("<:unknown:>", "<:unknown:>", "unknown tag", \%acts);
+  template_test("<:ifDead:><:str:><:or:><:str2:><:eif:>",
+               "* foo\n *<:ifDead:>ABC<:or:>DEF<:eif:>", "ifDead", \%acts);
+  template_test("<:ifNoimpl:><:str:><:or:><:str2:><:eif:>",
+               "<:ifNoimpl:>ABC<:or:>DEF<:eif:>", "ifNoimpl", \%acts);
+
+  template_test("<:if!False:>FOO<:eif:>", "FOO", "if!False", \%acts);
+  template_test("<:if !False:>FOO<:eif:>", "FOO", "if !False", \%acts);
+  template_test("<:if!Str:>FOO<:eif:>", "", "if!Str", \%acts);
+  template_test("<:if!Dead:><:str:><:eif:>",
+               "* foo\n *<:if!Dead:>ABC<:eif:>", "if!Dead", \%acts);
+  template_test("<:if!Noimpl:><:str:><:eif:>",
+               "<:if!Noimpl:>ABC<:eif:>", "if!Noimpl", \%acts);
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "in");
+<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
+<:param menu:>
+<:param showtitle:>
+TEMPLATE
+<title>foo ABC</title>
+Alpha
+1
+abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "both");
+Before
+<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" -:>
+Alpha
+<:param menu:>
+<:param showtitle:>
+<:-endwrap-:>
+After
+TEMPLATE
+Before
+<title>foo ABC</title>
+Alpha
+1
+abc
+After
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap with too much parameter text", \%acts, "in");
+<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" junk :>Alpha
+<:param menu:>
+<:param showtitle:>
+TEMPLATE
+* WARNING: Extra data after parameters ' junk' *<title>foo ABC</title>
+Alpha
+1
+abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap recursive", \%acts, "both");
+<:wrap wrapself.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
+<:param menu:>
+<:param showtitle:>
+TEMPLATE
+* Error starting wrap: Too many levels of wrap for 'wrapself.tmpl' *<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+Alpha
+1
+abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap unknown", \%acts, "both");
+<:wrap unknown.tmpl:>
+Body
+TEMPLATE
+* Loading wrap: File unknown.tmpl not found *
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "unwrapped wrap here", \%acts, "both");
+before
+<:wrap here:>
+after
+TEMPLATE
+before
+* wrap here without being wrapped *
+after
+OUTPUT
+
+  # undefined iterator - replacement should happen on the inside
+  template_test(<<TEMPLATE, <<OUTPUT, "undefined iterator", \%acts);
+<:iterator begin unknown:>
+<:if Eq "1" "1":>TRUE<:or:>FALSE<:eif:>
+<:iterator separator unknown:>
+<:if Eq "1" "0":>TRUE<:or:>FALSE<:eif:>
+<:iterator end unknown:>
+TEMPLATE
+<:iterator begin unknown:>
+TRUE
+<:iterator separator unknown:>
+FALSE
+<:iterator end unknown:>
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "multi wrap", \%acts, "in");
+<:wrap wrapinner.tmpl title => "ABC":>
+Test
+TEMPLATE
+<title>ABC</title>
+
+<head1>ABC</head1>
+
+Test
+OUTPUT
+
+  my $switch = <<IN;
+<:switch:>ignored<:case Eq [strref] "ABC":>ONE<:case Eq [strref] "XYZ":>TWO<:
+case default:>DEF<:endswitch:>
+IN
+  $str = "ABC";
+  template_test($switch, "ONE", "switch1", \%acts, "both");
+  $str = "XYZ";
+  template_test($switch, "TWO", "switch2", \%acts, "both");
+  $str = "DEF";
+  template_test($switch, "DEF", "switch def", \%acts, "both");
+
+  my $switch2 = <<IN;
+<:switch:><:case Eq [strref] "ABC":>ONE<:case Eq [strref] "XYZ":>TWO<:
+case default:>DEF<:endswitch:>
+IN
+  $str = "ABC";
+  template_test($switch2, "ONE", "switch without ignored", \%acts, "both");
+
+  template_test(<<IN, <<OUT, "unimplemented switch (by die)", \%acts, "both");
+<foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Eq [unknown] "ABC":><:endswitch:>
+IN
+<foo>ABC</foo><:switch:><:case Eq [unknown] "ABC":><:endswitch:>
+OUT
+
+  template_test(<<IN, <<OUT, "unimplemented switch (by missing)", \%acts, "both");
+<foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Unknown:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
+IN
+<foo>ABC</foo><:switch:><:case Unknown:>ABC<:case Eq [unknown] "ABC":>DEF<:endswitch:>
+OUT
+
+  template_test(<<IN, <<OUT, "switch with die in case and unknown", \%acts, "both");
+<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
+IN
+* foo
+ *<:switch:><:case Eq [unknown] "ABC":>DEF<:endswitch:>
+OUT
+
+  template_test(<<IN, <<OUT, "switch with die no matches", \%acts, "both");
+<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case False:><:str2:><:endswitch:>
+IN
+* foo
+ *
+OUT
+
+  template_test(<<IN, <<OUT, "switch with case !", \%acts, "both");
+<:switch:><:case !Str:>NOT STR<:case !False:>FALSE<:endswitch:>
+IN
+FALSE
+OUT
+
+  template_test("<:with begin upper:>Alpha<:with end upper:>", "ALPHA", "with", \%acts);
+
+  template_test("<:with begin unknown:>Alpha<:str:><:with end unknown:>", <<EOS, "with", \%acts, "out");
+<:with begin unknown:>AlphaABC<:with end unknown:>
+EOS
+
+  template_test("<:include doesnt/exist optional:>", "", "optional include", \%acts);
+  template_test("<:include doesnt/exist:>", "* cannot find include doesnt/exist in path *", "failed include", \%acts);
+  template_test("x<:include included.include:>z", "xyz", "include", \%acts);
+
+  template_test <<IN, <<OUT, "nested in undefined if", \%acts;
+<:if Unknown:><:if Eq "1" "1":>Equal<:or Eq:>Not Equal<:eif Eq:><:or Unknown:>false unknown<:eif Unknown:>
+IN
+<:if Unknown:>Equal<:or Unknown:>false unknown<:eif Unknown:>
+OUT
+  template_test <<IN, <<OUT, "nested in undefined switch case", \%acts;
+<:switch:>
+<:case ifUnknown:><:if Eq 1 1:>Equal<:or Eq:>Unequal<:eif Eq:>
+<:endswitch:>
+IN
+<:switch:><:case ifUnknown:>Equal
+<:endswitch:>
+OUT
+
+  { # using - for removing whitespace
+    template_test(<<IN, <<OUT, "space value", \%acts, "both");
+<foo>
+<:-str-:>
+</foo>
+<foo>
+<:str-:>
+</foo>
+<foo>
+<:str:>
+</foo>
+IN
+<foo>ABC</foo>
+<foo>
+ABC</foo>
+<foo>
+ABC
+</foo>
+OUT
+
+    template_test(<<IN, <<OUT, "space simple cond", \%acts, "both");
+<foo>
+<:-ifStr:>TRUE<:or-:><:eif-:>
+</foo>
+<foo2>
+<:-ifStr-:>
+TRUE
+<:-or:><:eif-:>
+</foo2>
+<foo3>
+<:-ifStr-:>
+TRUE
+<:-or-:>
+<:-eif-:>
+</foo3>
+<foo4>
+<:-ifFalse-:>TRUE<:-or-:>FALSE<:-eif-:>
+</foo4>
+<foo5>
+<:-ifFalse-:>
+TRUE
+<:-or-:>
+FALSE
+<:-eif-:>
+</foo5>
+<foo6>
+<:ifFalse:>
+TRUE
+<:or:>
+FALSE
+<:eif:>
+</foo6>
+IN
+<foo>TRUE</foo>
+<foo2>TRUE</foo2>
+<foo3>TRUE</foo3>
+<foo4>FALSE</foo4>
+<foo5>FALSE</foo5>
+<foo6>
+
+FALSE
+
+</foo6>
+OUT
+
+    template_test(<<IN, <<OUT, "space iterator", \%acts, "both");
+<foo>
+<:-iterator begin repeat 1 5 -:>
+<:-repeat-:>
+<:-iterator end repeat -:>
+</foo>
+<foo2>
+<:-iterator begin repeat 1 5 -:>
+<:-repeat-:>
+<:-iterator separator repeat -:>
+,
+<:-iterator end repeat -:>
+</foo2>
+IN
+<foo>12345</foo>
+<foo2>1,2,3,4,5</foo2>
+OUT
+
+    template_test(<<IN, <<OUT, "space switch", \%acts, "both");
+<foo>
+<:- switch:>
+
+ <:- case default:>FOO
+<:- endswitch:>
+</foo>
+IN
+<foo>FOO
+</foo>
+OUT
+
+    template_test(<<IN, <<OUT, "space complex", \%acts, "both");
+<div class="window">
+  <h1><:str:></h1>
+  <ul class="children list">
+    <:iterator begin repeat 1 2:>
+    <:- switch:>
+    <:- case False:>
+    <li class="error message"><:repeat:></li>
+    <:case str:>
+  </ul>
+  <h2><:repeat:></h2>
+  <ul class="children list">
+    <:- case default:>
+    <li><:repeat:></li>
+    <:- endswitch:>
+    <:iterator end repeat:>
+  </ul>
+</div>
+IN
+<div class="window">
+  <h1>ABC</h1>
+  <ul class="children list">
+    
+  </ul>
+  <h2>1</h2>
+  <ul class="children list">
+    
+  </ul>
+  <h2>2</h2>
+  <ul class="children list">
+    
+  </ul>
+</div>
+OUT
+  }
+
+  template_test("<:= unknown :>", "<:= unknown :>", "unknown", \%acts, "", \%vars);
+  template_test(<<TEMPLATE, "2", "multi-statement", \%acts, "", \%vars);
+<:.set foo = [] :><:% foo.push(1); foo.push(2) :><:= foo.size() -:>
+TEMPLATE
+
+  template_test(<<TEMPLATE, "2", "multi-statement no ws", \%acts, "", \%vars);
+<:.set foo=[]:><:%foo.push(1);foo.push(2):><:= foo.size() -:>
+TEMPLATE
+
+  template_test("<:= str :>", "ABC", "simple exp", \%acts, "", \%vars);
+  template_test("<:=str:>", "ABC", "simple exp no ws", \%acts, "", \%vars);
+  template_test("<:= a.b.c :>", "CEE", "hash methods", \%acts, "", \%vars);
+  template_test(<<IN, <<OUT, "simple set", \%acts, "both", \%vars);
+<:.set d = "test" -:><:= d :>
+IN
+test
+OUT
+  my @expr_tests =
+    (
+     [ 'num1 + num2', 303 ],
+     [ 'num1 - num2', -101 ],
+     [ 'num1 + num2 * 2', 505 ],
+     [ 'num2 mod 5', '2' ],
+     [ 'num1 / 5', '20.2' ],
+     [ 'num1 div 5', 20 ],
+     [ '+num1', 101 ],
+     [ '-(num1 + num2)', -303 ],
+     [ '"hello " _ str', 'hello ABC' ],
+     [ 'num1 < num2', 1 ],
+     [ 'num1 < 101', '' ],
+     [ 'num1 < 100', '' ],
+     [ 'num1 > num2', '' ],
+     [ 'num2 > num1', 1 ],
+     [ 'num1 > 101', '' ],
+     [ 'num1 == 101.0', '1' ],
+     [ 'num1 == 101', '1' ],
+     [ 'num1 == 100', '' ],
+     [ 'num1 != 101', '' ],
+     [ 'num1 != "101.0"', '' ],
+     [ 'num1 != 100', 1 ],
+     [ 'num1 >= 101', 1 ],
+     [ 'num1 >= 100', 1 ],
+     [ 'num1 >= 102', '' ],
+     [ 'num1 <= 101', 1 ],
+     [ 'num1 <= 100', '' ],
+     [ 'num1 <= 102', '1' ],
+     [ 'str eq "ABC"', '1' ],
+     [ 'str eq "AB"', '' ],
+     [ 'str ne "AB"', '1' ],
+     [ 'str ne "ABC"', '' ],
+     [ 'str.lower', 'abc' ],
+     [ 'somelist.size', 6 ],
+     [ '[ 4, 2, 3 ].first', 4 ],
+     [ '[ 1, 4, 9 ].join(",")', "1,4,9" ],
+     [ '[ "xx", "aa" .. "ad", "zz" ].join(" ")', "xx aa ab ac ad zz" ],
+     [ '1 ? "TRUE" : "FALSE"', 'TRUE' ],
+     [ '0 ? "TRUE" : "FALSE"', 'FALSE' ],
+     [ '[ 1 .. 4 ][2]', 3 ],
+     [ 'somelist[2]', "c" ],
+     [ 'somehash["b"]', "12" ],
+     [ 'not 1', '' ],
+     [ 'not 1 or 1', 1 ],
+     [ 'not 1 and 1', "" ],
+     [ '"xabcy" =~ /abc/', 1 ],
+     [ '[ "abc" =~ /(.)(.)/ ][1]', "b" ],
+     [ '{ "a": 11, "b": 12, "c": 20 }["b"]', 12 ],
+     [ 'testclass.foo', "[TestClass.foo]" ],
+    );
+  for my $test (@expr_tests) {
+    my ($expr, $result) = @$test;
+
+    template_test("<:= $expr :>", $result, "expr: $expr", \%acts, "", \%vars);
+  }
+
+  template_test(<<IN, "", "define no use", \%acts, "both", \%vars);
+<:-.define foo:>
+<:.end-:>
+<:-.define bar:>
+<:.end define-:>
+IN
+  template_test(<<IN, "avaluebvalue", "define with call", \%acts, "both", \%vars);
+<:-.define foo:>
+<:-= avar -:>
+<:.end-:>
+<:.call "foo", "avar":"avalue"-:>
+<:.call "foo",
+  "avar":"bvalue"-:>
+IN
+  template_test(<<IN, "other value", "external call", \%acts, "", \%vars);
+<:.call "called.tmpl", "avar":"other value"-:>
+IN
+  template_test(<<IN, "This was preloaded", "call preloaded", \%acts, "both", \%vars);
+<:.call "preloaded"-:>
+IN
+  template_test(<<IN, <<OUT, "simple .for", \%acts, "", \%vars);
+<:.for x in [ "a" .. "d" ] -:>
+Value: <:= x :> Index: <:= loop.index :> Count: <:= loop.count:> Prev: <:= loop.prev :> Next: <:= loop.next :> Even: <:= loop.even :> Odd: <:= loop.odd :> Parity: <:= loop.parity :> is_first: <:= loop.is_first :> is_last: <:= loop.is_last :>-
+<:.end-:>
+IN
+Value: a Index: 0 Count: 1 Prev:  Next: b Even:  Odd: 1 Parity: odd is_first: 1 is_last: -
+Value: b Index: 1 Count: 2 Prev: a Next: c Even: 1 Odd:  Parity: even is_first:  is_last: -
+Value: c Index: 2 Count: 3 Prev: b Next: d Even:  Odd: 1 Parity: odd is_first:  is_last: -
+Value: d Index: 3 Count: 4 Prev: c Next:  Even: 1 Odd:  Parity: even is_first:  is_last: 1-
+OUT
+  template_test(<<IN, <<OUT, "simple .if", \%acts, "", \%vars);
+<:.if "a" eq "b" :>FAIL<:.else:>SUCCESS<:.end:>
+<:.if "a" eq "a" :>SUCCESS<:.else:>FAIL<:.end:>
+<:.if "a" eq "c" :>FAIL1<:.elsif "a" eq "a":>SUCCESS<:.else:>FAIL2<:.end:>
+IN
+SUCCESS
+SUCCESS
+SUCCESS
+OUT
+  template_test(<<IN, <<OUT, "unknown .if", \%acts, "", \%vars);
+<:.if unknown:>TRUE<:.end:>
+<:.if "a" eq "a":>TRUE<:.elsif unknown:>TRUE<:.end:>
+<:.if "a" eq "b" :>TRUE<:.elsif unknown:>TRUE<:.end:>
+<:.if "a" ne "a" :>TRUE<:.elsif 0:>ELIF<:.elsif unknown:>TRUE<:.end:>
+IN
+<:.if unknown:>TRUE<:.end:>
+TRUE
+<:.if 0 :><:.elsif unknown:>TRUE<:.end:>
+<:.if 0 :><:.elsif unknown:>TRUE<:.end:>
+OUT
+
+  template_test(<<IN, <<OUT, "stack overflow on .call", \%acts, "", \%vars);
+<:.define foo:>
+<:-.call "foo"-:>
+<:.end:>
+<:-.call "foo"-:>
+IN
+Error opening scope for call: Too many scope levels
+Backtrace:
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:1
+  .call 'foo' from test:3
+OUT
+
+  template_test(<<IN, <<OUT, "evaltags", \%acts, "", \%vars);
+<:= "str".evaltag :>
+<:= "cat [str] [str2]".evaltag :>
+IN
+ABC
+ABCDEF
+OUT
+
+  template_test(<<IN, <<OUT, "set undef", \%acts, "", \%vars);
+<:.set foo = unknown :>
+<:.set bar = error.noimpl :>
+IN
+<:.set foo = unknown :>
+<:.set bar = error.noimpl :>
+OUT
+}
+
+sub template_test ($$$$;$$) {
+  my ($in, $out, $desc, $acts, $stripnl, $vars) = @_;
+
+  $stripnl ||= 'none';
+  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
+  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
+
+  my $templater = Squirrel::Template->new
+    (
+     template_dir=>'t/templates',
+     preload => "preload.tmpl"
+    );
+
+  my $result = $templater->replace_template($in, $acts, undef, "test", $vars);
+
+  is($result, $out, $desc);
+}
+
+sub iter_repeat_reset {
+  my ($rlimit, $rvalue, $args) = @_;
+
+  ($$rvalue, $$rlimit) = split ' ', $args;
+  --$$rvalue;
+}
+
+sub iter_repeat {
+  my ($rlimit, $rvalue) = @_;
+
+  ++$$rvalue <= $$rlimit;
+}
+
+sub tag_ifeq {
+  my ($args, $acts, $func, $templater) = @_;
+
+  my @args = get_expr($args, $acts, $templater);
+
+  @args >= 2
+    or die "ifEq takes 2 arguments";
+
+  $args[0] eq $args[1];
+}
+
+sub get_expr {
+  my ($origargs, $acts, $templater) = @_;
+
+  my @values;
+  my $args = $origargs;
+  while ($args) {
+    if ($args =~ s/\s*\[([^\[\]]+)\]\s*//) {
+      my $expr = $1;
+      my ($func, $funcargs) = split ' ', $expr, 2;
+      exists $acts->{$func} or die "ENOIMPL\n";
+      push @values, scalar $templater->perform($acts, $func, $funcargs, $expr);
+    }
+    elsif ($args =~ s/\s*\"((?:[^\"\\]|\\[\"\\]|\"\")*)\"\s*//) {
+      my $str = $1;
+      $str =~ s/(?:\\([\"\\])|\"(\"))/$1 || $2/eg;
+      push @values, $str;
+    }
+    elsif ($args =~ s/\s*(\S+)\s*//) {
+      push @values, $1;
+    }
+    else {
+      print "Arg parse failure with '$origargs' at '$args'\n";
+      exit;
+    }
+  }
+  
+  @values;
+}
+
+sub tag_with_upper {
+  my ($args, $text) = @_;
+
+  return uc($text);
+}
+
+sub tag_cat {
+  my ($args, $acts, $func, $templater) = @_;
+
+  return join "", $templater->get_parms($args, $acts);
+}
+
+package TestClass;
+
+sub foo {
+  return "[TestClass.foo]";
+}
diff --git a/t/020-templater/080-parms.t b/t/020-templater/080-parms.t
new file mode 100644 (file)
index 0000000..6ed8750
--- /dev/null
@@ -0,0 +1,56 @@
+#!perl -w
+use strict;
+use Test::More tests => 6;
+use Squirrel::Template;
+
+sub format_test($$$$;$);
+
+my $gotmodule = require_ok('DevHelp::Tags');
+
+SKIP: {
+  skip "couldn't load module", 5 unless $gotmodule;
+
+  my %acts =
+    (
+     alpha => 'abc',
+     gamma => 'cde',
+     upper => 
+     sub { 
+       my ($args, $acts, $func, $templater) = @_;
+
+       my @parms = DevHelp::Tags->get_parms($args, $acts, $templater);
+
+       uc "@parms";
+     },
+     lcfirst => 
+     sub { 
+       my ($args, $acts, $func, $templater) = @_;
+
+       my @parms = DevHelp::Tags->get_parms($args, $acts, $templater);
+
+       lcfirst "@parms";
+     },
+    );
+  format_test(\%acts, "<:upper abc:>", "ABC", 'simple');
+  format_test(\%acts, qq/<:upper "abc":>/, "ABC", 'quoted');
+  format_test(\%acts, qq/<:upper [alpha]:>/, "ABC", 'function');
+  format_test(\%acts, qq/<:upper [alpha] "[alpha beta]":>/,
+             "ABC [ALPHA BETA]", 'combo');
+  format_test(\%acts, qq/<:lcfirst [upper [alpha] "[alpha beta]"]:>/,
+             "aBC [ALPHA BETA]", 'nested');
+  
+}
+
+sub format_test ($$$$;$) {
+  my ($acts, $in, $out, $desc, $stripnl) = @_;
+
+  $stripnl ||= 'none';
+  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
+  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
+
+  my $formatter = Squirrel::Template->new();
+
+  my $result = $formatter->replace_template($in, $acts);
+
+  is($result, $out, $desc);
+}
diff --git a/t/030-tags/010-num.t b/t/030-tags/010-num.t
new file mode 100644 (file)
index 0000000..f4e61fa
--- /dev/null
@@ -0,0 +1,42 @@
+#!perl -w
+use strict;
+use Test::More tests => 10;
+use BSE::Cfg;
+use Squirrel::Template;
+
+use_ok("BSE::Util::Tags");
+
+my $cfg = BSE::Cfg->new(path => "t/tags/");
+
+my %acts =
+  (
+   BSE::Util::Tags->static(undef, $cfg),
+   pi => "3.14159265",
+   large => 1234567890,
+  );
+
+my @tests =
+  ( # comment, template, output
+   [ "num default", "<:number default [pi]:>", "3.14159265" ],
+   [ "num places", "<:number places [pi]:>", "3" ],
+   [ "num default large", "<:number default [large]:>", "1,234,567,890" ],
+   [ "num new comma", "<:number space [large]:>", "1 234 567 890" ],
+   [ "num comma limit", "<:number 9999 9999:>", "9999" ],
+   [ "num comma limit2", "<:number 9999 10000:>", "10,000" ],
+   [ "num cents", "<:number cents [large]:>", "12,345,678.90" ],
+   [ "num cents", "<:number cents 999999:>", "9,999.99" ],
+   [ "num decimal", "<:number decimal [large]:>", "12 345 678,90" ],
+  );
+
+for my $test (@tests) {
+  my ($comment, $in, $out) = @$test;
+  template_test($comment, $in, $out, \%acts);
+}
+
+sub template_test {
+  my ($note, $in, $out, $acts) = @_;
+
+  my $templater = Squirrel::Template->new;
+  my $result = $templater->replace_template($in, $acts);
+  return is($result, $out, $note);
+}
diff --git a/t/030-tags/020-iter.t b/t/030-tags/020-iter.t
new file mode 100644 (file)
index 0000000..9123aa5
--- /dev/null
@@ -0,0 +1,132 @@
+#!perl -w
+use strict;
+use Test::More tests => 3;
+use BSE::Cfg;
+use Squirrel::Template;
+
+use_ok("BSE::Util::Iterate");
+
+my $cfg = BSE::Cfg->new(path => "t/tags/");
+
+my @firsts =
+  (
+   { name => "one", id => 3 },
+   { name => "two", id => 1 },
+   { name => "three", id => 2 },
+  );
+
+my @ids = map $_->{id}, @firsts;
+my %ids = map { $_->{id} => $_ } @firsts;
+
+my $it = BSE::Util::Iterate->new(cfg => $cfg);
+my %acts =
+  (
+   BSE::Util::Tags->static(undef, $cfg),
+   pi => "3.14159265",
+   large => 1234567890,
+   $it->make
+   (
+    single => "first",
+    plural => "firsts",
+    data => \@firsts,
+   ),
+   $it->make
+   (
+    single => "load",
+    plural => "loads",
+    data => \@ids,
+    fetch => [ \&fetcher, \%ids ],
+   ),
+  );
+
+template_test("simple iter", <<IN, <<OUT, \%acts);
+<:iterator begin firsts
+:><:first id:>: <:first name:>
+  index: <:first_index:>
+  number: <:first_number:>
+  first: <:ifFirstFirst:>Y<:or:>N<:eif:>
+  last: <:ifLastFirst:>Y<:or:>N<:eif:>
+  prev name: <:previous_first name:>
+  next name: <:next_first name:>
+<:iterator end firsts:>
+IN
+3: one
+  index: 0
+  number: 1
+  first: Y
+  last: N
+  prev name: 
+  next name: two
+1: two
+  index: 1
+  number: 2
+  first: N
+  last: N
+  prev name: one
+  next name: three
+2: three
+  index: 2
+  number: 3
+  first: N
+  last: Y
+  prev name: two
+  next name: 
+
+OUT
+
+template_test("fetch iter", <<IN, <<OUT, \%acts);
+<:iterator begin loads
+:><:load id:>: <:load name:>
+  index: <:load_index:>
+  number: <:load_number:>
+  first: <:ifFirstLoad:>Y<:or:>N<:eif:>
+  last: <:ifLastLoad:>Y<:or:>N<:eif:>
+  ifPrev: <:ifPreviousLoad:>Y<:or:>N<:eif:>
+  ifNext: <:ifNextLoad:>Y<:or:>N<:eif:>
+  prev name: <:previous_load name:>
+  next name: <:next_load name:>
+<:iterator end loads:>
+IN
+3: one
+  index: 0
+  number: 1
+  first: Y
+  last: N
+  ifPrev: N
+  ifNext: Y
+  prev name: 
+  next name: two
+1: two
+  index: 1
+  number: 2
+  first: N
+  last: N
+  ifPrev: Y
+  ifNext: Y
+  prev name: one
+  next name: three
+2: three
+  index: 2
+  number: 3
+  first: N
+  last: Y
+  ifPrev: Y
+  ifNext: N
+  prev name: two
+  next name: 
+
+OUT
+
+sub fetcher {
+  my ($ids, $id) = @_;
+
+  return $ids->{$id};
+}
+
+sub template_test {
+  my ($note, $in, $out, $acts) = @_;
+
+  my $templater = Squirrel::Template->new;
+  my $result = $templater->replace_template($in, $acts);
+  return is($result, $out, $note);
+}
diff --git a/t/050-local/010-api.t b/t/050-local/010-api.t
new file mode 100644 (file)
index 0000000..3c3614d
--- /dev/null
@@ -0,0 +1,251 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url);
+use Test::More tests => 53;
+use File::Spec;
+use File::Slurp;
+use Carp qw(confess);
+
+$SIG{__DIE__} = sub { confess @_ };
+
+BEGIN {
+  unshift @INC, File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin", "modules");
+}
+
+BEGIN { use_ok("BSE::API", ":all") }
+
+my $ua = make_ua();
+
+my $base_cgi = File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin");
+ok(bse_init($base_cgi),   "initialize api")
+  or print "# failed to bse_init in $base_cgi\n";
+my $cfg = bse_cfg();
+ok($cfg, "we have a cfg object");
+
+my $art = bse_make_article(cfg => $cfg,
+                          title => "API test");
+ok($art, "make a basic article");
+
+my $child = bse_make_article(cfg => $cfg,
+                            title => "API test child",
+                            parentid => $art->id);
+ok($child, "make a child article");
+
+ok($child->is_descendant_of($art), "check decendant by object");
+ok($child->is_descendant_of($art->id), "check decendant by id");
+
+my $im1 = bse_add_image($cfg, $art, file => "t/data/t101.jpg");
+ok($im1, "add an image, just a filename");
+
+my $im2;
+{
+  open my $fh, "<", "t/data/t101.jpg"
+    or die "Cannot open test image: $!\n";
+  $im2 = bse_add_image($cfg, $art, fh => $fh, display_name => "t101.jpg");
+  ok($im2, "add an image by fh");
+}
+
+# just set alt text
+{
+  my %errors;
+  ok(bse_save_image($im1, alt => "Test", errors => \%errors),
+     "update alt text");
+  my $im = BSE::TB::Images->getByPkey($im1->id);
+  ok($im, "found im1 independently");
+  is($im->alt, "Test", "alt is set");
+}
+
+{ # change the image content (by name)
+  my %errors;
+  ok(bse_save_image($im1, file => "t/data/govhouse.jpg", errors => \%errors),
+     "save new image content");
+  is_deeply(\%errors, {}, "no errors");
+  like($im1->src, qr(^/), "src should start with /, assuming no storage");
+}
+
+{ # change the image content (by fh)
+  my %errors;
+  open my $fh, "<", "t/data/govhouse.jpg"
+    or die "Cannot open t/data/govhouse.jpg: $!";
+  ok(bse_save_image($im2, fh => $fh, , display_name => "govhouse.jpg",
+                   errors => \%errors),
+     "save new image content (by fh)");
+  is_deeply(\%errors, {}, "no errors");
+  like($im2->src, qr(^/), "src should start with /, assuming no storage");
+}
+
+{
+  # check we can retrieve the image
+  my $src = base_url() . $im2->image_url;
+  my $imres = $ua->get($src);
+  open my $fh, "<", "t/data/govhouse.jpg"
+    or die "Cannot open t/data/govhouse.jpg: $!";
+  binmode $fh;
+  my $orig = do { local $/; <$fh> };
+  close $fh;
+  ok($imres->is_success, "got some data");
+  is($imres->decoded_content, $orig, "check it matches");
+}
+
+SKIP: {
+  eval { require Imager; }
+    or skip "No Imager", 2;
+  # check thumbnailing
+  my $thumb_url = base_url() . $im2->dynamic_thumb_url(geo => "editor");
+  $thumb_url .= "&cache=0";
+  print "# $thumb_url\n";
+  my $thumb_res = $ua->get($thumb_url);
+  ok($thumb_res->is_success, "successful fetch");
+  like($thumb_res->content_type, qr(^image/[a-z]+$), "check content type");
+  print "# ", $thumb_res->content_type, "\n";
+}
+
+{
+  my $error;
+  ok($art->set_tags([ "colour: red", "size: large" ], \$error),
+     "set some tags should succeed");
+  my $cat = Articles->tag_category("colour");
+  ok($cat, "get the 'colour' tag cat");
+  my @orig_deps = $cat->deps;
+
+  ok($cat->set_deps([], \$error), "empty deps list")
+    or diag "setting deps empty: ", $error;
+
+  ok($cat->set_deps([ "abc:", "def :", "efg: ", "alpha:beta" ], \$error),
+     "set deps");
+  is_deeply([$cat->deps],
+           [ "abc:", "alpha: beta", "def:", "efg:" ],
+           "check they were set");
+
+  ok($cat->set_deps([ "abc:", "hij:" ], \$error),
+     "set deps that add and remove to the list");
+
+  is_deeply([$cat->deps],
+           [ "abc:", "hij:" ],
+           "check they were set");
+
+  ok($cat->set_deps(\@orig_deps, \$error), "restore deps list")
+    or diag "restoring deps: ", $error;
+}
+
+{ # adding a file
+  { # this should fail, file isn't a handle
+    my $file;
+    ok(!eval { $file = $art->add_file
+            (
+             $cfg,
+             displayName => "test.txt",
+             file => "t/t000load.t",
+             store => 0,
+            ) }, "file must be a file handle");
+    like($@, qr/file must be a file handle/, "check message");
+
+    ok(!eval { $file = $art->add_file
+            (
+             $cfg,
+             filename => "t/t000load.t",
+             store => 0,
+            ) }, "displayName is required");
+    like($@, qr/displayName must be non-blank/, "check message");
+  }
+
+  my $file = $art->add_file
+    (
+     $cfg,
+     displayName => "test.txt",
+     filename => "t/t000load.t",
+     store => 0,
+    );
+  ok($file, "added a file");
+
+  # check the content
+  my $mine = read_file("t/t000load.t");
+  my $stored = read_file($file->full_filename);
+  is($stored, $mine, "check contents");
+}
+
+{
+  {
+    # fail adding an image
+    my %errors;
+    my $im = bse_add_image
+      (
+       $cfg, $art,
+       file => "t/t000load.t",
+       errors => \%errors,
+      );
+    ok(!$im, "image failed to add");
+    ok($errors{image}, "failed on the image itself");
+    is($errors{image}, "Unknown image file type", "check message");
+  }
+  {
+    my %errors;
+    my $im = bse_add_image
+      (
+       $cfg, $art,
+       file => "t/data/govhouse.jpg",
+       display_name => "test.php",
+       errors => \%errors,
+      );
+    ok($im, "image failed to add");
+    like($im->image, qr/\.jpeg$/, "check proper extension");
+  }
+}
+
+ok($child->remove($cfg), "remove child");
+undef $child;
+ok($art->remove($cfg), "remove article");
+undef $art;
+
+{
+  my $prefix = "g" . time;
+  # deliberately out of order
+  my $im1 = bse_add_global_image
+    (
+     $cfg,
+     file => "t/data/govhouse.jpg",
+     name => $prefix . "b"
+    );
+  ok($im1, "make a global image (b)");
+  my $im2 = bse_add_global_image
+    (
+     $cfg,
+     file => "t/data/govhouse.jpg",
+     name => $prefix . "c"
+    );
+  ok($im2, "make a global image (c)");
+  my $im3 = bse_add_global_image
+    (
+     $cfg,
+     file => "t/data/govhouse.jpg",
+     name => $prefix . "a"
+    );
+  ok($im3, "make a global image (a)");
+
+  my @images = bse_site()->images;
+  cmp_ok(@images, '>=', 3, "we have some global images");
+
+  my @mine = grep $_->name =~ /^\Q$prefix/, @images;
+
+  # check sort order
+  is($mine[0]->displayOrder, $im1->displayOrder, "first should be first");
+  is($mine[1]->displayOrder, $im2->displayOrder, "middle should be middle");
+  is($mine[2]->displayOrder, $im3->displayOrder, "last should be last");
+
+  ok($im3->remove, "remove the global image");
+  undef $im3;
+  ok($im2->remove, "remove the global image");
+  undef $im2;
+  ok($im1->remove, "remove the global image");
+  undef $im1;
+  END {
+    $im1->remove if $im1;
+    $im2->remove if $im2;
+    $im3->remove if $im3;
+  }
+}
+
+END {
+  $child->remove($cfg) if $child;
+  $art->remove($cfg) if $art;
+}
diff --git a/t/050-local/020-article.t b/t/050-local/020-article.t
new file mode 100644 (file)
index 0000000..f4e4792
--- /dev/null
@@ -0,0 +1,128 @@
+#!perl -w
+use strict;
+use Test::More tests => 12;
+use BSE::Test ();
+use File::Spec;
+
+use_ok("Article");
+
+{
+  my $cfg = bless 
+    {
+     paths =>
+     {
+      base => "/test",
+      public_html => '$(base)/htdocs',
+     }
+    }, "Test::Cfg";
+
+  is(Article->link_to_filename($cfg, "/"), "/test/htdocs/index.html",
+     "check default link to /");
+  is(Article->link_to_filename($cfg, "/foo.html/test"), "/test/htdocs/foo.html",
+     "check default link to filename - trailing title");
+  is(Article->link_to_filename($cfg, "/test.html"), "/test/htdocs/test.html",
+     "check default link to filename - trailing filename");
+  is(Article->link_to_filename($cfg, "//test.html"), "/test/htdocs/test.html",
+     "check default link to filename - doubled /");
+}
+
+{
+  my $cfg = bless 
+    {
+     paths =>
+     {
+      base => "/test",
+      public_html => '$(base)/htdocs',
+     },
+     basic =>
+     {
+      index_file => "default.htm"
+     }
+    }, "Test::Cfg";
+  is(Article->link_to_filename($cfg, "/"), "/test/htdocs/default.htm",
+     "check cfg link to filename");
+}
+
+{
+  my $base_cgi = File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin");
+  
+  use_ok("BSE::API");
+  
+  BSE::API::bse_init($base_cgi);
+  my $cfg = BSE::API::bse_cfg();
+
+  {
+    my $now = time;
+    use POSIX qw(strftime);
+    my $today = strftime("%Y-%m-%d", localtime $now);
+    my $yesterday = strftime("%Y-%m-%d", localtime($now - 86_400));
+    my $tomorrow = strftime("%Y-%m-%d", localtime($now + 86_400));
+    my $tomorrow2 = strftime("%Y-%m-%d", localtime($now + 2*86_400));
+    my $art = BSE::API::bse_make_article
+      (
+       cfg => $cfg,
+       title => "t16article.t",
+       release => $today,
+       expire => $tomorrow,
+      );
+    ok($art, "make an article");
+    ok($art->is_released, "check successful is released");
+    ok(!$art->is_expired, "check false is expired");
+    $art->set_release($tomorrow);
+    ok(!$art->is_released, "check false is released");
+    $art->set_expire($yesterday);
+    ok($art->is_expired, "check true is expired");
+
+    $art->remove($cfg);
+  }
+}
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  my $sect = $self->{$section}
+    or return $def;
+  exists $sect->{$key} or return $def;
+
+  return $sect->{$key};
+}
+
+sub entryIfVar {
+  my ($self, $section, $key, $def) = @_;
+
+  my $value = $self->entry($section, $key);
+  defined $value
+    or return $def;
+
+  return $self->entryVar($section, $key);
+}
+
+sub entryErr {
+  my ($self, $section, $key) = @_;
+
+  my $value = $self->entry($section, $key);
+  defined $value or die "Missing [$section].$key";
+
+  return $value;
+}
+
+sub entryVar {
+  my ($self, $section, $key, $depth) = @_;
+
+  $depth ||= 0;
+  $depth < 10
+    or die "Too many levels of variables getting $key from $section";
+  my $value = $self->entryErr($section, $key);
+  $value =~ s!\$\(([\w ]+)/([\w ]+)\)! $self->entryVar($1, $2, $depth+1) !eg;
+  $value =~ s!\$\(([\w ]+)\)! $self->entryVar($section, $1, $depth+1) !eg;
+
+  $value;
+}
+
+sub content_base_path {
+  my ($self) = @_;
+
+  return $self->entryVar("paths", "public_html");
+}
diff --git a/t/050-local/030-tags.t b/t/050-local/030-tags.t
new file mode 100644 (file)
index 0000000..4d76b23
--- /dev/null
@@ -0,0 +1,216 @@
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests => 36;
+use File::Spec;
+use Carp qw(confess);
+
+$SIG{__DIE__} = sub { confess @_ };
+
+BEGIN {
+  unshift @INC, File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin", "modules");
+}
+
+use BSE::API ':all';
+
+my $base_cgi = File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin");
+ok(bse_init($base_cgi),   "initialize api")
+  or print "# failed to bse_init in $base_cgi\n";
+my $cfg = bse_cfg;
+
+# set up some test data
+my $parent = bse_make_catalog(title => "Tags parent",
+                             cfg => $cfg);
+ok($parent, "make parent article");
+my @kids;
+my %kids;
+for my $title ("A" .. "Z") {
+  my $kid = bse_make_product
+    (
+     cfg => $cfg,
+     title => $title,
+     retailPrice => 0,
+     parentid => $parent->id
+    );
+  push @kids, $kid;
+  $kids{$title} = $kid;
+}
+
+{
+  my %tags =
+    (
+     A => "Platform: iPad/iPad: iPad 1",
+     B => "Platform: iPad/iPad: iPad 1",
+     C => "Platform: iPad/iPad: iPad 2",
+     D => "Platform: iPad/iPad: iPad 2",
+     E => "Platform: iPad/iPad: iPad 2",
+     F => "Platform: iPad/iPad: iPad 3",
+     G => "Platform: iPod/iPod: Classic",
+     H => "Platform: iPod/iPod: Classic",
+     I => "Platform: iPod/iPod: Nano",
+     J => "Platform: iPod/iPod: Nano",
+     K => "Platform: iPod/iPod: 6th Gen",
+     L => "Platform: iPod/iPod: 6th Gen",
+     M => "Platform: iPhone/iPhone: 3G",
+     N => "Platform: iPhone/iPhone: 3G",
+     O => "Platform: iPhone/iPhone: 3GS",
+     P => "Platform: iPhone/iPhone: 4",
+     Q => "Platform: iPhone/iPhone: 4",
+    );
+
+  # set the tags
+  my $all_set = 1;
+  for my $title (keys %tags) {
+    my $kid = $kids{$title} or die "No kid $title found";
+    my $error;
+    unless ($kid->set_tags([ split '/', $tags{$title} ], \$error)) {
+      diag "Setting $title tags: $error\n";
+      $all_set = 0;
+    }
+  }
+  ok($all_set, "all kid tags set");
+}
+
+is_deeply([ map $_->title, $parent->children ],
+         [ reverse("A" .. "Z") ],
+         "check the childrent are in place");
+
+{
+  ok(!$parent->can("children_tags"), "non-optimized path");
+  my $tagged = $parent->collection_with_tags
+    (
+     "children",
+     [ "Platform: iPad" ]
+    );
+  ok($tagged, "collection_with_tags returned");
+ SKIP:
+  {
+    ok($tagged->{objects}, "has objects")
+      or skip("No objects", 1);
+    is_deeply([ map $_->title, @{$tagged->{objects}} ],
+             [ reverse("A" .. "F") ],
+             "check we got the expected kids");
+  }
+ SKIP:
+  {
+    ok($tagged->{object_ids}, "has object_ids")
+      or skip("No object_ids", 1);
+    is_deeply($tagged->{object_ids},
+             [ map $_->id, @kids{reverse("A" .. "F")} ],
+             "check object_ids");
+  }
+ SKIP:
+  {
+    ok($tagged->{extratags}, "has extratags")
+      or skip("No extratags", 1);
+    is(join("/", sort map $_->name, @{$tagged->{extratags}}),
+       "iPad: iPad 1/iPad: iPad 2/iPad: iPad 3",
+       "check knowntags");
+  }
+  ok($tagged->{members}, "has members");
+ SKIP:
+  {
+    ok($tagged->{counts}, "has counts")
+      or skip("No counts", 1);
+    is_deeply($tagged->{counts},
+             {
+              "iPad: iPad 1" => 2,
+              "iPad: iPad 2" => 3,
+              "iPad: iPad 3" => 1,
+             }, "check counts");
+  }
+}
+
+{
+  ok($parent->can("all_visible_product_tags"), "optimized path");
+  my $tagged = $parent->collection_with_tags
+    (
+     "all_visible_products",
+     [ "Platform: iPad" ]
+    );
+  ok($tagged, "collection_with_tags returned (all_visible_products)");
+ SKIP:
+  {
+    ok($tagged->{objects}, "has objects")
+      or skip("No objects", 1);
+    is_deeply([ map $_->title, @{$tagged->{objects}} ],
+             [ reverse("A" .. "F") ],
+             "check we got the expected kids");
+  }
+ SKIP:
+  {
+    ok($tagged->{object_ids}, "has object_ids")
+      or skip("No object_ids", 1);
+    is_deeply($tagged->{object_ids},
+             [ map $_->id, @kids{reverse("A" .. "F")} ],
+             "check object_ids");
+  }
+ SKIP:
+  {
+    ok($tagged->{extratags}, "has extratags")
+      or skip("No extratags", 1);
+    is(join("/", sort map $_->name, @{$tagged->{extratags}}),
+       "iPad: iPad 1/iPad: iPad 2/iPad: iPad 3",
+       "check knowntags");
+  }
+  ok($tagged->{members}, "has members");
+ SKIP:
+  {
+    ok($tagged->{counts}, "has counts")
+      or skip("No counts", 1);
+    is_deeply($tagged->{counts},
+             {
+              "iPad: iPad 1" => 2,
+              "iPad: iPad 2" => 3,
+              "iPad: iPad 3" => 1,
+             }, "check counts");
+  }
+}
+
+{
+  ok($parent->can("all_visible_product_tags"), "optimized path");
+  my $tagged = $parent->collection_with_tags
+    (
+     "all_visible_products",
+     [ "Platform: iPad" ],
+     { noobjects => 1 }
+    );
+  ok($tagged, "collection_with_tags returned (all_visible_products, no objects)");
+  ok(!$tagged->{objects}, "no objects");
+ SKIP:
+  {
+    ok($tagged->{object_ids}, "has object_ids")
+      or skip("No object_ids", 1);
+    # they don't necessarily come back in order
+    is_deeply([ sort @{$tagged->{object_ids}} ],
+             [ sort map $_->id, @kids{reverse("A" .. "F")} ],
+             "check object_ids");
+  }
+ SKIP:
+  {
+    ok($tagged->{extratags}, "has extratags")
+      or skip("No extratags", 1);
+    is(join("/", sort map $_->name, @{$tagged->{extratags}}),
+       "iPad: iPad 1/iPad: iPad 2/iPad: iPad 3",
+       "check knowntags");
+  }
+  ok($tagged->{members}, "has members");
+ SKIP:
+  {
+    ok($tagged->{counts}, "has counts")
+      or skip("No counts", 1);
+    is_deeply($tagged->{counts},
+             {
+              "iPad: iPad 1" => 2,
+              "iPad: iPad 2" => 3,
+              "iPad: iPad 3" => 1,
+             }, "check counts");
+  }
+}
+
+END {
+  for my $kid (@kids) {
+    $kid->remove($cfg);
+  }
+  $parent->remove($cfg) if $parent;
+}
diff --git a/t/050-local/040-catalog.t b/t/050-local/040-catalog.t
new file mode 100644 (file)
index 0000000..fe99692
--- /dev/null
@@ -0,0 +1,105 @@
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests=>19;
+use File::Spec;
+use FindBin;
+my $cgidir;
+BEGIN {
+  $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
+  unshift @INC, $cgidir . 'modules';
+}
+#ok(chdir $cgidir, "switch to CGI directory");
+# create some articles to test with
+use Articles;
+use Products;
+use BSE::API qw/bse_cfg bse_init bse_make_catalog bse_make_product bse_add_step_child/;
+
+bse_init($cgidir);
+my $cfg = bse_cfg;
+
+my $parent = bse_make_catalog
+  (
+   cfg => $cfg,
+   title => "test catalog",
+   body => "Test catalog for catalog tests"
+  );
+
+ok($parent, "made a catalog");
+is($parent->{generator}, "Generate::Catalog", "check generator");
+
+my $parent2 = bse_make_catalog
+  (
+   cfg => $cfg,
+   title => "second test catalog",
+   body => "second test catalog"
+  );
+
+ok($parent2, "got second catalog");
+isnt($parent->{displayOrder}, $parent2->{displayOrder},
+     "make sure we get unique display orders");
+
+# add some products
+my @prods;
+my $price = 1000;
+my %prod_order;
+for my $title (qw/prod1 prod2 prod3/) {
+  my $prod = bse_make_product
+    (
+     cfg => $cfg,
+     parentid => $parent->{id},
+     title => $title,
+     retailPrice => $price,
+     body => $title,
+     product_code => $title
+    );
+  ok($prod, "make product $title/$prod->{id}");
+  unshift @prods, $prod;
+  $prod_order{$prod->{displayOrder}} = 1;
+  $price += 500;
+}
+is(scalar keys %prod_order, 3, "make sure display orders unique");
+
+my $prod4 = bse_make_product
+  (
+   cfg => $cfg,
+   parentid => $parent2->{id},
+   title => "other catalog prod",
+   retailPrice => $price,
+   body => "other catalog prod",
+   product_code => "other catalog prod"
+  );
+ok($prod4, "made prod in other catalog");
+
+{
+  my @kids = $parent->all_visible_products;
+  is(@kids, 3, "got all the normal products");
+  for my $index (0 .. $#kids) {
+    is($kids[$index]{id}, $prods[$index]{id}, "check id at $index");
+  }
+}
+
+my $step_link = bse_add_step_child
+  (
+   cfg => $cfg,
+   parent => $parent,
+   child => $prod4
+  );
+ok($step_link, "made the step link");
+
+{
+  my @kids = $parent->all_visible_products;
+  is(@kids, 4, "got all the normal products and step");
+  my @check = ( $prod4, @prods );
+  for my $index (0 .. $#check) {
+    is($kids[$index]{id}, $check[$index]{id}, "check id at $index");
+  }
+}
+
+$prod4->remove($cfg);
+for my $prod (@prods) {
+  $prod->remove($cfg);
+}
+$parent->remove($cfg);
+$parent2->remove($cfg);
+
diff --git a/t/050-local/050-dyncat.t b/t/050-local/050-dyncat.t
new file mode 100644 (file)
index 0000000..9862962
--- /dev/null
@@ -0,0 +1,560 @@
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests => 95;
+use File::Spec;
+use FindBin;
+my $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
+ok(chdir $cgidir, "switch to CGI directory");
+push @INC, 'modules';
+require BSE::Cfg;
+my $cfg = BSE::Cfg->new;
+# create some articles to test with
+require Articles;
+require Products;
+require BSE::TB::ProductOptions;
+require BSE::TB::ProductOptionValues;
+require BSE::API;
+require BSE::Dynamic::Catalog;
+require BSE::Request::Test;
+use Carp qw(confess);
+
+$SIG{__DIE__} = sub { confess @_ };
+
+$| = 1;
+
+my %cgi =
+  (
+   test1 => "one",
+   test2 => [ qw/two three/ ],
+   test3 => "Size: Medium",
+   test4 => [ "Size: Medium", "Colour: Red" ],
+   test5 => "Size:Medium/Colour:Red/Style:Pretty",
+   test6 => "/Size:Medium//Colour:Red/",
+   pp => 5,
+   p => 2,
+  );
+my $req = BSE::Request::Test->new(cfg => $cfg, params => \%cgi);
+my $gen = BSE::Dynamic::Catalog->new($req);
+BSE::API->import(qw/bse_make_catalog bse_make_product bse_add_step_child/);
+
+sub dyn_template_test($$$$);
+
+my $parent = bse_make_catalog
+  (
+   cfg => $cfg,
+   title => "test catalog",
+   body => "Test catalog for catalog tests"
+  );
+
+ok($parent, "made a catalog");
+is($parent->{generator}, "Generate::Catalog", "check generator");
+
+sleep 1;
+my $parent2 = bse_make_catalog
+  (
+   cfg => $cfg,
+   title => "second test catalog",
+   body => "second test catalog"
+  );
+
+ok($parent2, "got second catalog");
+isnt($parent->{displayOrder}, $parent2->{displayOrder},
+     "make sure we get unique display orders");
+
+my $parent3 = bse_make_catalog
+  (
+   cfg => $cfg,
+   parentid => $parent->{id},
+   title => "third test catalog",
+   body => "third test catalog"
+  );
+
+# add some products
+my @prods;
+my %prods;
+my $price = 1000;
+my %prod_order;
+for my $title (qw/prod1 prod2 prod3 prod4 prod5 prod6 prod7 prod8 prod9 prod10/) {
+  my $prod = bse_make_product
+    (
+     cfg => $cfg,
+     parentid => $parent->{id},
+     title => $title,
+     retailPrice => $price,
+     body => $title,
+     product_code => $title
+    );
+  ok($prod, "make product $title/$prod->{id}");
+  unshift @prods, $prod;
+  $prods{$prod->title} = $prod;
+  $prod_order{$prod->{displayOrder}} = 1;
+  $price += 500;
+}
+
+# give the last an option
+my $order = time();
+my $opt = BSE::TB::ProductOptions->make
+  (
+   product_id => $prods[2]->id,
+   name => "Test Option",
+   display_order => $order++,
+  );
+BSE::TB::ProductOptionValues->make
+  (
+   product_option_id => $opt->id,
+   value => "Alpha",
+   display_order => $order++,
+  );
+BSE::TB::ProductOptionValues->make
+  (
+   product_option_id => $opt->id,
+   value => "Beta",
+   display_order => $order++,
+  );
+
+is(scalar keys %prod_order, 10, "make sure display orders unique");
+
+my $prod4 = bse_make_product
+  (
+   cfg => $cfg,
+   parentid => $parent2->{id},
+   title => "other catalog prod",
+   retailPrice => $price,
+   body => "other catalog prod",
+   product_code => "other catalog prod"
+  );
+ok($prod4, "made prod in other catalog");
+
+my $prod_step_link = bse_add_step_child
+  (
+   cfg => $cfg,
+   parent => $parent,
+   child => $prod4
+  );
+ok($prod_step_link, "made the product step link");
+
+bse_add_step_child
+  (
+   cfg => $cfg,
+   parent => $parent,
+   child => $parent2
+  );
+
+{
+  my %tags =
+    (
+     prod1 => [ "Size: Small", "Colour: Red", "ABC" ],
+     prod2 => [ "Size: Small", "Colour: Blue" ],
+     prod3 => [ "Size: Small", "Colour: Green", "ABC" ],
+     prod4 => [ "Size: Medium", "Colour: Red" ],
+     prod5 => [ "Size: Medium", "Colour: Blue", "Colour: Purple" ],
+     prod6 => [ "Size: Medium", "Colour: Green" ],
+     prod7 => [ "Size: Medium", "Colour: Black" ],
+     prod8 => [ "Size: Large", "Colour: Red" ],
+     prod9 => [ "Size: Large", "Colour: Blue" ],
+     prod10 => [ "Size: Large", "Colour: Green", "XYZ" ],
+    );
+  # set some tags
+  for my $key (sort keys %tags) {
+    my $error;
+    ok($prods{$key}->set_tags($tags{$key}, \$error),
+       "set tags on $key")
+      or print("# error: $error");
+
+    my @set = sort @{$tags{$key}};
+    my @tags = sort $prods{$key}->tags;
+    is_deeply(\@set, \@tags, "check tags set for $key");
+  }
+
+  my $error;
+  $parent->set_tags([ "Brand: Foo", "Class: Network" ], \$error);
+}
+
+dyn_template_test "dynallprods", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods:><:
+dynallprod id:><:ifDynAnyProductOptions:> options<:or:><:eif:>
+<:iterator end dynallprods:>
+TEMPLATE
+$prod4->{id}
+$prods[0]{id}
+$prods[1]{id}
+$prods[2]{id} options
+$prods[3]{id}
+$prods[4]{id}
+$prods[5]{id}
+$prods[6]{id}
+$prods[7]{id}
+$prods[8]{id}
+$prods[9]{id}
+
+EXPECTED
+
+dyn_template_test "article tags", $parent, <<TEMPLATE, <<EXPECTED;
+<:dynarticle tags:>
+TEMPLATE
+Brand: Foo/Class: Network
+EXPECTED
+
+dyn_template_test "dynallprods tag filter", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods tags: "Size: Small" :><:
+dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+prod3
+prod2
+prod1
+
+EXPECTED
+
+dyn_template_test "dynallprods tag filter cgi", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods tags: [lcgi test3] :><:
+dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+prod7
+prod6
+prod5
+prod4
+
+EXPECTED
+
+dyn_template_test "dynallprods tag filter", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods tags: "Size: Small" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+ ABC (2)
+Colour:
+ Blue (1)
+ Green (1)
+ Red (1)
+
+EXPECTED
+
+dyn_template_test "unused tags no highlander", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods tags: "Colour: Blue" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+Colour:
+ Purple (1)
+Size:
+ Large (1)
+ Medium (1)
+ Small (1)
+
+EXPECTED
+
+dyn_template_test "unused tags highlander", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods onlyone tags: "Colour: Blue" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+Size:
+ Large (1)
+ Medium (1)
+ Small (1)
+
+EXPECTED
+
+dyn_template_test "unused tags unfiltered", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods tags: "" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+ ABC (2)
+ XYZ (1)
+Colour:
+ Black (1)
+ Blue (3)
+ Green (3)
+ Purple (1)
+ Red (3)
+Size:
+ Large (3)
+ Medium (4)
+ Small (3)
+
+EXPECTED
+
+dyn_template_test "unused tags cat filtered", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods category:"Colour" tags: "" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+Colour:
+ Black (1)
+ Blue (3)
+ Green (3)
+ Purple (1)
+ Red (3)
+
+EXPECTED
+
+dyn_template_test "unused tags new style", $parent, <<TEMPLATE, <<EXPECTED;
+<:.set ptags = dynarticle.collection_with_tags(
+  "all_visible_products",
+  [],
+  {
+    "noobjects":1
+  }
+  ) -:>
+<:# = bse.dumper(ptags) -:>
+<:.set ptagcats = bse.categorize_tags(ptags.extratags, [],
+  {
+   "onlycat":"Colour",
+   "counts":ptags.counts
+  }) -:>
+<:.for cat in ptagcats -:>
+<:= cat.name:>:
+<:.for val in cat.vals -:>
+<:= " " _ val.val :> (<:= val.count :>)
+<:.end for-:>
+<:.end for:>
+TEMPLATE
+Colour:
+ Black (1)
+ Blue (3)
+ Green (3)
+ Purple (1)
+ Red (3)
+
+EXPECTED
+
+dyn_template_test "dyntags", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dyntags "Size:  Small/Colour: Red/XYZ" :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+<:iterator begin dyntags [lcgi test5] :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+<:iterator begin dyntags [lcgi test6] :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+TEMPLATE
+Size: Small|Size|Small|
+Colour: Red|Colour|Red|
+XYZ||XYZ|
+
+Size: Medium|Size|Medium|
+Colour: Red|Colour|Red|
+Style: Pretty|Style|Pretty|
+
+Size: Medium|Size|Medium|
+Colour: Red|Colour|Red|
+
+EXPECTED
+
+dyn_template_test "dynallcats", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallcats:><:
+dynallcat id:>
+<:iterator end dynallcats:>
+TEMPLATE
+$parent2->{id}
+$parent3->{id}
+
+EXPECTED
+
+dyn_template_test "empty dyncart", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dyncart:><:
+dyncartitem title:> <:money dyncartitem price:>
+<:iterator end dyncart:>
+Total: <:money dyncarttotalcost:>
+TEMPLATE
+
+Total: 0.00
+EXPECTED
+
+# fake an item in the cart
+$req->session->{cart} =
+  [
+   {
+    productId => $prods{prod3}{id},
+    units => 1,
+    price => scalar $prods{prod3}->price(),
+    title => scalar $prods{prod3}->title,
+   }
+  ];
+
+dyn_template_test "nonempty dyncart", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dyncart:><:
+dyncartitem title:> <:money dyncartitem price:>
+<:iterator end dyncart:>
+Total: <:money dyncarttotalcost:>
+TEMPLATE
+prod3 20.00
+
+Total: 20.00
+EXPECTED
+
+dyn_template_test "cgi", $parent, <<TEMPLATE, <<EXPECTED;
+><:cgi unknown:><
+><:cgi test1:><
+><:cgi test2:><
+TEMPLATE
+><
+>one<
+>two three<
+EXPECTED
+
+dyn_template_test "lcgi", $parent, <<TEMPLATE, <<EXPECTED;
+><:lcgi unknown:><
+><:lcgi test1:><
+><:lcgi test2:><
+><:lcgi "," test1:><
+><:lcgi "," test2:><
+><:lcgi ")(" test2:><
+TEMPLATE
+><
+>one<
+>two/three<
+>one<
+>two,three<
+>two)(three<
+EXPECTED
+
+dyn_template_test "deltag", $parent, <<TEMPLATE, <<EXPECTED;
+><:deltag "Size: Medium" [lcgi test4]:><
+><:deltag "Size:Medium" [lcgi test4]:><
+><:deltag "Size:Medium/Colour:Red" [lcgi test5]:><
+><:deltag "Size:Medium" [lcgi test5]:><
+<:iterator begin dyntags [lcgi test5]
+:><:dyntag name:> - <:deltag [dyntag name] [lcgi test5]:>
+<:iterator end dyntags:>
+TEMPLATE
+>Colour: Red<
+>Colour: Red<
+>Style: Pretty<
+>Colour: Red/Style: Pretty<
+Size: Medium - Colour: Red/Style: Pretty
+Colour: Red - Size: Medium/Style: Pretty
+Style: Pretty - Size: Medium/Colour: Red
+
+EXPECTED
+
+dyn_template_test "ifTagIn", $parent, <<TEMPLATE, <<EXPECTED;
+<:ifTagIn "Size:medium" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "Size: Huge" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "Size: Medium" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "DEF" [lcgi test5]:>1<:or:>0<:eif:>
+TEMPLATE
+1
+0
+1
+0
+EXPECTED
+
+dyn_template_test "paged default", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods paged: :><:iterator end dynallprods:>
+Current page: <:dynallprods_page:>
+Page count: <:dynallprods_pagecount:>
+Next page: <:dynallprods_nextpage:>
+Previous page: <:dynallprods_prevpage:>
+Total count: <:dynallprod_totalcount:>
+Count: <:dynallprod_count paged: :>
+First number this page: <:dynallprods_firstnumber:>
+Last number this page: <:dynallprods_lastnumber:>
+Perpage: <:dynallprods_perpage:>
+Pages: <:iterator begin dynallprods_pagec
+:><:dynallprod_pagec page
+:><:ifDynallprod_pagec current:>c<:or:><:eif
+:><:ifDynallprod_pagec first:>f<:or:><:eif
+:><:ifDynallprod_pagec last:>l<:or:><:eif
+:><:ifDynallprod_pagec next:>n<:dynallprod_pagec next:><:or:><:eif
+:><:ifDynallprod_pagec prev:>p<:dynallprod_pagec prev:><:or:><:eif:> <:iterator end dynallprods_pagec
+:>
+<:iterator begin dynallprods paged:
+:><:dynallprod_number:> <:dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+
+Current page: 2
+Page count: 3
+Next page: 3
+Previous page: 1
+Total count: 11
+Count: 5
+First number this page: 6
+Last number this page: 10
+Perpage: 5
+Pages: 1fn2 2cn3p1 3lp2 
+6 prod6
+7 prod5
+8 prod4
+9 prod3
+10 prod2
+
+EXPECTED
+
+$prod4->remove($cfg);
+for my $prod (@prods) {
+  $prod->remove($cfg);
+}
+$parent3->remove($cfg);
+$parent2->remove($cfg);
+$parent->remove($cfg);
+
+# produces three test results
+sub dyn_template_test($$$$) {
+  my ($tag, $article, $template, $expected) = @_;
+
+  #diag "Template >$template<";
+  my $gen = 
+    eval {
+      my $gen_class = $article->{generator};
+      $gen_class =~ s/.*\W//;
+      $gen_class = "BSE::Dynamic::".$gen_class;
+      (my $filename = $gen_class) =~ s!::!/!g;
+      $filename .= ".pm";
+      require $filename;
+      $gen_class->new($req);
+    };
+  ok($gen, "$tag: created generator $article->{generator}");
+  diag $@ unless $gen;
+
+  # get the template - always regen it
+  my $work_template = _generate_dyn_template($article, $template);
+
+  my $result;
+ SKIP: {
+    skip "$tag: couldn't make generator", 1 unless $gen;
+    eval {
+      $result =
+       $gen->generate($article, $work_template);
+    };
+    ok($result, "$tag: generate content");
+    diag $@ unless $result;
+  }
+ SKIP: {
+     skip "$tag: couldn't gen content", 1 unless $result;
+     is($result->{content}, $expected, "$tag: comparing");
+   }
+}
+
+sub _generate_dyn_template {
+  my ($article, $template) = @_;
+
+  my $articles = 'Articles';
+  my $genname = $article->{generator};
+  eval "use $genname";
+  $@ && die $@;
+  my $gen = $genname->new(articles=>$articles, cfg=>$cfg, top=>$article);
+
+  return $gen->generate_low($template, $article, $articles, 0);
+}
diff --git a/t/060-generate/010-generate.t b/t/060-generate/010-generate.t
new file mode 100644 (file)
index 0000000..c8b4634
--- /dev/null
@@ -0,0 +1,757 @@
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests=>161;
+use File::Spec;
+use FindBin;
+use Cwd;
+my $start_dir;
+BEGIN {
+  $start_dir = getcwd();
+  my $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
+  ok(chdir $cgidir, "switch to CGI directory");
+  push @INC, 'modules';
+}
+use BSE::API qw(bse_init bse_cfg bse_make_article bse_add_global_image);
+
+bse_init(".");
+
+my $cfg = bse_cfg();
+
+use BSE::Util::SQL qw/sql_datetime/;
+use DevHelp::Date qw(dh_strftime_sql_datetime);
+
+sub template_test($$$$);
+sub dyn_template_test($$$$);
+
+my $parent = add_article
+  (
+   title=>'Parent', 
+   body=>'parent article doclink[shop|foo]',
+   lastModified => '2004-09-23 06:00:00',
+   threshold => 2,
+  );
+ok($parent, "create section");
+my @kids;
+for my $name ('One', 'Two', 'Three') {
+  my $kid = add_article
+    (
+     title => $name, parentid => $parent->{id}, 
+     body => "b[$name] - alpha, beta, gamma, delta, epsilon",
+     summaryLength => 35,
+    );
+  ok($kid, "creating kid $name");
+  push(@kids, $kid);
+}
+
+my $grandkid = add_article
+  (
+   parentid => $kids[1]{id},
+   title => "Grandkid",
+   body => "grandkid",
+  );
+
+my $prefix = "test" . time;
+my $gim1 = bse_add_global_image
+  (
+   $cfg,
+   file => "$start_dir/t/data/govhouse.jpg",
+   name => $prefix . "a",
+  );
+ok($gim1, "make a global image");
+my $gim2 = bse_add_global_image
+  (
+   $cfg,
+   file => "$start_dir/t/data/t101.jpg",
+   name => $prefix . "b",
+  );
+ok($gim2, "make a second global image");
+
+END {
+  $gim1->remove if $gim1;
+  $gim2->remove if $gim2;
+}
+
+my $base_securl = $cfg->entryVar("site", "secureurl");
+
+# make parent a step child of itself
+require BSE::Admin::StepParents;
+BSE::Admin::StepParents->add($parent, $parent);
+
+is($parent->section->{id}, $parent->{id}, "parent should be it's own section");
+is($kids[0]->section->{id}, $parent->{id}, "kids section should be the parent");
+
+my $top = Articles->getByPkey(1);
+ok($top, "grabbing Home page");
+
+template_test "cfg", $top, <<TEMPLATE, <<EXPECTED;
+<:cfg "no such section" somekey "default / value":>
+TEMPLATE
+default / value
+EXPECTED
+
+template_test "formats", $top, <<TEMPLATE, <<EXPECTED;
+<:arithmetic 10 |%05d:>
+TEMPLATE
+00010
+EXPECTED
+
+template_test "children_of", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin children_of $parent->{id}:><:
+ofchild title:>
+<:iterator end children_of:>
+<:-.set myart = articles.getByPkey($parent->{id}):>
+<:-.for a in [ myart.visible_kids ]:>
+<:-= a.title |html :>
+<:.end for-:>
+TEMPLATE
+Three
+Two
+One
+Three
+Two
+One
+EXPECTED
+
+template_test "allkids_of", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin allkids_of $parent->{id}:><:
+ofallkid title:>
+<:iterator end allkids_of:>
+TEMPLATE
+Parent
+Three
+Two
+One
+
+EXPECTED
+
+template_test "allkids_of filtered", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin allkids_of $parent->{id} filter: [title] =~ /o/i :><:
+ofallkid title:>
+<:iterator end allkids_of:>
+TEMPLATE
+Two
+One
+
+EXPECTED
+
+my @kidids = map $_->{id}, @kids;
+template_test "inlines", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin inlines @kidids:><:
+inline title:><:iterator end inlines:>
+TEMPLATE
+OneTwoThree
+EXPECTED
+
+template_test "inlines filtered", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin inlines @kidids filter: [title] =~ /^T/ :><:
+inline title:><:iterator end inlines:>
+TEMPLATE
+TwoThree
+EXPECTED
+
+template_test "ifancestor positive", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $parent->{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+Yes
+EXPECTED
+
+template_test "ifancestor equal", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $kids[0]{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+Yes
+EXPECTED
+
+template_test "ifancestor negative", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $kids[1]{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+No
+EXPECTED
+
+template_test "children", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin children:><:
+child title:>
+<:iterator end children:>
+TEMPLATE
+Three
+Two
+One
+
+EXPECTED
+
+template_test "embed children", $top, <<TEMPLATE, <<EXPECTED;
+<:embed $parent->{id} test/children.tmpl:>
+TEMPLATE
+Three
+Two
+One
+
+
+EXPECTED
+
+# test some of the newer basic tags
+template_test "add", $top, <<TEMPLATE, <<EXPECTED;
+<:add 3 4:>
+<:add 3 4 5:>
+<:add 3 [add 4 5]:>
+TEMPLATE
+7
+12
+12
+EXPECTED
+
+template_test "concatenate", $top, <<TEMPLATE, <<EXPECTED;
+<:concatenate one two:>
+<:concatenate one "two " three:>
+<:concatenate one [concatenate "two " three]:>
+<:concatenate [concatenate "one" [concatenate "two" "three"]]:>
+<:cat [cat "one" "two"] [concatenate "three" "four"]:>
+TEMPLATE
+onetwo
+onetwo three
+onetwo three
+onetwothree
+onetwothreefour
+EXPECTED
+
+template_test "cond", $top, <<TEMPLATE, <<EXPECTED;
+<:cond 1 "true" false:>
+<:cond 0 true false:>
+<:cond "" true false:>
+TEMPLATE
+true
+false
+false
+EXPECTED
+
+template_test "match", $top, <<'TEMPLATE', <<EXPECTED;
+<:match "abc123" "(\d+)":>
+<:match "abc 123" "(\w+)\s+(\w+)" "$2$1":>
+<:match "abc 123" "(\w+)X(\w+)" "$2$1":>
+<:match "abc 123" "(\w+)X(\w+)" "$2$1" "default":>
+TEMPLATE
+123
+123abc
+
+default
+EXPECTED
+
+template_test "replace", $top, <<'TEMPLATE', <<EXPECTED;
+<:replace "abc123" "(\d+)" "XXX" :>
+<:replace "!!abc 123!!" "(\w+)\s+(\w+)" "$2$1":>
+<:replace "abc 123" "(\w+)" "XXX" g:>
+<:replace "abc 123" "X" "$1" :>
+<:replace "abc
+123
+xyz" "\n" "\\n" g:>
+TEMPLATE
+abcXXX
+!!123abc!!
+XXX XXX
+abc 123
+abc\\n123\\nxyz
+EXPECTED
+
+template_test "cases", $top, <<'TEMPLATE', <<EXPECTED;
+<:lc "AbC123 XYZ":>
+<:uc "aBc123 xyz":>
+<:lcfirst "AbC123 XYZ":>
+<:ucfirst "aBc123 xyz":>
+<:capitalize "alpha beta gamma":>
+<:capitalize "'one day, but don't', 'we know'":>
+<:capitalize "IBM stock soars":>
+TEMPLATE
+abc123 xyz
+ABC123 XYZ
+abC123 XYZ
+ABc123 xyz
+Alpha Beta Gamma
+'One Day, But Don't', 'We Know'
+Ibm Stock Soars
+EXPECTED
+
+template_test "arithmetic", $top, <<'TEMPLATE', <<EXPECTED;
+<:arithmetic 2+2:>
+<:arithmetic 2+[add 1 1]:>
+<:arithmetic d2:1.234+1.542:>
+<:arithmetic 2+ [add 1 2] + [undefinedtag x] + [add 1 1] + [undefinedtag2]:>
+TEMPLATE
+4
+4
+2.78
+<:arithmetic 2+ [add 1 2] + [undefinedtag x] + [add 1 1] + [undefinedtag2]:>
+EXPECTED
+
+template_test "nobodytext", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:nobodytext article body:>
+TEMPLATE
+One - alpha, beta, gamma, delta, epsilon
+EXPECTED
+
+{
+  my $formatted = dh_strftime_sql_datetime("%a %d/%m/%Y", $parent->lastModified);
+  template_test "date", $parent, <<'TEMPLATE', <<EXPECTED;
+<:date "%a %d/%m/%Y" article lastModified:>
+TEMPLATE
+$formatted
+EXPECTED
+}
+
+use POSIX qw(strftime);
+template_test "today", $parent, <<'TEMPLATE', strftime("%Y-%m-%d %d-%b-%Y\n", localtime);
+<:today "%Y-%m-%d":> <:today:>
+TEMPLATE
+
+SKIP:
+{
+  eval {
+    require Date::Format;
+  };
+
+  $@
+    and skip("No Date::Format", 3);
+
+  my $today = Date::Format::strftime("%a %o %B %Y", [ localtime ]);
+  my $mod = dh_strftime_sql_datetime("%A %o %B %Y", $parent->lastModified);
+  template_test "date/today w/Date::Format", $parent, <<'TEMPLATE', <<EXPECTED;
+<:date "%A %o %B %Y" article lastModified:> <:today "%a %o %B %Y":>
+TEMPLATE
+$mod $today
+EXPECTED
+}
+
+template_test "strepeats", $parent, <<'TEMPLATE', <<EXPECTED;
+<:iterator begin strepeats [arithmetic 1+1]:><:strepeat index:> <:strepeat value:>
+<:iterator end strepeats:>
+TEMPLATE
+0 1
+1 2
+
+EXPECTED
+
+template_test "strepeats2", $parent, <<'TEMPLATE', <<EXPECTED;
+<:iterator begin strepeats [arithmetic 1+1] 5:><:strepeat index:> <:strepeat value:>
+<:iterator end strepeats:>
+TEMPLATE
+0 2
+1 3
+2 4
+3 5
+
+EXPECTED
+
+{
+  my $mod_iso = dh_strftime_sql_datetime("%FT%T%z", $parent->lastModified);
+  (my $mod_iso2 = $mod_iso) =~ s/(\d\d)$/:$1/;
+  template_test "quotedreplace", $parent, <<'TEMPLATE', <<EXPECTED;
+<:date "%FT%T%z" article lastModified:>
+<meta name="DC.title" content="<:article title:>" />
+<meta name="DC.date" content="<:replace [date "%FT%T%z" article lastModified] "(\d\d)$" ":$1":>" />
+<meta name="DC.format" content="<:cfg site format "text/html":>" />
+TEMPLATE
+$mod_iso
+<meta name="DC.title" content="Parent" />
+<meta name="DC.date" content="$mod_iso2" />
+<meta name="DC.format" content="text/html" />
+EXPECTED
+}
+
+template_test "report", $parent, <<'TEMPLATE', <<EXPECTED;
+<:report bse_test test/testrep 2:>
+<:report bse_test test/testrep [article id]:>
+TEMPLATE
+Report: Test report
+id title
+2 [index subsection]
+Report: Test report
+id title
+$parent->{id} Parent
+EXPECTED
+
+template_test "body", $parent, <<'TEMPLATE', <<EXPECTED;
+<:body:>
+TEMPLATE
+<p>parent article <a href="$base_securl/shop/" title="The Shop" class="doclink">foo</a></p>
+EXPECTED
+
+# not actually generation tests, but chekcs that the is_step_ancestor works
+ok($kids[0]->is_step_ancestor($parent->{id}),
+   "is_step_ancestor - check normal parent");
+ok($parent->is_step_ancestor($parent->{id}),
+   "is_step_ancestor - check step parent");
+ok(!$parent->is_step_ancestor($kids[0]),
+   "is_step_ancestor - failure check");
+
+# and test the static tag
+template_test "ifStepAncestor 1", $parent, <<'TEMPLATE', <<EXPECTED;
+<:ifStepAncestor article:>Good<:or:>bad<:eif:>
+<:ifStepAncestor 3:>Bad<:or:>Good<:eif:>
+TEMPLATE
+Good
+Good
+EXPECTED
+
+template_test "ifStepAncestor 2", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifStepAncestor parent:>Good<:or:>bad<:eif:>
+<:ifStepAncestor article:>Good<:or:>Bad<:eif:>
+<:ifStepAncestor $kids[2]{id}:>Bad<:or:>Good<:eif:>
+TEMPLATE
+Good
+Good
+Good
+EXPECTED
+
+template_test "ifAnd dynamic cfg ajax", $parent, <<TEMPLATE, <<EXPECTED;
+<:ifAnd [ifDynamic] [cfg basic ajax]:>1<:or:>0<:eif:>
+TEMPLATE
+0
+EXPECTED
+
+template_test "replace complex re", $parent, <<'TEMPLATE', <<EXPECTED;
+<:replace "test&amp;test 01234567890123456789" ((?:&[^;]*;|[^&]){16}).* $1...:>
+TEMPLATE
+test&amp;test 012345...
+EXPECTED
+
+template_test "summary", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:summary article:>
+<:summary article 14:>
+TEMPLATE
+One - alpha, beta, gamma, delta,...
+One - alpha,...
+EXPECTED
+
+template_test "ifUnderThreshold parent children", $parent, <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold:>1<:or:>0<:eif:>
+<:ifUnderThreshold children:>1<:or:>0<:eif:>
+TEMPLATE
+0
+0
+EXPECTED
+
+template_test "ifUnderThreshold parent allkids", $parent, <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold allkids:>1<:or:>0<:eif:>
+TEMPLATE
+0
+EXPECTED
+
+template_test "ifUnderThreshold parent stepkids", $parent, <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold stepkids:>1<:or:>0<:eif:>
+TEMPLATE
+1
+EXPECTED
+
+template_test "ifUnderThreshold child children", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold:>1<:or:>0<:eif:>
+<:ifUnderThreshold children:>1<:or:>0<:eif:>
+TEMPLATE
+1
+1
+EXPECTED
+
+template_test "ifUnderThreshold child allkids", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold allkids:>1<:or:>0<:eif:>
+TEMPLATE
+1
+EXPECTED
+
+template_test "ifUnderThreshold child stepkids", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:ifUnderThreshold stepkids:>1<:or:>0<:eif:>
+TEMPLATE
+1
+EXPECTED
+
+template_test "global images", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin gimages named /^$prefix/ :>
+<:-gimage - displayOrder:>
+<:iterator end gimages-:>
+TEMPLATE
+$gim1->{displayOrder}
+$gim2->{displayOrder}
+EXPECTED
+
+template_test "noreplace undefined", $parent, <<'TEMPLATE', <<'EXPECTED';
+<:switch:><:case Dynallkids_of2 dynofallkid filter: [listed] != 2 :><:if Or [ifAncestor dynofallkid] [ifEq [cgi catid] [dynofallkid id]]:>
+contentA
+  <:iterator begin dynallkids_of2 dynofallkid filter: [listed] != 2 && [generator] =~ /Catalog/ :>
+contentB
+<:ifEq [dynarticle id] [dynofallkid2 id]:> focus<:or:><:eif:>
+<:ifAncestor dynofallkid2:> hilite<:or:><:eif:>
+<:ifFirstDynofallkid2:> first<:or:><:eif:>
+<:ifLastDynofallkid2:> last<:or:><:eif:>
+<:ifDynallkids_of3 dynofallkid2 filter: [listed] != 2 :> parent<:or:><:eif:>
+<:ifDynofallkid2 titleAlias:><:dynofallkid2 titleAlias:><:or:><:dynofallkid2 title:><:eif:>
+<:iterator separator dynallkids_of2:>
+<:iterator end dynallkids_of2:>
+<:or Or:><:eif Or:><:endswitch:>
+TEMPLATE
+<:switch:><:case Dynallkids_of2 dynofallkid filter: [listed] != 2 :><:if Or [ifAncestor dynofallkid] [ifEq [cgi catid] [dynofallkid id]]:>
+contentA
+  <:iterator begin dynallkids_of2 dynofallkid filter: [listed] != 2 && [generator] =~ /Catalog/ :>
+contentB
+<:ifEq [dynarticle id] [dynofallkid2 id]:> focus<:or:><:eif:>
+<:ifAncestor dynofallkid2:> hilite<:or:><:eif:>
+<:ifFirstDynofallkid2:> first<:or:><:eif:>
+<:ifLastDynofallkid2:> last<:or:><:eif:>
+<:ifDynallkids_of3 dynofallkid2 filter: [listed] != 2 :> parent<:or:><:eif:>
+<:ifDynofallkid2 titleAlias:><:dynofallkid2 titleAlias:><:or:><:dynofallkid2 title:><:eif:>
+<:iterator separator dynallkids_of2:>
+<:iterator end dynallkids_of2:>
+<:or Or:><:eif Or:><:endswitch:>
+EXPECTED
+
+# vimages
+template_test "vimages childrenof(children)", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin vimages childrenof(children) :>
+<:iterator end vimages:>
+TEMPLATE
+
+EXPECTED
+
+# tags
+template_test "bse.categorize_tags", $parent, <<'TEMPLATE', <<'EXPECTED';
+<:.set tags = [
+  { "cat":"One", "val":"A", "name":"One: A" },
+  { "cat":"One", "val":"B", "name":"One: B" },
+  { "cat":"Two", "val":"C", "name":"Two: C" },
+  { "cat":"", "val":"D", "name":"D" }
+  ] -:>
+<:.set tagcats = bse.categorize_tags(tags) -:>
+<:.for tagcat in tagcats -:>
+Category: <:= tagcat.name:>
+<:.for tag in tagcat.tags :>  Tag: <:= tag.val:>
+<:.end for:>
+<:.end for -:>
+TEMPLATE
+Category: 
+  Tag: D
+
+Category: One
+  Tag: A
+  Tag: B
+
+Category: Two
+  Tag: C
+
+EXPECTED
+
+my $cat = Articles->tag_category("Foo:");
+my @old_deps = $cat->deps;
+my $error;
+$cat->set_deps([ "Bar:" ], \$error);
+
+template_test "bse.categorize_tags with deps", $parent, <<'TEMPLATE', <<'EXPECTED';
+<:.set tags = [
+  { "cat":"Bar", "val":"A", "name":"Bar: A" },
+  { "cat":"Bar", "val":"B", "name":"Bar: B" },
+  { "cat":"Foo", "val":"C", "name":"Foo: C" },
+  { "cat":"", "val":"D", "name":"D" }
+  ] -:>
+<:.set tagcats = bse.categorize_tags(tags) -:>
+<:.for tagcat in tagcats -:>
+Category: <:= tagcat.name:>
+<:.end for -:>
+--
+<:.set tagcats = bse.categorize_tags(tags, [ "Bar: B" ]) -:>
+<:.for tagcat in tagcats -:>
+Category: <:= tagcat.name:>
+<:.end for -:>
+--
+<:.set tagcats = bse.categorize_tags(tags, [ "Bar: B" ], { "onlyone":1 }) -:>
+<:.for tagcat in tagcats -:>
+Category: <:= tagcat.name:>
+<:.end for -:>
+--
+<:.set counts = { "Bar: A":1, "Foo: C": 10 } -:>
+<:.set tagcats = bse.categorize_tags(tags, [ "Bar: B" ], { "counts":counts }) -:>
+<:.for tagcat in tagcats -:>
+Category: <:= tagcat.name:>
+<:.for tag in tagcat.tags :>  Tag: <:= tag.val:> (<:= tag.count:>)
+<:.end for:>
+<:.end for -:>
+TEMPLATE
+Category: 
+Category: Bar
+--
+Category: 
+Category: Bar
+Category: Foo
+--
+Category: 
+Category: Foo
+--
+Category: 
+  Tag: D (0)
+
+Category: Bar
+  Tag: A (1)
+  Tag: B (0)
+
+Category: Foo
+  Tag: C (10)
+
+EXPECTED
+
+$cat->set_deps(\@old_deps, \$error);
+
+############################################################
+# dynamic stuff
+require BSE::Dynamic::Article;
+require BSE::Request::Test;
+my $req = BSE::Request::Test->new(cfg => $cfg);
+my $gen = BSE::Dynamic::Article->new($req);
+
+dyn_template_test "dynallkidsof", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallkids_of $parent->{id} filter: [title] =~ /o/i :><:
+dynofallkid title:> <:next_dynofallkid title:> <:previous_dynofallkid title:>
+  next: <:ifNextDynofallkid:>Y<:or:>N<:eif:>
+  previous: <:ifPreviousDynofallkid:>Y<:or:>N<:eif:>
+<:iterator end dynallkids_of:>
+TEMPLATE
+Two One 
+  next: Y
+  previous: N
+One  Two
+  next: N
+  previous: Y
+
+EXPECTED
+
+dyn_template_test "dynallkidsof nested", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallkids_of $parent->{id} filter: [title] =~ /o/i :><:
+dynofallkid title:><:iterator begin dynallkids_of2 dynofallkid:>
+  <:dynofallkid2 title:><:iterator end dynallkids_of2:>
+<:iterator end dynallkids_of:>
+TEMPLATE
+Two
+  Grandkid
+One
+
+EXPECTED
+
+dyn_template_test "dynallkidsof nested filtered cond", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallkids_of dynarticle:><:dynofallkid title:><:if Dynallkids_of2 dynofallkid filter: [title] =~ /G/:><:iterator begin dynallkids_of2 dynofallkid filter: [title] =~ /G/:>
+  <:dynofallkid2 title:><:iterator end dynallkids_of2:><:or Dynallkids_of2:>
+  No G kids<:eif Dynallkids_of2:>
+<:iterator end dynallkids_of:>
+TEMPLATE
+Parent
+  No G kids
+Three
+  No G kids
+Two
+  Grandkid
+One
+  No G kids
+
+EXPECTED
+
+dyn_template_test "dynallkids_of move_dynofallkid", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallkids_of dynarticle:><:dynofallkid title:><:move_dynofallkid:>
+<:iterator end dynallkids_of:>
+TEMPLATE
+Parent
+Three
+Two
+One
+
+EXPECTED
+
+############################################################
+# Cleanup
+
+BSE::Admin::StepParents->del($parent, $parent);
+$grandkid->remove($cfg);
+for my $kid (reverse @kids) {
+  my $name = $kid->{title};
+  my $kidid = $kid->{id};
+  $kid->remove($cfg);
+  ok(1, "removing kid $name ($kidid)");
+}
+$parent->remove($cfg);
+ok(1, "removed parent");
+
+sub add_article {
+  my (%parms) = @_;
+
+  my $article = bse_make_article(cfg => $cfg, parentid => -1, %parms);
+
+  $article;
+}
+
+sub template_test($$$$) {
+  my ($tag, $article, $template, $expected) = @_;
+
+  #diag "Template >$template<";
+  my $gen = 
+    eval {
+      (my $filename = $article->{generator}) =~ s!::!/!g;
+      $filename .= ".pm";
+      require $filename;
+      $article->{generator}->new(cfg => $cfg, top => $article);
+    };
+  ok($gen, "$tag: created generator $article->{generator}");
+  diag $@ unless $gen;
+  my $content;
+ SKIP: {
+    skip "$tag: couldn't make generator", 1 unless $gen;
+    eval {
+      $content =
+       $gen->generate_low($template, $article, 'Articles', 0);
+    };
+    ok(defined $content, "$tag: generate content");
+    diag $@ unless $content;
+  }
+ SKIP: {
+     skip "$tag: couldn't gen content", 1 unless defined $content;
+     is($content, $expected, "$tag: comparing");
+   }
+}
+
+sub dyn_template_test($$$$) {
+  my ($tag, $article, $template, $expected) = @_;
+
+  #diag "Template >$template<";
+  my $gen = 
+    eval {
+      my $gen_class = $article->{generator};
+      $gen_class =~ s/.*\W//;
+      $gen_class = "BSE::Dynamic::".$gen_class;
+      (my $filename = $gen_class) =~ s!::!/!g;
+      $filename .= ".pm";
+      require $filename;
+      $gen_class->new($req);
+    };
+  ok($gen, "$tag: created generator $article->{generator}");
+  diag $@ unless $gen;
+
+  # get the template - always regen it
+  my $work_template = _generate_dyn_template($article, $template);
+
+  my $result;
+ SKIP: {
+    skip "$tag: couldn't make generator", 1 unless $gen;
+    eval {
+      $result =
+       $gen->generate($article, $work_template);
+    };
+    ok($result, "$tag: generate content");
+    diag $@ unless $result;
+  }
+ SKIP: {
+     skip "$tag: couldn't gen content", 1 unless $result;
+     is($result->{content}, $expected, "$tag: comparing");
+   }
+}
+
+sub _generate_dyn_template {
+  my ($article, $template) = @_;
+
+  my $articles = 'Articles';
+  my $genname = $article->{generator};
+  eval "use $genname";
+  $@ && die $@;
+  my $gen = $genname->new(articles=>$articles, cfg=>$cfg, top=>$article);
+
+  return $gen->generate_low($template, $article, $articles, 0);
+}
diff --git a/t/060-generate/020-catalog.t b/t/060-generate/020-catalog.t
new file mode 100644 (file)
index 0000000..b8db1e0
--- /dev/null
@@ -0,0 +1,342 @@
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests=>83;
+use File::Spec;
+use FindBin;
+BEGIN {
+  my $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
+  ok(chdir $cgidir, "switch to CGI directory");
+  push @INC, 'modules';
+}
+use BSE::API qw(bse_init bse_cfg bse_make_catalog bse_make_product);
+
+bse_init(".");
+
+my $cfg = bse_cfg();
+require BSE::Util::SQL;
+use DevHelp::Date qw(dh_strftime_sql_datetime);
+
+BSE::DB->init($cfg);
+
+BSE::Util::SQL->import(qw/sql_datetime/);
+sub template_test($$$$);
+
+my $parent = add_catalog
+  (
+   title=>'Test catalog', 
+   body=>'test catalog',
+   parentid => 3,
+   lastModified => '2004-09-23 06:00:00',
+   threshold => 2,
+  );
+ok($parent, "create parent catalog");
+my @kids;
+for my $name ('One', 'Two', 'Three') {
+  my $kid = add_catalog(title => $name, parentid => $parent->{id}, 
+                       body => "b[$name]");
+  ok($kid, "creating kid catalog $name");
+  push(@kids, $kid);
+}
+
+my $stepkid = add_catalog(title=>'step kid', parentid=>3);
+ok($stepkid, "adding step catalog");
+my $stepprod = add_product(title=>'Delta', parentid=>$stepkid->{id},
+                          retailPrice=>400);
+ok($stepprod, "adding step product");
+
+my %prices = ( Alpha => 100, Beta => 200, Gamma => 300 );
+my @prods;
+for my $name (qw(Alpha Beta Gamma)) {
+  my $prod = add_product(title=>$name, retailPrice => $prices{$name},
+                        parentid => $parent->{id});
+  ok($prod, "creating kid product $name");
+  push @prods, $prod;
+}
+
+require BSE::Admin::StepParents;
+BSE::Admin::StepParents->add($parent, $stepkid);
+sleep(2); # make sure they get a new displayOrder
+BSE::Admin::StepParents->add($parent, $stepprod);
+
+my $top = Articles->getByPkey(1);
+ok($top, "grabbing Home page");
+
+template_test "children_of", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin children_of $parent->{id}:><:
+ofchild title:>
+<:iterator end children_of:>
+TEMPLATE
+Gamma
+Beta
+Alpha
+Three
+Two
+One
+
+EXPECTED
+
+template_test "allkids_of", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin allkids_of $parent->{id}:><:
+ofallkid title:>
+<:iterator end allkids_of:>
+TEMPLATE
+Delta
+step kid
+Gamma
+Beta
+Alpha
+Three
+Two
+One
+
+EXPECTED
+
+my @kidids = map $_->{id}, @kids;
+template_test "inlines", $top, <<TEMPLATE, <<EXPECTED;
+<:iterator begin inlines @kidids:><:
+inline title:><:iterator end inlines:>
+TEMPLATE
+OneTwoThree
+EXPECTED
+
+template_test "ifancestor positive", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $parent->{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+Yes
+EXPECTED
+
+template_test "ifancestor equal", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $kids[0]{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+Yes
+EXPECTED
+
+template_test "ifancestor negative", $kids[0], <<TEMPLATE, <<EXPECTED;
+<:ifAncestor $kids[1]{id}:>Yes<:or:>No<:eif:>
+TEMPLATE
+No
+EXPECTED
+
+template_test "children", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin children:><:
+child title:>
+<:iterator end children:>
+TEMPLATE
+Gamma
+Beta
+Alpha
+Three
+Two
+One
+
+EXPECTED
+
+template_test "embed children", $top, <<TEMPLATE, <<EXPECTED;
+<:embed $parent->{id} test/children.tmpl:>
+TEMPLATE
+Gamma
+Beta
+Alpha
+Three
+Two
+One
+
+
+EXPECTED
+
+# test some of the newer basic tags
+template_test "add", $top, <<TEMPLATE, <<EXPECTED;
+<:add 3 4:>
+<:add 3 4 5:>
+<:add 3 [add 4 5]:>
+TEMPLATE
+7
+12
+12
+EXPECTED
+
+template_test "concatenate", $top, <<TEMPLATE, <<EXPECTED;
+<:concatenate one two:>
+<:concatenate one "two " three:>
+<:concatenate one [concatenate "two " three]:>
+<:concatenate [concatenate "one" [concatenate "two" "three"]]:>
+TEMPLATE
+onetwo
+onetwo three
+onetwo three
+onetwothree
+EXPECTED
+
+template_test "match", $top, <<'TEMPLATE', <<EXPECTED;
+<:match "abc123" "(\d+)":>
+<:match "abc 123" "(\w+)\s+(\w+)" "$2$1":>
+<:match "abc 123" "(\w+)X(\w+)" "$2$1":>
+<:match "abc 123" "(\w+)X(\w+)" "$2$1" "default":>
+TEMPLATE
+123
+123abc
+
+default
+EXPECTED
+
+template_test "replace", $top, <<'TEMPLATE', <<EXPECTED;
+<:replace "abc123" "(\d+)" "XXX" :>
+<:replace "!!abc 123!!" "(\w+)\s+(\w+)" "$2$1":>
+<:replace "abc 123" "(\w+)" "XXX" g:>
+<:replace "abc 123" "X" "$1" :>
+<:replace "abc
+123
+xyz" "\n" "\\n" g:>
+TEMPLATE
+abcXXX
+!!123abc!!
+XXX XXX
+abc 123
+abc\\n123\\nxyz
+EXPECTED
+
+template_test "cases", $top, <<'TEMPLATE', <<EXPECTED;
+<:lc "AbC123 XYZ":>
+<:uc "aBc123 xyz":>
+<:lcfirst "AbC123 XYZ":>
+<:ucfirst "aBc123 xyz":>
+<:capitalize "alpha beta gamma":>
+TEMPLATE
+abc123 xyz
+ABC123 XYZ
+abC123 XYZ
+ABc123 xyz
+Alpha Beta Gamma
+EXPECTED
+
+template_test "arithmetic", $top, <<'TEMPLATE', <<EXPECTED;
+<:arithmetic 2+2:>
+<:arithmetic 2+[add 1 1]:>
+<:arithmetic d2:1.234+1.542:>
+<:arithmetic 2+[add 1 2]+[undefinedtag x]+[add 1 1]+[undefinedtag2]:>
+TEMPLATE
+4
+4
+2.78
+<:arithmetic 2+[add 1 2]+[undefinedtag x]+[add 1 1]+[undefinedtag2]:>
+EXPECTED
+
+template_test "nobodytext", $kids[0], <<'TEMPLATE', <<EXPECTED;
+<:nobodytext article body:>
+TEMPLATE
+One
+EXPECTED
+
+{
+  my $mod = dh_strftime_sql_datetime("%a %d/%m/%Y", $parent->lastModified);
+  template_test "date", $parent, <<'TEMPLATE', <<EXPECTED;
+<:date "%a %d/%m/%Y" article lastModified:>
+TEMPLATE
+$mod
+EXPECTED
+}
+
+template_test "strepeats", $parent, <<'TEMPLATE', <<EXPECTED;
+<:iterator begin strepeats [arithmetic 1+1]:><:strepeat index:> <:strepeat value:>
+<:iterator end strepeats:>
+TEMPLATE
+0 1
+1 2
+
+EXPECTED
+
+template_test "strepeats2", $parent, <<'TEMPLATE', <<EXPECTED;
+<:iterator begin strepeats [arithmetic 1+1] 5:><:strepeat index:> <:strepeat value:>
+<:iterator end strepeats:>
+TEMPLATE
+0 2
+1 3
+2 4
+3 5
+
+EXPECTED
+
+template_test "ifUnderThreshold parent allcats", $parent, <<TEMPLATE, <<EXPECTED;
+<:ifUnderThreshold allcats:>1<:or:>0<:eif:>
+TEMPLATE
+0
+EXPECTED
+
+template_test "ifUnderThreshold parent allprods", $parent, <<TEMPLATE, <<EXPECTED;
+<:ifUnderThreshold allprods:>1<:or:>0<:eif:>
+TEMPLATE
+0
+EXPECTED
+
+template_test "variables", $parent, <<TEMPLATE, <<EXPECTED;
+<:= article.title :>
+TEMPLATE
+Test catalog
+EXPECTED
+
+BSE::Admin::StepParents->del($parent, $stepkid);
+BSE::Admin::StepParents->del($parent, $stepprod);
+for my $kid (reverse @prods, $stepprod) {
+  my $name = $kid->{title};
+  $kid->remove($cfg);
+  ok(1, "removing product $name");
+}
+for my $kid (reverse @kids, $stepkid) {
+  my $name = $kid->{title};
+  $kid->remove($cfg);
+  ok(1, "removing kid $name");
+}
+$parent->remove($cfg);
+ok(1, "removed parent");
+
+sub add_article {
+  my (%parms) = @_;
+
+  my $article = bse_make_article(cfg => $cfg, parentid => -1, %parms);
+
+  $article;
+}
+
+sub add_catalog {
+  my (%parms) = @_;
+
+  # this won't put the catalogs in the shop area, but that isn't needed 
+  # for this case.
+  return bse_make_catalog(cfg => $cfg, body => "", %parms);
+}
+
+sub add_product {
+  my (%parms) = @_;
+
+  return bse_make_product(cfg => $cfg, %parms);
+}
+
+sub template_test($$$$) {
+  my ($tag, $article, $template, $expected) = @_;
+
+  #diag "Template >$template<";
+  my $gen = 
+    eval {
+      (my $filename = $article->{generator}) =~ s!::!/!g;
+      $filename .= ".pm";
+      require $filename;
+      $article->{generator}->new(cfg => $cfg, top => $article);
+    };
+  ok($gen, "$tag: created generator $article->{generator}");
+  diag $@ unless $gen;
+  my $content;
+ SKIP: {
+    skip "$tag: couldn't make generator", 1 unless $gen;
+    eval {
+      $content =
+       $gen->generate_low($template, $article, 'Articles', 0);
+    };
+    ok($content, "$tag: generate content");
+    diag $@ unless $content;
+  }
+ SKIP: {
+     skip "$tag: couldn't gen content", 1 unless $content;
+     is($content, $expected, "$tag: comparing");
+   }
+}
diff --git a/t/060-generate/030-thumb.t b/t/060-generate/030-thumb.t
new file mode 100644 (file)
index 0000000..a4242e7
--- /dev/null
@@ -0,0 +1,36 @@
+#!perl -w
+use strict;
+use Test::More tests => 4;
+
+my $cfg = bless 
+  {
+   "imager thumb driver" =>
+   {
+    #debug => 1,
+   }
+  }, "Test::Cfg";
+
+BEGIN { use_ok("BSE::Thumb::Imager") }
+
+my $thumb = BSE::Thumb::Imager->new($cfg);
+
+{
+  my ($width, $height, $type, $orig) =
+    $thumb->thumb_dimensions_sized("scale(55x55c)", 300, 300, undef);
+  is($width, 55, "check scale 55x55c width");
+  is($height, 55, "check scale 55x55c width");
+  is($type, undef, "check type");
+}
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $default) = @_;
+
+  if (exists $self->{$section}
+      && exists $self->{$section}{$key}) {
+    return $self->{$section}{$key};
+  }
+
+  return $default;
+}
diff --git a/t/070-user/010-edit.t b/t/070-user/010-edit.t
new file mode 100644 (file)
index 0000000..be20480
--- /dev/null
@@ -0,0 +1,46 @@
+#!perl -w
+use strict;
+use BSE::Test qw(base_url make_ua skip check_form post_ok ok 
+                 check_content follow_ok);
+use URI::QueryParam;
+#use WWW::Mechanize;
+++$|;
+print "1..22\n";
+my $baseurl = base_url;
+my $ua = make_ua;
+
+ok($ua->get("$baseurl/cgi-bin/admin/add.pl?parentid=-1"), "edit page");
+  check_content($ua->{content}, 'edit page',
+             qr!No\s+parent\s+-\s+this\s+is\s+a\s+section
+             .*
+             common/default.tmpl
+             .*
+             Add\s+New\s+Page\s+Lev1
+             !xs);
+check_form($ua->{content},
+          "edit form",
+          parentid=>[ -1, 'select' ],
+          id => [ '', 'hidden' ],
+          template=> [ 'common/default.tmpl', 'select' ],
+          body => [ '', 'textarea' ],
+          listed => [ 1, 'select' ],
+         );
+$ua->field(title=>'Test Article');
+$ua->field(body=>'This is a test body');
+ok($ua->click('save'), 'submit modified edit form');
+# should redirect to admin mode page
+check_content($ua->{content}, "admin mode", 
+          qr!
+          <title>.*Test\ Article.*</title>
+          .*
+          This\ is\ a\ test\ body
+          !xsm);
+my $uri = $ua->uri;
+my $id = $uri->query_param("id");
+# manage sections
+ok($ua->get("$baseurl/cgi-bin/admin/add.pl?id=-1"), "sections page");
+follow_ok($ua, "clean up",
+         {
+          text => "Delete",
+          url_regex => qr/id=$id/
+         }, qr/Article deleted/);
diff --git a/t/070-user/020-images.t b/t/070-user/020-images.t
new file mode 100644 (file)
index 0000000..9c11be1
--- /dev/null
@@ -0,0 +1,455 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url fetch_ok follow_ok click_ok follow_refresh_ok);
+use Test::More tests => 114;
+
+my $base_url = base_url;
+my $ua = make_ua;
+
+my $title = "t40images.t ".time;
+my $title_re = qr/\Q$title/;
+
+# make a new section to put the images into
+fetch_ok($ua, "menu", "$base_url/cgi-bin/admin/menu.pl", qr/Administration Centre/);
+
+follow_ok($ua, "add section link", "Add a new section", qr/New Page Lev1/);
+
+ok($ua->form_name("edit"), "select edit form");
+
+$ua->field(title => $title);
+$ua->field(body => "ONE((image[test]))\n\nTWO\{\{image[2]\}\}");
+
+click_ok($ua, "add the article", "save", $title_re);
+
+ok($ua->form_name("edit"), "select edit form");
+
+click_ok($ua, "back to editor", undef, qr/Edit Page Lev1/);
+
+my $article_id;
+SKIP:
+{
+  ok((my $edit_form = $ua->form_name("edit")), "edit page has an edit form")
+    or skip("no edit form", 1);
+  ok(($article_id = $edit_form->value("id")),
+     "edit form has an id");
+}
+
+follow_ok($ua, "to images", "Manage Images", qr/Page Lev1 Image Wizard/);
+
+ok($ua->form_name("add"), "select add form");
+
+my @image_content = ( image1(), image2() );
+
+my $form = $ua->current_form;
+ok(my $file = $form->find_input("image"), "get file field");
+$file->filename("t105pal.gif");
+$file->content($image_content[0]);
+
+$ua->field(name => 'test');
+$ua->field(altIn => 'one');
+
+click_ok($ua, "add an image", 'addimg', qr/New image added/);
+
+ok($ua->form_name('add'), "add form again");
+
+sleep 1; # avoid the rare duplicate display order
+
+$form = $ua->current_form;
+ok($file = $form->find_input("image"), "get file field");
+$file->filename("t101.jpg");
+$file->content($image_content[1]);
+$ua->field(altIn => 'two');
+
+click_ok($ua, "add second image", "addimg", qr/New image added/);
+
+follow_ok($ua, "back to editor", "Edit article", "Edit Page Lev1");
+
+# remember where we are
+my $edit_url = $ua->uri;
+
+# this page should include the two images we added
+my @images = get_images($ua->content);
+
+ok(@images == 2, "two images");
+is($images[0]{height}, 16, "image 1 height");
+is($images[0]{width}, 16, "image 1 width");
+like($images[0]{src}, qr/t105pal\.gif$/, "image 1 name");
+is($images[0]{alt}, "one", "image 1 alt");
+is($images[1]{height}, 150, "image 2 height");
+is($images[1]{width}, 150, "image 2 width");
+like($images[1]{src}, qr/t101\.jpg$/, "image 2 name");
+is($images[1]{alt}, "two", "image 2 alt");
+
+# look at the article
+follow_ok($ua, "admin view of article", "See article", $title_re);
+
+# extract the images here too, but simpler due to the layout of the body
+my @im_html;
+($im_html[0]) = $ua->content =~ /ONE\(\((.*?)\)\)/;
+($im_html[1]) = $ua->content =~ /TWO\{\{(.*?)\}\}/;
+for my $im_index (0..1) {
+  my %im;
+
+  my $im_html = $im_html[$im_index];
+
+  ok($im_html, "image $im_index sequence found in body");
+  while ($im_html =~ /(\w+)=\"([^\"]+)\"/g) {
+    $im{$1} = $2;
+  }
+
+  # match the fields
+  for my $field (qw(image alt width height)) {
+    is($im{$field}, $images[$im_index]{$field}, "image $im_index field $field match");
+  }
+  
+  # make sure we can fetch the images
+  # workaround: get() doesn't push the page stack
+  $ua->_push_page_stack();
+  my $image_abs = URI->new_abs($im{src}, $ua->uri);
+  fetch_ok($ua, "image $im_index", $image_abs);
+
+  # make sure it matches
+  is($ua->content(), $image_content[$im_index],
+     "image content stored correctly");
+  
+  # go back to the containing page
+  $ua->back();
+}
+
+ok($ua->form_name("edit"), "select edit form");
+
+click_ok($ua, "back to editor", undef, qr/Edit Page Lev1/);
+
+follow_ok($ua, "admin menu", "Admin menu", qr/Administration Centre/);
+
+follow_ok($ua, "sections", "Administer sections", qr/Manage Sections/);
+
+follow_ok($ua, "global images", "Global Images", qr/Global Image Wizard/);
+
+# fail to add a global image
+ok($ua->form_name('add'), "add form");
+$form = $ua->current_form;
+ok($file = $form->find_input("image"), "get file field");
+$file->filename("t105_trans.gif");
+$file->content(imageg());
+$ua->field(altIn => 'three');
+
+# this should fail, since we didn't set a name
+click_ok($ua, "fail to add a global image", "addimg", 
+        qr/Name must be supplied for global images/);
+
+# try again, and supply a name
+my $global_name = "test".time;
+ok($ua->form_name('add'), "add form");
+$form = $ua->current_form;
+ok($file = $form->find_input("image"), "get file field");
+$file->filename("t105_trans.gif");
+$file->content(imageg());
+$ua->field(altIn => 'three');
+$ua->field(name => $global_name);
+
+click_ok($ua, "add a global image", 'addimg', qr/New image added/);
+
+# back to the article
+print "# edit url $edit_url\n";
+fetch_ok($ua, "back to edit", $edit_url, qr/Edit Page Lev1/);
+
+# update the body to reference the global image
+ok($ua->form_name("edit"), "select edit form");
+$ua->field(body =>"ONE((image[test]))\n\nTWO\{\{image[2]\}\}\n\nTHREE<<gimage[$global_name]>>");
+
+click_ok($ua, "save the new body", "save", undef, qr/Title: BSE - Edit Page Lev1/);
+follow_ok($ua, "to display", "See article", $title_re);
+print "# on page ",$ua->uri,"\n";
+my ($g_html) = $ua->content =~ /THREE&lt;&lt;(.*?)&gt;&gt;/;
+ok($g_html, "global image in page");
+print "# g_html $g_html\n";
+my %gim;
+while ($g_html =~ /(\w+)=\"([^\"]+)\"/g) {
+  $gim{$1} = $2;
+}
+
+is($gim{width}, 20, "gimage width");
+is($gim{height}, 20, "gimage height");
+is($gim{alt}, "three", "gimage alt");
+
+# check that the image matches
+$ua->_push_page_stack();
+my $gimage_abs = URI->new_abs($gim{src}, $ua->uri);
+fetch_ok($ua, "gimage content", $gimage_abs);
+
+is($ua->content, imageg(), "gimage content");
+$ua->back;
+
+# back to the editor
+ok($ua->form_name("edit"), "select edit form");
+click_ok($ua, "edit page", undef, qr/Edit Page Lev1/);
+
+follow_ok($ua, "image manager", "Manage Images", qr/Page Lev1 Image Wizard/);
+
+for my $im_index (0 .. 1) {
+  follow_ok($ua, "delete image $im_index", "Delete", qr/Image removed/);
+
+  # make sure the file was deleted
+  $ua->_push_page_stack();
+  my $img_url = URI->new_abs($images[$im_index]{src}, $ua->uri);
+  ok(!$ua->get($img_url)->is_success, 
+     "checking image file for $im_index was deleted");
+  $ua->back;
+}
+
+follow_ok($ua, "admin menu", "Admin menu", qr/Administration Centre/);
+follow_ok($ua, "sections", "Administer sections", qr/Manage Sections/);
+follow_ok($ua, "global images", "Global Images", qr/Global Image Wizard/);
+
+# since there may have been other global images, we need to be a bit 
+# more careful here
+my $links = $ua->links;
+my @links = grep defined($_->text) && $_->text eq 'Delete', @$links;
+print "# link #", scalar(@links), "\n";
+follow_ok($ua, "delete global image", 
+         { n=>scalar(@links), text=>"Delete" }, 
+         qr/Image removed/);
+
+# make sure the file was deleted
+$ua->_push_page_stack();
+my $img_url = URI->new_abs($gim{src}, $ua->uri);
+ok(!$ua->get($img_url)->is_success, 
+   "checking image file for global image was deleted");
+$ua->back;
+
+follow_ok($ua, "admin menu", "Admin menu", qr/Administration Centre/);
+follow_ok($ua, "sections", "Administer sections", qr/Manage Sections/);
+follow_ok($ua, "delete article",
+         {
+          text => "Delete",
+          url_regex => qr/id=$article_id/
+         },
+         qr/Article deleted/);
+
+sub image1 {
+  # based on testout/t105pal.gif from Imager
+  my $hex = <<HEX;
+47 49 46 38 37 61 10 00 10 00 A2 00 00 FF FF 00 
+FF 00 00 00 FF 00 00 00 FF 00 00 00 FF FF FF 00 
+00 00 00 00 00 21 F9 04 04 32 00 00 00 21 FE 0E 
+4D 61 64 65 20 77 69 74 68 20 47 49 4D 50 00 2C 
+00 00 00 00 10 00 10 00 00 03 96 08 00 10 81 11 
+22 22 38 33 03 80 00 11 11 28 22 32 83 33 00 00 
+18 11 21 82 22 33 33 08 00 10 81 11 22 22 38 33 
+03 80 00 11 11 28 22 32 83 33 00 00 18 11 21 82 
+22 33 33 08 00 10 81 11 22 22 38 33 03 80 00 11 
+11 28 22 32 83 33 00 00 18 11 21 82 22 33 33 08 
+00 10 81 11 22 22 38 33 03 80 00 11 11 28 22 32 
+83 33 00 00 18 11 21 82 22 33 33 08 00 10 81 11 
+22 22 38 33 03 80 00 11 11 28 22 32 83 33 00 00 
+18 11 21 82 22 33 33 08 00 10 81 11 22 22 38 33 
+93 00 21 F9 04 05 32 00 06 00 2C 03 00 03 00 0A 
+00 0A 00 00 03 3B 48 44 44 84 44 44 44 48 44 44 
+84 44 44 44 48 44 44 84 44 44 44 48 44 44 84 44 
+44 44 48 54 55 85 55 55 55 58 55 55 85 55 55 55 
+58 55 55 85 55 55 55 58 55 55 85 55 55 55 58 55 
+95 00 3B                                        
+HEX
+  $hex =~ tr/0-9A-F//cd;
+  return pack("H*", $hex);
+}
+
+sub image2 {
+  # based on testout/t101.jpg from Imager
+  my $hex = <<HEX;
+FF D8 FF E0 00 10 4A 46 49 46 00 01 01 00 00 01 
+00 01 00 00 FF DB 00 43 00 1B 12 14 17 14 11 1B 
+17 16 17 1E 1C 1B 20 28 42 2B 28 25 25 28 51 3A 
+3D 30 42 60 55 65 64 5F 55 5D 5B 6A 78 99 81 6A 
+71 90 73 5B 5D 85 B5 86 90 9E A3 AB AD AB 67 80 
+BC C9 BA A6 C7 99 A8 AB A4 FF DB 00 43 01 1C 1E 
+1E 28 23 28 4E 2B 2B 4E A4 6E 5D 6E A4 A4 A4 A4 
+A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 
+A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 
+A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 A4 FF C0 
+00 11 08 00 96 00 96 03 01 22 00 02 11 01 03 11 
+01 FF C4 00 1F 00 00 01 05 01 01 01 01 01 01 00 
+00 00 00 00 00 00 00 01 02 03 04 05 06 07 08 09 
+0A 0B FF C4 00 B5 10 00 02 01 03 03 02 04 03 05 
+05 04 04 00 00 01 7D 01 02 03 00 04 11 05 12 21 
+31 41 06 13 51 61 07 22 71 14 32 81 91 A1 08 23 
+42 B1 C1 15 52 D1 F0 24 33 62 72 82 09 0A 16 17 
+18 19 1A 25 26 27 28 29 2A 34 35 36 37 38 39 3A 
+43 44 45 46 47 48 49 4A 53 54 55 56 57 58 59 5A 
+63 64 65 66 67 68 69 6A 73 74 75 76 77 78 79 7A 
+83 84 85 86 87 88 89 8A 92 93 94 95 96 97 98 99 
+9A A2 A3 A4 A5 A6 A7 A8 A9 AA B2 B3 B4 B5 B6 B7 
+B8 B9 BA C2 C3 C4 C5 C6 C7 C8 C9 CA D2 D3 D4 D5 
+D6 D7 D8 D9 DA E1 E2 E3 E4 E5 E6 E7 E8 E9 EA F1 
+F2 F3 F4 F5 F6 F7 F8 F9 FA FF C4 00 1F 01 00 03 
+01 01 01 01 01 01 01 01 01 00 00 00 00 00 00 01 
+02 03 04 05 06 07 08 09 0A 0B FF C4 00 B5 11 00 
+02 01 02 04 04 03 04 07 05 04 04 00 01 02 77 00 
+01 02 03 11 04 05 21 31 06 12 41 51 07 61 71 13 
+22 32 81 08 14 42 91 A1 B1 C1 09 23 33 52 F0 15 
+62 72 D1 0A 16 24 34 E1 25 F1 17 18 19 1A 26 27 
+28 29 2A 35 36 37 38 39 3A 43 44 45 46 47 48 49 
+4A 53 54 55 56 57 58 59 5A 63 64 65 66 67 68 69 
+6A 73 74 75 76 77 78 79 7A 82 83 84 85 86 87 88 
+89 8A 92 93 94 95 96 97 98 99 9A A2 A3 A4 A5 A6 
+A7 A8 A9 AA B2 B3 B4 B5 B6 B7 B8 B9 BA C2 C3 C4 
+C5 C6 C7 C8 C9 CA D2 D3 D4 D5 D6 D7 D8 D9 DA E2 
+E3 E4 E5 E6 E7 E8 E9 EA F2 F3 F4 F5 F6 F7 F8 F9 
+FA FF DA 00 0C 03 01 00 02 11 03 11 00 3F 00 E6 
+68 A2 8A 00 28 A2 8A 00 28 A2 8A 00 28 A2 8A 00 
+28 A2 8A 00 28 A2 8A 00 28 A2 8A 00 28 A2 8A 00 
+28 A2 8A 00 28 A2 8A 00 28 A2 8A 00 28 A9 22 00 
+F5 A7 ED 1E 95 D9 4B 08 EA 47 99 32 5C AC 41 45 
+4F B4 7A 51 B4 7A 56 9F 51 97 71 73 10 51 53 ED 
+1E 94 6D 1E 94 7D 46 5D C3 98 82 8A 9F 68 F4 A5 
+0A 33 D2 8F A8 CB B8 73 10 60 FA 51 83 E8 6B A1 
+B7 B6 84 C2 A4 A0 CE 3D 2A 4F B2 C1 FF 00 3C C7 
+E5 5E 34 B1 0A 32 6A C7 2B C5 C5 3B 58 E6 B0 7D 
+0D 18 3E 86 BA 5F B2 C1 FF 00 3C C7 E5 47 D9 60 
+FF 00 9E 63 F2 A9 FA D2 EC 1F 5C 8F 63 9A C1 F4 
+34 60 FA 1A E9 7E CB 07 FC F3 1F 95 1F 65 83 FE 
+79 8F CA 8F AD 2E C1 F5 C8 F6 39 9A 2A F6 AD 1A 
+C7 38 08 00 18 AA 35 D3 19 73 2B 9D 70 97 3C 54 
+82 8A 28 AA 28 28 A2 8A 00 92 2E F5 2D 45 17 7A 
+96 BD BC 2F F0 91 94 B7 0A 28 A2 BA 44 14 51 40 
+04 F4 A2 F6 0D C2 81 D6 9E 22 63 DA 9D E4 35 73 
+CB 13 4A 3A 39 1B 2C 3D 56 AE A2 6C DB 7F A8 4F 
+A5 4B 50 5B 48 82 25 52 79 02 A7 EB 5F 1F 57 E3 
+6C F1 6A D3 9C 24 D4 95 82 8A 28 AC CC C2 8A 28 
+A0 0C 4D 67 FE 3E 07 D2 B3 AB 47 59 FF 00 8F 81 
+F4 AC EA F4 E9 7C 08 F6 28 7F 0D 05 14 51 5A 9B 
+05 14 51 40 12 45 DE A5 A8 A2 EF 52 D7 B7 85 FE 
+12 32 96 E1 45 14 01 93 8A E9 7A 0B 71 C8 85 CD 
+59 48 C2 8A 23 5D AB 4F AF 9D C5 E2 E5 56 4E 31 
+7A 1E F6 1B 0D 1A 71 BB DC 28 A2 8A E1 3B 02 A6 
+86 E1 90 E0 F2 2A 1A 29 34 9E E6 55 68 C2 B4 79 
+66 AE 6A 2B 07 19 14 B5 4A D2 5D AD B4 F4 35 76 
+B9 A5 1E 56 7C 6E 33 0C F0 D5 5C 3A 74 0A 28 A2 
+A4 E4 31 35 9F F8 F8 1F 4A CE AD 1D 67 FE 3E 07 
+D2 B3 AB D3 A5 F0 23 D8 A1 FC 34 14 51 45 6A 6C 
+14 51 45 00 49 17 7A 96 A2 8B BD 4B 5E DE 17 F8 
+48 CA 5B 85 3E 11 97 14 CA 96 DF EF D3 C4 C9 C6 
+94 9A 36 C3 A4 EA C5 32 CD 14 51 5F 2E 7D 18 51 
+45 14 00 51 45 14 00 A8 70 C0 D6 9A 1C A8 35 97 
+5A 50 FF 00 AB 5F A5 63 54 F0 33 B8 AE 58 C8 7D 
+14 51 58 9F 38 62 6B 3F F1 F0 3E 95 9D 5A 3A CF 
+FC 7C 0F A5 67 57 A7 4B E0 47 B1 43 F8 68 28 A2 
+8A D4 D8 28 A2 8A 00 92 2E F5 2D 45 17 7A 96 BD 
+BC 2F F0 91 94 B7 0A 7C 47 0E 29 94 0E 2B 6A 91 
+E7 8B 8F 72 A1 2E 59 29 17 69 6A 38 9F 72 FB D4 
+95 F2 B5 20 E1 27 16 7D 24 26 A7 15 24 14 51 45 
+41 61 45 14 50 02 A0 DC E0 56 9A 8C 28 15 56 D2 
+2E 77 9A B7 5C F5 1D DD 8F 95 CD F1 0A A5 45 08 
+F4 0A 28 A2 B3 3C 73 13 59 FF 00 8F 81 F4 AC EA 
+D1 D6 7F E3 E0 7D 2B 3A BD 3A 5F 02 3D 8A 1F C3 
+41 45 14 56 A6 C1 45 14 50 04 91 77 A9 6A 28 BB 
+D4 B5 ED E1 7F 84 8C A5 B8 51 45 15 D2 21 55 8A 
+9C 8A B2 92 86 EB C1 AA B4 57 2E 23 0B 0A DB EE 
+74 D0 C4 CE 8E DB 17 73 4B 54 C3 B0 E8 69 44 AF 
+9E B5 E6 4B 2C A8 9E 8C F4 16 61 0B 6A 8B 61 49 
+E8 2A CC 36 C4 9C BD 4D 6C A3 C9 53 8E 48 A9 AB 
+C6 A9 36 9B 89 E4 E2 73 79 CD 38 D3 56 10 00 06 
+05 2D 14 56 27 88 DD F5 61 45 14 50 06 26 B3 FF 
+00 1F 03 E9 59 D5 A3 AC FF 00 C7 C0 FA 56 75 7A 
+74 BE 04 7B 14 3F 86 82 8A 28 AD 4D 82 8A 28 A0 
+09 22 EF 52 D4 31 B0 1D 6A 4D EB 5E C6 1A A4 23 
+49 26 CC E4 B5 1D 45 37 7A D1 BD 6B A3 DB 53 EE 
+2B 31 D4 53 77 AD 1B D6 8F 6D 4F B8 59 8E A0 75 
+A6 EF 5A 04 8B 9A 5E DA 9F 70 B3 3A 0B 6F F5 09 
+F4 A9 6A 84 17 F0 2C 4A A5 B9 02 A4 FE D1 B7 FE 
+F5 7C 7D 58 49 CD B4 BA 9E 5C A9 4E EF 42 DD 15 
+53 FB 46 DF FB D4 7F 68 DB FF 00 7A B3 F6 72 EC 
+2F 65 3E C5 BA 2A A7 F6 8D BF F7 A8 FE D1 B7 FE 
+F5 1E CE 5D 83 D9 4F B1 9F AC FF 00 C7 C0 FA 56 
+75 5C D4 E7 49 E6 0C 87 23 15 4E BD 1A 4A D0 57 
+3D 5A 29 A8 24 C2 8A 28 AD 0D 42 8A 28 A0 02 8A 
+28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 
+28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 
+28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 
+28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 28 A0 02 8A 
+28 A0 02 8A 28 A0 02 8A 28 A0 0F FF D9          
+HEX
+  $hex =~ tr/0-9A-F//cd;
+  return pack("H*", $hex);
+}
+
+sub imageg {
+  # based on testout/t105_trans.gif from Imager
+  my $hex = <<HEX;
+47 49 46 38 37 61 14 00 14 00 91 00 00 00 FF 00 
+FF 00 00 00 00 00 00 00 00 21 F9 04 01 00 00 02 
+00 2C 00 00 00 00 14 00 14 00 00 02 E2 04 08 10 
+20 40 80 00 01 02 04 08 10 20 40 80 00 01 02 04 
+08 10 20 40 80 11 23 46 8C 18 31 62 C4 88 01 01 
+2A 54 A8 50 A1 42 85 0A 15 0A 04 18 31 62 C4 88 
+11 23 46 8C 18 10 A0 42 85 0A 15 2A 54 A8 50 A1 
+40 80 11 23 46 8C 18 31 62 C4 88 01 01 2A 54 A8 
+50 A1 42 85 0A 15 0A 04 18 31 62 C4 88 11 23 46 
+8C 18 10 A0 42 85 0A 15 2A 54 A8 50 A1 40 80 11 
+23 46 8C 18 31 62 C4 88 01 01 2A 54 A8 50 A1 42 
+85 0A 15 0A 04 18 31 62 C4 88 11 23 46 8C 18 10 
+A0 42 85 0A 15 2A 54 A8 50 A1 40 80 11 23 46 8C 
+18 31 62 C4 88 01 01 2A 54 A8 50 A1 42 85 0A 15 
+0A 04 18 31 62 C4 88 11 23 46 8C 18 10 A0 42 85 
+0A 15 2A 54 A8 50 A1 40 80 11 23 46 8C 18 31 62 
+C4 88 01 01 02 04 08 10 20 40 80 00 01 02 05 00 
+3B                                              
+HEX
+  $hex =~ tr/0-9A-F//cd;
+  return pack("H*", $hex);
+}
+
+# extract the image tags from the edit page
+sub get_images {
+  my ($content) = @_;
+
+  require 'HTML/Parser.pm';
+  require 'HTML/Entities.pm';
+
+  my @images;
+
+  #my $indent = 0;
+  my $in_images;
+  my $start = 
+    sub {
+      my ($tagname, $attr) = @_;
+
+      #print "# "," "x$indent,">$tagname ",join(",", map("$_=>$attr->{$_}", keys %$attr)),"\n";
+      #++$indent;
+                                              
+      if ($tagname eq 'td') {
+       my $id = $attr->{id};
+       #print "# id $id\n" if $id;
+       if ($id && $id eq 'images') {
+         ++$in_images;
+       }
+      }
+      elsif ($tagname eq 'img' && $in_images) {
+       push @images, { %$attr };
+      }
+    };
+  my $end =
+    sub {
+      my ($tagname) = @_;
+
+      #--$indent;
+      #print "# "," "x$indent,"<$tagname\n";
+      
+      if ($tagname eq 'td' && $in_images) {
+       --$in_images;
+      }
+    };
+
+  my $p = HTML::Parser->new( start_h => [ $start, "tagname, attr" ],
+                            end_h => [ $end, "tagname" ]);
+  $p->parse($content);
+  $p->eof;
+  
+  use Data::Dumper;
+  my $dump = Dumper \@images;
+  $dump =~ s/^/# /gm;
+  print $dump;
+  
+  @images;
+}
diff --git a/t/080-remote/010-save.t b/t/080-remote/010-save.t
new file mode 100644 (file)
index 0000000..efd7588
--- /dev/null
@@ -0,0 +1,547 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url);
+use JSON;
+use DevHelp::HTML;
+use Test::More;
+use Article;
+
+my @cols = Article->columns;
+
+my $base = 119;
+
+my $count = $base + (@cols - 13) * 4;
+
+plan tests => $count;
+
+$| = 1;
+
+my $ua = make_ua;
+my $baseurl = base_url;
+
+my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
+
+my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
+
+my %add_req =
+  (
+   save => 1,
+   title => "test",
+   parentid => -1,
+   _context => "test context",
+  );
+my $art_data = do_req($add_url, \%add_req, "add article");
+
+SKIP:
+{
+  $art_data or skip("no response to add", 20);
+  ok($art_data->{success}, "successful json response");
+
+  is($art_data->{context}, "test context", "check context returned");
+
+  my $art = $art_data->{article};
+  my $orig_lastmod = $art->{lastModified};
+
+  # try to fetch by id
+ SKIP:
+  {
+    my %fetch_req =
+      (
+       a_article => 1,
+       id => $art->{id},
+      );
+    my $data = do_req($add_url, \%fetch_req, "fetch just saved")
+      or skip("no json", 2);
+    ok($data->{success}, "successful");
+    ok($data->{article}, "has an article");
+    my %temp = %$art;
+    for my $field (qw/release expire/) {
+      delete $temp{$field};
+      delete $data->{article}{$field};
+    }
+    is_deeply($data->{article}, \%temp, "check it matches what we saved");
+    ok($data->{article}{tags}, "has a tags member");
+    is_deeply($data->{article}{tags}, [], "which is an empty array ref");
+  }
+
+  my @fields = grep 
+    {
+      defined $art->{$_}
+       && !/^(id|created|link|admin|files|images|cached_dynamic|createdBy|generator|level|lastModified(By)?|displayOrder)$/
+         && !/^thumb/
+       } keys %$art;
+
+  for my $field (@fields) {
+    print "# save test $field\n";
+    my %reqdata =
+      (
+       save => 1,
+       id => $art->{id},
+       $field => $art->{$field},
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%reqdata, "set $field");
+  SKIP:
+    {
+      $data or skip("Not json from setting $field", 2);
+      ok($data->{success}, "success flag is set");
+      ok($data->{article}, "has an article object");
+      $art = $data->{article};
+    }
+  }
+
+  { # try to set a bad value for category
+    my %req_data = 
+      (
+       save => 1,
+       id => $art->{id},
+       category => "A" . rand(),
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%req_data, "save bad category");
+  SKIP:
+    {
+      $data or skip("Not json from setting bad category", 4);
+      ok(!$data->{success}, "shouldn't be successful");
+      ok(!$data->{article}, "should be no article object");
+      is($data->{error_code}, "FIELD", "should be a field error");
+      ok($data->{errors} && $data->{errors}{category},
+        "should be an error message for category");
+    }
+  }
+
+  my $tag_name1 = "YHUIOP";
+  my $tag_name2 = "zyx: alpha";
+  { # save tags
+    my %reqdata =
+      (
+       save => 1,
+       id => $art->{id},
+       _save_tags => 1,
+       tags => [ $tag_name2, " $tag_name1 " ],
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%reqdata, "set tags");
+  SKIP:
+    {
+      $data or skip("Not json from setting tags", 2);
+      ok($data->{success}, "success flag set");
+      is_deeply($data->{article}{tags}, [ $tag_name1, $tag_name2 ],
+               "check tags saved");
+      $art = $data->{article};
+    }
+  }
+
+  { # grab the tree
+    my %tree_req =
+      (
+       a_tree => 1,
+       id => -1,
+      );
+    my $data = do_req($add_url, \%tree_req, "fetch tree");
+    $data or skip("not a json response", 6);
+    ok($data->{success}, "was successful");
+    ok($data->{articles}, "has articles");
+    my $art = $data->{articles}[0];
+    ok(defined $art->{level}, "entries have level");
+    ok($art->{title}, "entries have a title");
+    ok(defined $art->{listed}, "entries have a listed");
+    ok($art->{lastModified}, "entries have a lastModified");
+  }
+
+  { # grab the tags
+    my %tag_req =
+      (
+       a_tags => 1,
+       id => -1,
+      );
+    my $data = do_req($add_url, \%tag_req, "fetch tags");
+  SKIP:
+    {
+      $data or skip("not a json response", 4);
+      ok($data->{tags}, "it has tags");
+      my ($xyz_tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+      ok($xyz_tag, "check we found the tag we set");
+      is($xyz_tag->{cat}, "zyx", "check cat");
+      is($xyz_tag->{val}, "alpha", "check val");
+    }
+  }
+
+  my $tag1;
+  my $tag2;
+  { # grab them with article ids
+    my %tag_req =
+      (
+       a_tags => 1,
+       id => -1,
+       showarts => 1,
+      );
+    my $data = do_req($add_url, \%tag_req, "fetch tags");
+  SKIP:
+    {
+      $data or skip("not a json response", 6);
+      ok($data->{tags}, "it has tags");
+      ($tag1) = grep $_->{name} eq $tag_name1, @{$data->{tags}};
+      ($tag2) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+      ok($tag2, "check we found the tag we set");
+      is($tag2->{cat}, "zyx", "check cat");
+      is($tag2->{val}, "alpha", "check val");
+      ok($tag2->{articles}, "has articles");
+      ok(grep($_ == $art->{id}, @{$tag2->{articles}}),
+             "has our article id in it");
+    }
+  }
+
+ SKIP:
+  { # delete a tag globally
+    $tag2
+      or skip("didn't find the tag we want to remove", 6);
+    my %del_req =
+      (
+       a_tagdelete => 1,
+       id => -1,
+       tag_id => $tag2->{id},
+      );
+    my $data = do_req($add_url, \%del_req, "delete tag");
+  SKIP:
+    {
+      $data or skip("not a json response", 7);
+      ok($data->{success}, "successful");
+
+      # refetch tag list and make sure it's gone
+      my %get_req =
+       (
+        a_tags => 1,
+        id => -1,
+       );
+      my $tags_data = do_req($add_url, \%get_req, "refetch tags");
+      my ($tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+      ok(!$tag, "should be gone");
+
+      # try to delete it again
+      my $redel_data = do_req($add_url, \%del_req, "delete should fail");
+      $redel_data
+       or skip("not a json response", 3);
+      ok(!$redel_data->{success}, "should fail");
+      is($redel_data->{error_code}, "FIELD", "check error code");
+      ok($redel_data->{errors}{tag_id}, "and error message on field");
+    }
+  }
+
+  { # rename a tag
+    my %ren_req =
+      (
+       a_tagrename => 1,
+       id => -1,
+       tag_id => $tag1->{id},
+       name => $tag_name2, # rename over just removed tag
+      );
+
+    my $data = do_req($add_url, \%ren_req, "rename tag");
+  SKIP:
+    {
+      $data
+       or skip("not a json response", 4);
+      ok($data->{success}, "successful");
+      ok($data->{tag}, "returned updated tag");
+      is($data->{tag}{name}, $tag_name2, "check name saved");
+    }
+  }
+
+  { # refetch the article to check the tags
+    my %fetch_req =
+      (
+       a_article => 1,
+       id => $art->{id},
+      );
+    my $data = do_req($add_url, \%fetch_req, "fetch just saved")
+      or skip("no json", 2);
+    ok($data->{success}, "check success");
+    is_deeply($data->{article}{tags}, [ $tag_name2 ],
+             "check the tags");
+  }
+
+  # error handling on save
+ SKIP:
+  { # bad title
+    my %bad_title =
+      (
+       save => 1,
+       id => $art->{id},
+       title => "",
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%bad_title, "save bad title");
+    $data or skip("not a json response", 2);
+    ok(!$data->{success}, "should be failure");
+    is($data->{error_code}, "FIELD", "should be a field error");
+    ok($data->{errors}{title}, "should be a message for the title");
+  }
+ SKIP:
+  { # bad template
+    my %bad_template =
+      (
+       save => 1,
+       id => $art->{id},
+       template => "../../etc/passwd",
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%bad_template, "save bad template");
+    $data or skip("not a json response", 2);
+    ok(!$data->{success}, "should be failure");
+    is($data->{error_code}, "FIELD", "should be a field error");
+    ok($data->{errors}{template}, "should be a message for the template");
+  }
+ SKIP:
+  { # bad last modified
+    my %bad_lastmod =
+      (
+       save => 1,
+       id => $art->{id},
+       title => "test",
+       lastModified => $orig_lastmod,
+      );
+    my $data = do_req($add_url, \%bad_lastmod, "save bad lastmod");
+    $data or skip("not a json response", 2);
+    ok(!$data->{success}, "should be failure");
+    is($data->{error_code}, "LASTMOD", "should be a last mod error");
+  }
+ SKIP:
+  { # bad parent
+    my %bad_parent =
+      (
+       save => 1,
+       id => $art->{id},
+       parentid => $art->{id},
+       lastModified => $art->{lastModified},
+      );
+    my $data = do_req($add_url, \%bad_parent, "save bad parent");
+    $data or skip("not a json response", 2);
+    ok(!$data->{success}, "should be failure");
+    is($data->{error_code}, "PARENT", "should be a parent error");
+  }
+
+  # grab config data for the article
+ SKIP:
+  {
+    my %conf_req =
+      (
+       a_config => 1,
+       id => $art->{id},
+      );
+    my $data = do_req($add_url, \%conf_req, "config data");
+    $data or skip("no json to check", 7);
+    ok($data->{success}, "check for success");
+    ok($data->{templates}, "has templates");
+    ok($data->{thumb_geometries}, "has geometries");
+    ok($data->{defaults}, "has defaults");
+    ok($data->{child_types}, "has child types");
+    is($data->{child_types}[0], "Article", "check child type value");
+    ok($data->{flags}, "has flags");
+  }
+
+ SKIP:
+  { # config article for children of the article
+    my %conf_req =
+      (
+       a_config => 1,
+       parentid => $art->{id},
+      );
+    my $data = do_req($add_url, \%conf_req, "config data");
+    $data or skip("no json to check", 3);
+    ok($data->{success}, "check for success");
+    ok($data->{templates}, "has templates");
+    ok($data->{thumb_geometries}, "has geometries");
+    ok($data->{defaults}, "has defaults");
+  }
+
+ SKIP:
+  { # section config
+    my %conf_req =
+      (
+       a_config => 1,
+       parentid => -1,
+      );
+    my $data = do_req($add_url, \%conf_req, "section config data");
+    $data or skip("no json to check", 3);
+    ok($data->{success}, "check for success");
+    ok($data->{templates}, "has templates");
+    ok($data->{thumb_geometries}, "has geometries");
+    ok($data->{defaults}, "has defaults");
+    use Data::Dumper;
+    note(Dumper($data));
+  }
+
+ SKIP:
+  {
+    my $parent = do_add($add_url, { parentid => -1, title => "parent" }, "add parent");
+    my $kid1 = do_add($add_url, { parentid => $parent->{id}, title => "kid1" }, "add first kid");
+    sleep 2;
+    my $kid2 = do_add($add_url,
+                     {
+                      parentid => $parent->{id},
+                      title => "kid2",
+                      _after => $kid1->{id},
+                     }, "add second child");
+    my @expected_order = ( $kid1->{id}, $kid2->{id} );
+    my %tree_req =
+      (
+       a_tree => 1,
+       id => $parent->{id},
+      );
+    my $data = do_req($add_url, \%tree_req, "get newly ordered tree");
+    ok($data->{success}, "got the tree");
+    my @saved_order = map $_->{id}, @{$data->{articles}};
+    is_deeply(\@saved_order, \@expected_order, "check saved order");
+
+    {
+      {
+       # stepkids
+       my %add_step =
+         (
+          add_stepkid => 1,
+          id => $parent->{id},
+          stepkid => $art->{id},
+          _after => $kid1->{id},
+         );
+       sleep(2);
+       my $result = do_req($add_url, \%add_step, "add stepkid in order");
+       ok($result->{success}, "Successfully");
+       my $rel = $result->{relationship};
+       ok($rel, "has a relationship");
+       is($rel->{childId}, $art->{id}, "check the rel child id");
+       is($rel->{parentId}, $parent->{id}, "check the rel parent id");
+      }
+
+      {
+       # refetch the tree
+       my $data = do_req($add_url, \%tree_req, "get tree with stepkid");
+       my @expected_order = ( $kid1->{id}, $art->{id}, $kid2->{id} );
+       my @found_order = map $_->{id}, @{$data->{allkids}};
+       is_deeply(\@found_order, \@expected_order, "check new order");
+      }
+
+      {
+       # remove the stepkid
+       my %del_step =
+         (
+          del_stepkid => 1,
+          id => $parent->{id},
+          stepkid => $art->{id},
+          _after => $kid1->{id},
+         );
+       my $result = do_req($add_url, \%del_step, "delete stepkid");
+       ok($result->{success}, "check success");
+
+       $result = do_req($add_url, \%del_step, "delete stepkid again (should failed)");
+       ok(!$result->{success}, "it failed");
+
+       my $data = do_req($add_url, \%tree_req, "get tree with stepkid removed");
+       my @expected_order = ( $kid1->{id}, $kid2->{id} );
+       my @found_order = map $_->{id}, @{$data->{allkids}};
+       is_deeply(\@found_order, \@expected_order, "check new order with stepkid removed");
+      }
+    }
+
+    do_req($add_url, { remove => 1, id => $kid1->{id} }, "remove kid1");
+    do_req($add_url, { remove => 1, id => $kid2->{id} }, "remove kid2");
+    do_req($add_url, { remove => 1, id => $parent->{id} }, "remove parent");
+  }
+
+  # delete it
+ SKIP:
+  {
+    my %del_req =
+      (
+       remove => 1,
+       id => $art->{id},
+       _context => $art->{id},
+      );
+    my $data = do_req($add_url, \%del_req, "remove test article");
+    $data or skip("no json from req", 3);
+    ok($data->{success}, "successfully deleted");
+    is($data->{article_id}, $art->{id}, "check id returned");
+    is($data->{context}, $art->{id}, "check context returned");
+  }
+
+  # shouldn't be fetchable anymore
+ SKIP:
+  {
+    my %fetch_req =
+      (
+       a_article => 1,
+       id => $art->{id},
+      );
+    my $data = do_req($add_url, \%fetch_req, "fetch just deleted")
+      or skip("no json", 2);
+    ok(!$data->{success}, "failed as expected");
+  }
+}
+
+SKIP:
+{ # tag cleanup
+  my %clean_req =
+    (
+     a_tagcleanup => 1,
+     id => -1,
+    );
+  my $data = do_req($add_url, \%clean_req, "tag cleanup");
+  $data
+    or skip("no json response", 2);
+  ok($data->{success}, "successful");
+  ok($data->{count}, "should have cleaned up something");
+}
+
+sub do_req {
+  my ($url, $req_data, $comment) = @_;
+
+  my @entries;
+  for my $key (keys %$req_data) {
+    my $value = $req_data->{$key};
+    if (ref $value) {
+      for my $val (@$value) {
+       push @entries, "$key=" . escape_uri($val);
+      }
+    }
+    else {
+      push @entries, "$key=" . escape_uri($value);
+    }
+  }
+  my $content = join("&", @entries);
+
+  print <<EOS;
+# Request:
+# URL: $add_url
+# Content: $content
+EOS
+
+  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
+
+  $req->content($content);
+
+  my $resp = $ua->request($req);
+  ok($resp->is_success, "$comment successful at http level");
+  my $data = eval { from_json($resp->decoded_content) };
+  ok($data, "$comment response decoded as json")
+    or print "# $@\n";
+
+  return $data;
+}
+
+sub do_add {
+  my ($url, $req, $comment) = @_;
+
+  $req->{save} = 1;
+
+  my $result = do_req($url, $req, $comment);
+  my $article;
+ SKIP:
+  {
+    $result or skip("No JSON result", 1);
+    if (ok($result->{success} && $result->{article}, "check success and article")) {
+      return $result->{article};
+    }
+  };
+
+  return;
+}
diff --git a/t/080-remote/020-cat.t b/t/080-remote/020-cat.t
new file mode 100644 (file)
index 0000000..115ae9f
--- /dev/null
@@ -0,0 +1,145 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url);
+use JSON;
+use DevHelp::HTML;
+use Test::More tests => 34;
+use Data::Dumper;
+
+my $ua = make_ua;
+my $baseurl = base_url;
+
+my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
+
+my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
+
+# make a catalog
+my $cat = do_add($add_url, 
+                { 
+                 parentid => 3,
+                 title => "Test Catalog",
+                 type => "Catalog",
+                }, "make test catalog");
+
+is($cat->{generator}, "Generate::Catalog", "make sure it's a catalog");
+
+# and an article
+my $art = do_add($add_url, 
+                {
+                 parentid => -1,
+                 title => "Test article",
+                }, "make test article");
+
+is($art->{generator}, "Generate::Article", "make sure it's an article");
+
+my $prod;
+{
+  # make a product
+  my $result = do_add
+    ($add_url,
+     {
+      type => "Product",
+      parentid => $cat->{id},
+      title => "Some Product",
+     }, "make test product");
+  is($result->{generator}, "Generate::Product",
+     "check generator");
+  $prod = $result;
+}
+
+{
+  # fail to make a product (empty title)
+  my $result = do_req
+    ($add_url,
+     {
+      type => "Product",
+      parentid => $cat->{id},
+      title => "",
+      save => 1,
+     }, "fail to make a product");
+  ok(!$result->{success}, "yep, it failed");
+  is($result->{error_code}, "FIELD", "and correct error code");
+  ok($result->{errors}{title}, "has a title error");
+}
+
+{ # fail to set empty title for a product
+  my $result = do_req
+    ($add_url,
+     {
+      id => $prod->{id},
+      title => "",
+      lastModified => $prod->{lastModified},
+      save => 1,
+     }, "fail to set title to empty");
+  ok(!$result->{success}, "yep, it failed");
+  is($result->{error_code}, "FIELD", "and correct error code");
+  ok($result->{errors}{title}, "has a title error");
+}
+
+{
+  # attempt to reparent the article under the catalog, should fail
+  my $result = do_req($add_url, 
+                     { 
+                      save => 1, 
+                      id=> $art->{id},
+                      parentid => $cat->{id},
+                      lastModified => $art->{lastModified},
+                     },
+                     "reparent article under catalog");
+  ok(!$result->{success}, "should have failed")
+    and print "# $result->{error_code}: $result->{message}\n";
+}
+{
+  # and the other way around
+  my $result = do_req($add_url, 
+                     { 
+                      save => 1, 
+                      id=> $cat->{id},
+                      parentid => $art->{id},
+                      lastModified => $cat->{lastModified},
+                     },
+                     "reparent catalog under article");
+  ok(!$result->{success}, "should have failed")
+    and print "# $result->{error_code}: $result->{message}\n";
+}
+
+do_req($add_url, { remove => 1, id => $prod->{id} }, "remove product");
+do_req($add_url, { remove => 1, id => $art->{id} }, "remove article");
+do_req($add_url, { remove => 1, id => $cat->{id} }, "remove catalog");
+
+sub do_req {
+  my ($url, $req_data, $comment) = @_;
+
+  my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
+  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
+
+  $req->content($content);
+  
+  my $resp = $ua->request($req);
+  ok($resp->is_success, "$comment successful at http level");
+  my $data = eval { from_json($resp->decoded_content) };
+  ok($data, "$comment response decoded as json")
+    or print "# $@: ", $resp->decoded_content, "\n";
+
+  return $data;
+}
+
+sub do_add {
+  my ($url, $req, $comment) = @_;
+
+  $req->{save} = 1;
+
+  my $result = do_req($url, $req, $comment);
+  my $article;
+ SKIP:
+  {
+    $result or skip("No JSON result", 1);
+    if (ok($result->{success} && $result->{article}, "check success and article")) {
+      return $result->{article};
+    }
+
+    print STDERR Dumper($result);
+  };
+
+  return;
+}
diff --git a/t/080-remote/030-parent.t b/t/080-remote/030-parent.t
new file mode 100644 (file)
index 0000000..d689667
--- /dev/null
@@ -0,0 +1,79 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url);
+use JSON;
+use DevHelp::HTML;
+use Test::More tests => 13;
+
+my $ua = make_ua;
+my $baseurl = base_url;
+
+my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
+
+my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
+
+# make a parent
+my $par = do_add($add_url, 
+                { 
+                 parentid => -1,
+                 title => "parent",
+                }, "make test parent");
+
+# and a child
+my $child = do_add($add_url, 
+                {
+                 parentid => $par->{id},
+                 title => "child",
+                }, "make test child");
+
+{
+  # attempt to reparent the parent under the child, should fail
+  my $result = do_req($add_url, 
+                     { 
+                      save => 1, 
+                      id=> $par->{id},
+                      parentid => $child->{id},
+                      lastModified => $par->{lastModified},
+                     },
+                     "reparent parent under child");
+  ok(!$result->{success}, "should have failed")
+    and print "# $result->{error_code}: $result->{message}\n";
+}
+
+do_req($add_url, { remove => 1, id => $child->{id} }, "remove child");
+do_req($add_url, { remove => 1, id => $par->{id} }, "remove parent");
+
+sub do_req {
+  my ($url, $req_data, $comment) = @_;
+
+  my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
+  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
+
+  $req->content($content);
+  
+  my $resp = $ua->request($req);
+  ok($resp->is_success, "$comment successful at http level");
+  my $data = eval { from_json($resp->decoded_content) };
+  ok($data, "$comment response decoded as json")
+    or print "# $@\n";
+
+  return $data;
+}
+
+sub do_add {
+  my ($url, $req, $comment) = @_;
+
+  $req->{save} = 1;
+
+  my $result = do_req($url, $req, $comment);
+  my $article;
+ SKIP:
+  {
+    $result or skip("No JSON result", 1);
+    if (ok($result->{success} && $result->{article}, "check success and article")) {
+      return $result->{article};
+    }
+  };
+
+  return;
+}
diff --git a/t/080-remote/040-steps.t b/t/080-remote/040-steps.t
new file mode 100644 (file)
index 0000000..00934b8
--- /dev/null
@@ -0,0 +1,208 @@
+#!perl -w
+use strict;
+use BSE::Test qw(make_ua base_url);
+use JSON;
+use DevHelp::HTML;
+use Test::More tests => 93;
+use Data::Dumper;
+
+my $ua = make_ua;
+my $baseurl = base_url;
+
+my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
+
+my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
+
+my $parent = do_add({ parentid => -1, title => "parent2" }, "make parent");
+sleep 1;
+my @kids1;
+my @kids2;
+for my $num (1..3) {
+  push @kids1, 
+    do_add({ parentid => $parent->{id}, title => "kid$num"}, "make parent  first kid");
+sleep 1;
+}
+
+for my $num (1..3) {
+  push @kids2,
+    do_add({ parentid => $kids1[1]{id}, title => "kid2 - kid $num"}, "make kid2 1 first kid");
+  sleep 1;
+}
+
+my $base = do_add({ parentid => -1, title => "base" }, "make base article");
+sleep 1;
+
+{
+  my %add_step =
+    (
+     add_stepkid => 1,
+     id => $parent->{id},
+     stepkid => $base->{id},
+     _after => $kids1[1]{id},
+    );
+  my $step_res = do_req($add_url, \%add_step, "add step kid in order");
+  ok($step_res->{success}, "add step kid success")
+    or diag(Dumper($step_res));
+
+  my %tree_req =
+    (
+     a_tree => 1,
+     id => $parent->{id},
+    );
+  my $result = do_req($add_url, \%tree_req, "get order");
+  ok($result->{success}, "got tree ok");
+  my @got_order = map $_->{id}, @{$result->{allkids}};
+  my @exp_order = ( $kids1[2]{id}, $kids1[1]{id}, $base->{id}, $kids1[0]{id} );
+  is_deeply(\@got_order, \@exp_order, "check kid inserted correctly")
+}
+
+{
+  my %move_step =
+    (
+     a_restepkid => 1,
+     id => $base->{id},
+     parentid => $parent->{id},
+     newparentid => $kids1[1]{id},
+     _after => $kids2[1]{id},
+    );
+  my $restep_res = do_req($add_url, \%move_step, "move stepkid in order");
+  ok($restep_res->{success}, "restep kid success")
+    or diag(Dumper($restep_res));
+
+  {
+    # shouldn't be under $parent anymore
+    my %tree_req =
+      (
+       a_tree => 1,
+       id => $parent->{id},
+      );
+    my $result = do_req($add_url, \%tree_req, "get parent order");
+    ok($result->{success}, "got tree ok");
+    my @got_order = map $_->{id}, @{$result->{allkids}};
+    my @exp_order = ( $kids1[2]{id}, $kids1[1]{id}, $kids1[0]{id} );
+    is_deeply(\@got_order, \@exp_order, "check kid moved away correctly")
+  }
+  {
+    my %tree_req =
+      (
+       a_tree => 1,
+       id => $kids1[1]->{id},
+      );
+    my $result = do_req($add_url, \%tree_req, "get kids1[1] order");
+    ok($result->{success}, "got tree ok");
+    my @got_order = map $_->{id}, @{$result->{allkids}};
+    my @exp_order = ( $kids2[2]{id}, $kids2[1]{id}, $base->{id}, $kids2[0]{id} );
+    is_deeply(\@got_order, \@exp_order, "check kid inserted correctly")
+  }
+}
+
+{
+  # various error handling checks
+  my %base_req =
+    (
+     a_restepkid => 1,
+     id => $base->{id},
+    );
+
+  {
+    # no parentid
+    my $badpar_res = do_req
+      ($add_url, { %base_req }, "missing parentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "NOPARENTID", "check error");
+  }
+  $base_req{parentid} = $kids1[1]{id};
+  {
+    # invalid parentid
+    my $badpar_res = do_req
+      ($add_url, { %base_req, parentid => "abc"}, "bad parentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "BADPARENTID", "check error");
+  }
+  {
+    # unknown parentid
+    my $badpar_res = do_req
+      ($add_url, { %base_req, parentid => 1000+$base->{id}}, "unknown parentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "NOTFOUND", "check error");
+  }
+  {
+    # invalid newparentid
+    my $badpar_res = do_req
+      ($add_url, { %base_req, newparentid => "abc"}, "bad newparentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "BADNEWPARENT", "check error");
+  }
+  {
+    # unknown newparentid
+    my $badpar_res = do_req
+      ($add_url, { %base_req, newparentid => 1000+$base->{id}}, "unknown newparentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "UNKNOWNNEWPARENT", "check error");
+  }
+
+  {
+    # duplicate
+    my %add_step =
+      (
+       add_stepkid => 1,
+       id => $parent->{id},
+       stepkid => $base->{id},
+      );
+    my $step_res = do_req($add_url, \%add_step, "add step kid in order");
+    ok($step_res->{success}, "add step kid success")
+      or diag(Dumper($step_res));
+
+    my $badpar_res = do_req
+      ($add_url, { %base_req, newparentid => $parent->{id}}, "duplicate newparentid");
+    ok(!$badpar_res->{success}, "should fail");
+    is($badpar_res->{error_code}, "NEWPARENTDUP", "check error");
+  }
+}
+
+for my $art (@kids2, @kids1, $parent, $base) {
+  my %del_req =
+    (
+     remove => 1,
+     id => $art->{id},
+    );
+  my $result = do_req($add_url, \%del_req, "remove $art->{title}");
+  ok($result && $result->{success}, "got a remove result")
+    or diag(Dumper($result));
+}
+
+sub do_req {
+  my ($url, $req_data, $comment) = @_;
+
+  my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
+  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
+
+  $req->content($content);
+  
+  my $resp = $ua->request($req);
+  ok($resp->is_success, "$comment successful at http level");
+  my $data = eval { from_json($resp->decoded_content) };
+  ok($data, "$comment response decoded as json")
+    or print "# $@\n";
+
+  return $data;
+}
+
+sub do_add {
+  my ($req, $comment) = @_;
+
+  $req->{save} = 1;
+
+  my $result = do_req($add_url, $req, $comment);
+  my $article;
+ SKIP:
+  {
+    $result or skip("No JSON result", 1);
+    if (ok($result->{success} && $result->{article}, "check success and article")) {
+      return $result->{article};
+    }
+  };
+  diag(Dumper($result));
+
+  return;
+}
diff --git a/t/100-payment/010-securepayxml.t b/t/100-payment/010-securepayxml.t
new file mode 100644 (file)
index 0000000..157dc7d
--- /dev/null
@@ -0,0 +1,175 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval "use XML::Simple; 1"
+    or plan skip_all => "No XML::Simple";
+  eval { require LWP::UserAgent; 1 }
+    or plan skip_all => "No XML::LibXML";
+  eval { require Crypt::SSLeay; 1 }
+    or plan skip_all => "No Crypt::SSLeay";
+
+  plan tests => 27;
+}
+
+++$|;
+
+my $debug = 0;
+
+my $gotmodule;
+BEGIN { $gotmodule = use_ok('DevHelp::Payments::SecurePayXML'); }
+
+my %cfg_good =
+  (
+   testmerchantid=>'ABC0001',
+   testpassword=>'abc123',
+   test=>1,
+   debug => $debug,
+  );
+
+my $cfg = bless \%cfg_good, 'Test::Cfg';
+
+my $payment = DevHelp::Payments::SecurePayXML->new($cfg);
+
+ok($payment, 'make payment object');
+
+my %req =
+  (
+   cardnumber => '4242424242424242',
+   expirydate => '200708',
+   amount => 1000,
+   orderno => time,
+  );
+
+my $result = $payment->payment(%req);
+ok($result, "got some sort of result");
+ok($result->{success}, "successful!")
+  or print "# $result->{error}\n";
+ok($result->{receipt}, "got a receipt: $result->{receipt}");
+
+my %req_bad = 
+  (
+   cardnumber => '4242424242424242',
+   expirydate => '200405', # out of date CC #
+   amount => 1010, # on test server, cents returned as status
+   orderno => time,
+  );
+
+$result = $payment->payment(%req_bad);
+ok($result, "got some sort of result");
+ok(!$result->{success}, "failed as expected");
+ok($result->{error}, "got an error: $result->{error}");
+
+# try to create a periodic payment
+my %add =
+  (
+   clientid => 'AAAA',
+   expirydate => '08/07',
+   cardnumber => '4242424242424242',
+  );
+$result = $payment->add_payment(%add);
+ok($result, "got some sort of result")
+  or print "# $result->{error}\n";
+ok($result->{success}, "successful!")
+  or print "# failed add_payment: ",$result->{error}, "\n";
+print "# payment id: $result->{paymentid}\n";
+ok($result->{paymentid}, "got a payment id");
+
+my $paymentid = $result->{paymentid};
+
+my %trigger =
+  (
+   paymentid => $paymentid,
+   amount => 1500,
+  );
+
+print "# trigger a payment\n";
+$result = $payment->make_payment(%trigger);
+ok($result, "got some sort of result");
+ok($result->{success}, "success!");
+ok($result->{receipt}, "check receipt");
+
+print "# delete the payment\n";
+my %delete =
+  (
+   paymentid => $paymentid
+  );
+$result = $payment->delete_payment(%delete);
+ok($result, "got some sort of result");
+ok($result->{success}, "success!")
+  or print "# delete error: $result->{error}\n";
+
+print "# try a bad triggered payment\n";
+my %bad_trigger =
+  (
+   paymentid => $paymentid,
+   amount => 1000,
+  );
+$result = $payment->make_payment(%bad_trigger);
+ok($result, "got some sort of result");
+ok(!$result->{success}, "shouldn't be successful");
+print "# bad trigger error: $result->{error}\n";
+
+my %bad_add =
+  (
+   clientid => 'BBBB',
+   expirydate => '05/05',
+   cardnumber => '4242424242424242',
+  );
+$result = $payment->add_payment(%bad_add);
+ok($result, "got some sort of result");
+{
+  local $TODO = "back end doesn't fail on bad expiry";
+  ok(!$result->{success}, "should fail on bad expiry");
+  isnt($result->{error}, "Successful", "should set error");
+  print "# bad add_payment: ",$result->{error}, "\n";
+}
+
+# try to fail one with a bad password
+my %cfg_bad =
+  (
+   testmerchantid=>'ABC0001x',
+   testpassword=>'abc123xyz',
+   test=>1,
+   debug => $debug,
+  );
+
+$cfg = bless \%cfg_bad, 'Test::Cfg';
+
+$payment = DevHelp::Payments::SecurePayXML->new($cfg);
+
+$result = $payment->payment(%req);
+ok($result, "got some sort of result");
+ok(!$result->{success}, "failed as expected");
+ok($result->{error}, "got an error: $result->{error}");
+
+# try to fail one with a bad connectivity
+my %cfg_bad2 =
+  (
+   testmerchantid=>'ABC0001',
+   testpassword=>'abc123',
+   testurl => 'https://undefined.develop-help.com/xmltest',
+   test=>1,
+   debug => $debug,
+  );
+
+$cfg = bless \%cfg_bad2, 'Test::Cfg';
+
+$payment = DevHelp::Payments::SecurePayXML->new($cfg);
+
+$result = $payment->payment(%req);
+ok($result, "got some sort of result");
+ok(!$result->{success}, "failed as expected");
+ok($result->{error}, "got an error: $result->{error}");
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  $section eq 'securepay xml' or die;
+  exists $self->{$key} or return $def;
+
+  return $self->{$key};
+}
diff --git a/t/100-payment/020-nabtransactxml.t b/t/100-payment/020-nabtransactxml.t
new file mode 100644 (file)
index 0000000..507c771
--- /dev/null
@@ -0,0 +1,119 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval "use XML::Simple; 1"
+    or plan skip_all => "No XML::Simple";
+  eval { require LWP::UserAgent; 1 }
+    or plan skip_all => "No XML::LibXML";
+  eval { require Crypt::SSLeay; 1 }
+    or plan skip_all => "No Crypt::SSLeay";
+
+  plan tests => 14;
+}
+
+++$|;
+
+my $debug = 0;
+
+my $gotmodule;
+BEGIN { $gotmodule = use_ok('DevHelp::Payments::SecurePayXML'); }
+
+my %cfg_good =
+  (
+   testmerchantid=>'xyz0010',
+   testpassword=>'abcd1234',
+   test=>1,
+   debug => $debug,
+   vendor => "nab",
+  );
+
+my $cfg = bless \%cfg_good, 'Test::Cfg';
+
+my $payment = DevHelp::Payments::SecurePayXML->new($cfg);
+
+ok($payment, 'make payment object');
+
+my %req =
+  (
+   cardnumber => '4242424242424242',
+   expirydate => '201008',
+   amount => 1000,
+   orderno => time,
+   cvv => "999",
+  );
+
+my $result = $payment->payment(%req);
+ok($result, "got some sort of result");
+ok($result->{success}, "successful!")
+  or print "# $result->{error}\n";
+ok($result->{receipt}, "got a receipt: $result->{receipt}");
+
+my %req_bad = 
+  (
+   cardnumber => '4242424242424242',
+   expirydate => '200405', # out of date CC #
+   amount => 1000, # on test server, cents returned as status
+   orderno => time,
+  );
+
+$result = $payment->payment(%req_bad);
+ok($result, "got some sort of result");
+{
+  local $TODO = "backend doesn't fail on CC expiry";
+  ok(!$result->{success}, "failed as expected (bad CC expiry)");
+  isnt($result->{error}, "Approved", "got an error: $result->{error}");
+}
+
+# try to fail one with a bad password
+my %cfg_bad =
+  (
+   testmerchantid=>'xyz0010', ##'ABC0001x',
+   testpassword=>'abc123xyz',
+   test=>1,
+   debug => $debug,
+   vendor => "nab",
+  );
+
+$cfg = bless \%cfg_bad, 'Test::Cfg';
+
+$payment = DevHelp::Payments::SecurePayXML->new($cfg);
+$result = $payment->payment(%req);
+ok($result, "got some sort of result");
+{
+  local $TODO = "backend doesn't fail on bad password";
+  ok(!$result->{success}, "failed as expected (bad password)");
+  isnt($result->{error}, "Approved", "got an error: $result->{error}");
+}
+
+# try to fail one with a bad connectivity
+my %cfg_bad2 =
+  (
+   testmerchantid=>'xyz0010',
+   testpassword=>'abcd1234',
+   testurl => 'https://undefined.develop-help.com/xmltest',
+   test=>1,
+   debug => $debug,
+   vendor => "nab",
+  );
+
+$cfg = bless \%cfg_bad2, 'Test::Cfg';
+
+$payment = DevHelp::Payments::SecurePayXML->new($cfg);
+
+$result = $payment->payment(%req);
+ok($result, "got some sort of result");
+ok(!$result->{success}, "failed as expected");
+ok($result->{error}, "got an error: $result->{error}");
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  $section eq 'securepay xml' or die;
+  exists $self->{$key} or return $def;
+
+  return $self->{$key};
+}
diff --git a/t/100-payment/030-eway.t b/t/100-payment/030-eway.t
new file mode 100644 (file)
index 0000000..ba5c435
--- /dev/null
@@ -0,0 +1,140 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval { require XML::LibXML; }
+    or plan skip_all => "No XML::LibXML";
+  eval { require LWP::UserAgent; }
+    or plan skip_all => "No XML::LibXML";
+  eval { require Crypt::SSLeay; }
+    or plan skip_all => "No Crypt::SSLeay";
+
+  plan tests => 17;
+}
+
+++$|;
+
+my $debug = 1;
+
+my $gotmodule;
+BEGIN { $gotmodule = use_ok('DevHelp::Payments::Eway'); }
+
+my %cfg_good =
+  (
+   test=>1,
+   debug => $debug,
+  );
+
+my $cfg = bless \%cfg_good, 'Test::Cfg';
+
+my $payment = DevHelp::Payments::Eway->new($cfg);
+
+ok($payment, 'make payment object');
+
+{
+  my %req =
+    (  
+     cardnumber => '4444333322221111',
+     expirydate => '200708',
+     nameoncard => "Joseph Bloe",
+     amount => 1000,
+     orderno => time,
+     cvv => "123",
+    );
+
+  my $result = $payment->payment(%req);
+  ok($result->{success}, "successful");
+  ok($result->{receipt}, "got a receipt");
+  ok($result->{transactionid}, "got a transaction id");
+}
+
+{
+  my %req =
+    (  
+     cardnumber => '4444333322221111',
+     expirydate => '200708',
+     nameoncard => "Joseph Bloe",
+     amount => 1000,
+     orderno => time,
+     cvv => "123",
+     currency => "AUD",
+    );
+
+  my $result = $payment->payment(%req);
+  ok($result->{success}, "successful with AUD");
+  ok($result->{receipt}, "got a receipt");
+  ok($result->{transactionid}, "got a transaction id");
+}
+
+{ # supply everything
+  my %req =
+    (  
+     cardnumber => '4444333322221111',
+     expirydate => '200708',
+     nameoncard => "Joseph Bloe",
+     amount => 1000,
+     orderno => time,
+     cvv => "123",
+     currency => "AUD",
+     firstname => "Joseph",
+     lastname => "Bloe",
+     address1 => "Unit 1",
+     address2 => "56 Unknown Pde",
+     suburb => "Sydney",
+     postcode => "2345",
+     state => "NSW",
+     countrycode => "AU",
+     email => 'test@example.com',
+     description => "Test transaction",
+     ipaddress => "127.0.0.1",
+    );
+
+  my $result = $payment->payment(%req);
+  ok($result->{success}, "successful with details");
+  ok($result->{receipt}, "got a receipt");
+  ok($result->{transactionid}, "got a transaction id");
+}
+
+{
+  my %req =
+    (
+     cardnumber => '4242424242424242',
+     expirydate => '200708',
+     nameoncard => "Joseph Bloe",
+     amount => 1000,
+     orderno => time,
+     cvv => "321",
+    );
+  my $result = $payment->payment(%req);
+  ok(!$result->{success}, "failure (bad card number)");
+  ok($result->{statuscode}, "got an error code");
+  like($result->{error}, qr/credit card/, "error should mention credit card");
+}
+
+{
+  my %req =
+    (
+     cardnumber => '4444333322221111',
+     expirydate => '200708',
+     nameoncard => "Joseph Bloe",
+     amount => 1001,
+     orderno => time,
+     cvv => "321",
+    );
+  my $result = $payment->payment(%req);
+  ok(!$result->{success}, "failure (generated error)");
+  like($result->{statuscode}, qr/[0-9]+/, "got a numeric error code");
+  like($result->{error}, qr/^Refer to Issuer/, "match expected message");
+}
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  $section eq 'eway payments' or die;
+  exists $self->{$key} or return $def;
+
+  return $self->{$key};
+}
diff --git a/t/110-courier/010-fastway.t b/t/110-courier/010-fastway.t
new file mode 100644 (file)
index 0000000..79ad005
--- /dev/null
@@ -0,0 +1,82 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval "use XML::Simple; 1"
+    or plan skip_all => "No XML::Simple";
+
+  plan tests => 7;
+}
+
+use Courier::Fastway::Road;
+use BSE::Shipping;
+
+my %cfg_work = 
+  (
+   shipping => 
+   {
+    sourcepostcode => "4350",
+    fastwayfranchisee => "TOO",
+   },
+   debug =>
+   {
+    fastway => 0,
+   },
+  );
+
+my $cfg = bless \%cfg_work, "Test::Cfg";
+
+my $cour = Courier::Fastway::Road->new(config => $cfg);
+ok($cour, "make courier object");
+ok($cour->can_deliver(country => "AU",
+                     suburb => "Westmead",
+                     postcode => "2145"), "can deliver to australia");
+ok(!$cour->can_deliver(country => "NZ"),
+   "can't deliver to NZ");
+
+my $small_parcel = BSE::Shipping::Parcel->new
+  (
+   length => 100,
+   width => 200,
+   height => 200,
+   weight => 800
+  );
+
+my $medium_parcel = BSE::Shipping::Parcel->new
+  (
+   length => 500,
+   width => 400,
+   height => 400,
+   weight => 6000
+  );
+
+my $local_small_cost = $cour->calculate_shipping
+  (
+   parcels => [ $small_parcel ],
+   postcode => 4405,
+   suburb => "Dalby",
+   country => "AU"
+  );
+ok($local_small_cost, "got a local small parcel cost");
+like($local_small_cost, qr/^\d+$/, "it's an integer");
+
+my $local_medium_cost = $cour->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 4405,
+   suburb => "Dalby",
+   country => "AU"
+  );
+ok($local_medium_cost, "got a local medium cost");
+like($local_medium_cost, qr/^\d+$/, "it's an integer");
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  exists $self->{$section} or return $def;
+  exists $self->{$section}{$key} or return $def;
+  return $self->{$section}{$key};
+}
diff --git a/t/110-courier/020-auspost.t b/t/110-courier/020-auspost.t
new file mode 100644 (file)
index 0000000..84a3177
--- /dev/null
@@ -0,0 +1,195 @@
+#!perl -w
+use strict;
+use Test::More tests => 27;
+
+use Courier::AustraliaPost::Standard;
+use Courier::AustraliaPost::Air;
+use Courier::AustraliaPost::Sea;
+use BSE::Shipping;
+
+my %cfg_work = 
+  (
+   shipping => 
+   {
+    sourcepostcode => "4350",
+   },
+   debug =>
+   {
+    auspost => 0
+   },
+  );
+
+my $cfg = bless \%cfg_work, "Test::Cfg";
+
+my $std = Courier::AustraliaPost::Standard->new(config => $cfg);
+my $air = Courier::AustraliaPost::Air->new(config => $cfg);
+my $sea = Courier::AustraliaPost::Sea->new(config => $cfg);
+
+ok($std, "make standard courier object");
+ok($std->can_deliver(country => "AU",
+                     suburb => "Westmead",
+                     postcode => "2145"), "can deliver to australia");
+ok(!$std->can_deliver(country => "NZ"),
+   "can't deliver to NZ");
+
+my $tiny_parcel = BSE::Shipping::Parcel->new
+  (
+   length => 50,
+   width => 20,
+   height => 20,
+   weight => 200
+  );
+my $small_parcel = BSE::Shipping::Parcel->new
+  (
+   length => 100,
+   width => 200,
+   height => 200,
+   weight => 800
+  );
+
+my $medium_parcel = BSE::Shipping::Parcel->new
+  (
+   length => 500,
+   width => 400,
+   height => 300,
+   weight => 6000
+  );
+
+my $local_tiny_cost = $std->calculate_shipping
+  (
+   parcels => [ $tiny_parcel ],
+   postcode => 4405,
+   suburb => "Dalby",
+   country => "AU"
+  );
+ok($local_tiny_cost, "got a local tiny parcel cost")
+  or diag $std->error_message;
+like($local_tiny_cost, qr/^\d+$/, "it's an integer");
+print "# $local_tiny_cost\n";
+
+my $local_small_cost = $std->calculate_shipping
+  (
+   parcels => [ $small_parcel ],
+   postcode => 4405,
+   suburb => "Dalby",
+   country => "AU"
+  );
+ok($local_small_cost, "got a local small parcel cost")
+  or diag $std->error_message;
+like($local_small_cost, qr/^\d+$/, "it's an integer");
+print "# $local_small_cost\n";
+
+my $local_medium_cost = $std->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 4405,
+   suburb => "Dalby",
+   country => "AU"
+  );
+ok($local_medium_cost, "got a local medium cost")
+  or diag $std->error_message;
+like($local_medium_cost, qr/^\d+$/, "it's an integer");
+print "# $local_medium_cost\n";
+cmp_ok($local_tiny_cost, "<=", $local_small_cost, "tiny < small");
+cmp_ok($local_small_cost, "<=", $local_medium_cost, "small < medium");
+
+# longer distance
+my $nsw_medium_cost = $std->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 2145,
+   suburb => "Westmead",
+   country => "AU"
+  );
+
+ok($nsw_medium_cost, "got a nsw medium cost");
+like($nsw_medium_cost, qr/^\d+$/, "it's an integer");
+print "# $nsw_medium_cost\n";
+cmp_ok($local_medium_cost, "<=", $nsw_medium_cost, "local <= nsw");
+
+# longest
+my $perth_medium_cost = $std->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 6000,
+   suburb => "Perth",
+   country => "AU"
+  );
+
+ok($perth_medium_cost, "got a perth medium cost");
+like($perth_medium_cost, qr/^\d+$/, "it's an integer");
+print "# $perth_medium_cost\n";
+cmp_ok($nsw_medium_cost, "<=", $perth_medium_cost, "nsw <= perth");
+
+# international
+my $us_medium_cost_air = $air->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 6000,
+   suburb => "Perth",
+   country => "US"
+  );
+
+ok($us_medium_cost_air, "got a US medium cost");
+like($us_medium_cost_air, qr/^\d+$/, "it's an integer");
+print "# $us_medium_cost_air\n";
+cmp_ok($perth_medium_cost, "<=", $us_medium_cost_air, "perth <= us air");
+
+my $us_medium_cost_sea = $sea->calculate_shipping
+  (
+   parcels => [ $medium_parcel ],
+   postcode => 6000,
+   suburb => "Perth",
+   country => "US"
+  );
+
+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");
+
+# too big
+my $too_long = BSE::Shipping::Parcel->new
+  (
+   length => 1060,
+   width => 100,
+   height => 100,
+   weight => 200
+  );
+my $too_long_cost = $std->calculate_shipping
+  (
+   parcels => [ $too_long ],
+   postcode => 2145,
+   suburb => "Westmead",
+   country => "AU",
+  );
+is($too_long_cost, undef, "too long returns undef");
+ok($std->error_message, "some error set");
+
+my $big_girth = BSE::Shipping::Parcel->new
+  (
+   length => 4000,
+   width => 300,
+   height => 500,
+   weight => 200
+  );
+
+my $big_girth_cost = $std->calculate_shipping
+  (
+   parcels => [ $big_girth ],
+   postcode => 2145,
+   suburb => "Westmead",
+   country => "AU",
+  );
+is($too_long_cost, undef, "big girth returns undef");
+ok($std->error_message, "some error set");
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $def) = @_;
+
+  exists $self->{$section} or return $def;
+  exists $self->{$section}{$key} or return $def;
+  return $self->{$section}{$key};
+}
diff --git a/t/110-courier/030-by-unit.t b/t/110-courier/030-by-unit.t
new file mode 100644 (file)
index 0000000..abf2d9b
--- /dev/null
@@ -0,0 +1,49 @@
+#!perl -w
+use strict;
+use Test::More tests => 8;
+use BSE::Cfg;
+use Courier::ByUnitAU;
+
+my $cfg = BSE::Cfg->new_from_text(text => <<EOS, path => ".");
+[by unit au shipping]
+description=testing
+base=1000
+perunit=100
+EOS
+
+my $c = Courier::ByUnitAU->new
+  (
+   config => $cfg,
+  );
+
+ok($c, "create courier object");
+is($c->description, "testing", "test description");
+is($c->name, "by-unit-au", "check name");
+ok($c->can_deliver(country => "AU"), "can deliver to australia");
+ok(!$c->can_deliver(country => "US"), "Can't deliver to US");
+is($c->calculate_shipping
+   (
+    country => "AU",
+    items =>
+    [
+     { units => 1 }
+    ]
+   ), 1000, "one unit order");
+is($c->calculate_shipping
+   (
+    country => "AU",
+    items =>
+    [
+     { units => 2 }
+    ]
+   ), 1100, "two unit order");
+is($c->calculate_shipping
+   (
+    country => "AU",
+    items =>
+    [
+     { units => 2 },
+     { units => 1 },
+     { units => 1 }
+    ]
+   ), 1300, "four unit order");
diff --git a/t/120-thumb/00load.t b/t/120-thumb/00load.t
new file mode 100644 (file)
index 0000000..8ca72be
--- /dev/null
@@ -0,0 +1,11 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval "use Imager; 1"
+    or plan skip_all => "Imager not installed";
+}
+
+plan tests => 1;
+use_ok("BSE::Thumb::Imager");
diff --git a/t/120-thumb/10scale.t b/t/120-thumb/10scale.t
new file mode 100644 (file)
index 0000000..201bed3
--- /dev/null
@@ -0,0 +1,116 @@
+#!perl -w
+use strict;
+use Test::More;
+
+BEGIN {
+  eval <<EOS
+use Imager;
+use Imager::File::PNG;
+use Imager::File::GIF;
+use Imager::File::JPEG;
+1;
+EOS
+    or plan skip_all => "Imager or a needed file module not installed";
+}
+
+use BSE::Thumb::Imager;
+use Imager::Test qw(is_image_similar);
+
+my @dimension_tests =
+  ( # input geo, width, height, type, output width, height, type
+   [ "scale(100x100)", 200, 100, "", 100, 50, "" ],
+   [ "scale(100x100,fill:808080)", 200, 100, "", 100, 100, "" ],
+   [ "scale(100x100c)", 150, 80, "", 100, 80, "" ],
+   [ "scale(100x100c)", 150, 110, "", 100, 100, "" ],
+  );
+
+my @image_tests =
+  (
+   # geo, input, reference output, max diff (def: 1000)
+   [ "scale(40x30)", "simple.png", "scale40x30.png" ],
+   [ "scale(40x30,fill:808080)", "simple.png", "scale40x30fill.png" ],
+  );
+
+plan tests => 8 + 3 * @dimension_tests + 4 * @image_tests;
+
+my $cfg = bless
+  {
+  }, "Test::Cfg";
+
+my $th = BSE::Thumb::Imager->new($cfg);
+ok($th, "make driver object");
+
+{ # parsing
+  my $error;
+  ok($th->validate_geometry("scale(100x)", \$error),
+     "validate scale(100x)");
+  ok($th->validate_geometry("scale(100x100)", \$error),
+     "validate scale(100x100)");
+  ok($th->validate_geometry("scale(x100)", \$error),
+     "validate scale(x100)");
+  ok($th->validate_geometry("scale(100x100c)", \$error),
+     "validate scale(100x100c)");
+  ok($th->validate_geometry("scale(100x100,fill:808080)", \$error),
+     "validate scale(100x100,fill:808080)");
+  ok(!$th->validate_geometry("scale(100x,fill:808080)", \$error),
+     "fail validate scale(100x,fill:808080)");
+  is($error, "scale:Both dimensions must be supplied for fill",
+     "check error message");
+}
+
+{ # dimensions
+  for my $test (@dimension_tests) {
+    my ($geo, $in_w, $in_h, $in_type, $out_w, $out_h, $out_type) = @$test;
+
+    my $name = "$geo/$in_w/$in_h";
+    my ($result_w, $result_h, $result_type) =
+      $th->thumb_dimensions_sized($geo, $in_w, $in_h, $in_type);
+    is($result_w, $out_w, "dim $name: check output width");
+    is($result_h, $out_h, "dim $name: check output height");
+    is($result_type, $out_type, "dim $name: check output type");
+  }
+}
+
+{ # image results
+  for my $test (@image_tests) {
+    my ($geo, $infile, $reffile, $maxdiff) = @$test;
+
+    defined $maxdiff or $maxdiff = 1000;
+
+    my $name = "$geo/$infile";
+
+  SKIP:
+    {
+      my $error;
+      my ($data, $type) =
+       $th->thumb_data(filename => "t/120-thumb/data/$infile",
+                       geometry => $geo,
+                       error => \$error);
+      ok($data, "$name: made a thumb")
+       or skip("no thumb data to check", 3);
+
+      my $outim = Imager->new;
+      ok($outim->read(data => $data),
+        "$name: get the image data back as an image")
+       or skip("can't compare an image I can't read", 2);
+      my $refim = Imager->new;
+      ok($refim->read(file => "t/120-thumb/data/$reffile"),
+        "$name: get the reference image file as an image")
+       or skip("can't compare an image I can't read", 1);
+      is_image_similar($outim, $refim, $maxdiff,
+                      "$name: compare");
+    }
+  }
+}
+
+package Test::Cfg;
+
+sub entry {
+  my ($self, $section, $key, $default) = @_;
+
+  $section eq "imager thumb driver"
+    or return $default;
+  $self->{$key}
+    and return $self->{$key};
+  return $default;
+}
diff --git a/t/120-thumb/data/scale40x30.png b/t/120-thumb/data/scale40x30.png
new file mode 100644 (file)
index 0000000..738349c
Binary files /dev/null and b/t/120-thumb/data/scale40x30.png differ
diff --git a/t/120-thumb/data/scale40x30fill.png b/t/120-thumb/data/scale40x30fill.png
new file mode 100644 (file)
index 0000000..7b78076
Binary files /dev/null and b/t/120-thumb/data/scale40x30fill.png differ
diff --git a/t/120-thumb/data/simple.png b/t/120-thumb/data/simple.png
new file mode 100644 (file)
index 0000000..3c54f38
Binary files /dev/null and b/t/120-thumb/data/simple.png differ
diff --git a/t/900-kwalitee/010-strict-warn.t b/t/900-kwalitee/010-strict-warn.t
new file mode 100644 (file)
index 0000000..5a56be0
--- /dev/null
@@ -0,0 +1,25 @@
+#!perl -w
+use strict;
+use BSE::Test qw(ok);
+use File::Find;
+
+my @files;
+open MANIFEST, "< MANIFEST" or die "Cannot open MANIFEST";
+while (<MANIFEST>) {
+  chomp;
+  next if /^\s*\#/;
+  s/\s+.*//;
+  push @files, $_ if /\.(pm|t|pl)$/;
+}
+close MANIFEST;
+my @scripts = grep /\.(pl|t)$/, @files;
+print "1..",scalar(@files) + scalar(@scripts),"\n";
+for my $file (@files) {
+  open SRC, "< $file" or die "Cannot open $file: $!";
+  my $data = do { local $/; <SRC> };
+  close SRC;
+  ok($data =~ /^use\s+strict/m, "use strict in $file");
+  if ($file =~ /\.(pl|t)$/) {
+    ok($data =~ /#!.*perl.*-w|use warnings;/m, "-w or use warnings in $file");
+  }
+}
diff --git a/t/900-kwalitee/020-checktemplates.t b/t/900-kwalitee/020-checktemplates.t
new file mode 100644 (file)
index 0000000..93cdd93
--- /dev/null
@@ -0,0 +1,34 @@
+#!perl
+use strict;
+use warnings;
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+use Squirrel::Template;
+
+my $mani = maniread();
+
+$| = 1;
+my @templates = map m(^site/templates/(.*)$),
+  sort grep m(^site/templates/.*\.tmpl$), keys %$mani;
+
+plan tests => scalar @templates;
+
+my $templater = Squirrel::Template->new
+   (
+    charset => "utf-8",
+    utf8 => 1,
+    template_dir => "site/templates",
+   );
+for my $file (@templates) {
+  my ($p, $message) = $templater->parse_file($file);
+  if ($p) {
+    my @errors = $templater->errors;
+    ok(!@errors, "check $file for template errors");
+    diag("$_->[3]:$_->[2]: $_->[4]") for @errors;
+    $templater->clear_errors;
+  }
+  else {
+    fail("check $file for template errors");
+    diag($message);
+  }
+}
diff --git a/t/900-kwalitee/030-messages.t b/t/900-kwalitee/030-messages.t
new file mode 100644 (file)
index 0000000..a366d25
--- /dev/null
@@ -0,0 +1,44 @@
+#!perl -w
+use strict;
+use DevHelp::LoaderData;
+use BSE::MessageScanner;
+use Test::More;
+
+# check that the core message bases and defaults cover all of the ids
+# used in BSE.
+
+# load the data
+my @base = _load("site/data/db/bse_msg_base.data");
+my %base = map { $_->{id} => 1 } @base;
+my @defs = _load("site/data/db/bse_msg_defaults.data");
+my %defs = map { $_->{id} => 1 } @defs;
+
+# scan for ids
+my @msgs = BSE::MessageScanner->scan([ "site" ]);
+
+# make them unique, we don't need a bunch of errors for one id
+my %seen;
+@msgs = grep !$seen{$_->[0]}, @msgs;
+
+plan tests => 2 * scalar(@msgs);
+
+for my $msg (@msgs) {
+  my ($id, $file, $line) = @$msg;
+  (my $subid = $id) =~ s/^msg://;
+  ok($base{$subid}, "found base for $id ($file:$line)");
+  ok($defs{$subid}, "found default for $id ($file:$line)");
+}
+
+sub _load {
+  my ($in_name) = @_;
+
+  open my $fh, "<", $in_name
+    or die "Cannot open $in_name: $!";
+  my $loader = DevHelp::LoaderData->new($fh);
+  my @data;
+  while (my $row = $loader->read) {
+    push @data, $row;
+  }
+
+  return @data;
+}
diff --git a/t/900-kwalitee/040-podcheck.t b/t/900-kwalitee/040-podcheck.t
new file mode 100644 (file)
index 0000000..6ac35e8
--- /dev/null
@@ -0,0 +1,142 @@
+#!perl -w
+use strict;
+use Test::More;
+use Getopt::Long;
+use ExtUtils::Manifest qw(maniread);
+eval "use Pod::Checker 1.51;";
+plan skip_all => "Pod::Checker 1.51 required for testing POD" if $@;
+my $manifest = maniread();
+my @pod = sort grep /\.(pm|pl|pod|PL)$/, keys %$manifest;
+
+my $rebuild;
+GetOptions("r" => \$rebuild);
+
+my $known_issues_name = "t/data/known_pod_issues.txt";
+my %expected;
+unless ($rebuild) {
+  plan tests => scalar(@pod);
+  open my $exp_file, "<", $known_issues_name
+    or die "Cannot open $known_issues_name: $!\n";
+  while (<$exp_file>) {
+    chomp;
+    my ($filename, @error_found) = split /\t/, $_, 3;
+    push @{$expected{$filename}}, \@error_found;
+  }
+}
+
+my %found;
+for my $file (@pod) {
+  my $checker = My::Pod::Checker->new;
+  $checker->parse_from_file($file, \*STDERR);
+  my @errors = $checker->imager_errors;
+  if ($rebuild) {
+    $found{$file} = \@errors if scalar @errors;
+  }
+  else {
+    my @diffs;
+    my %exp = map { $_->[0] => $_->[1] } @{$expected{$file} || []};
+    my %seen = map { $_->[0] => $_->[1] } @errors;
+    my %all = map { $_ => 1 } keys %exp, keys %seen;
+    for my $msg (sort keys %all) {
+      my $old_count = $exp{$msg} || 0;
+      my $new_count = $seen{$msg} || 0;
+      if ($old_count && $new_count > $old_count) {
+       push @diffs, "Added: $msg (from $old_count to $new_count)";
+      }
+      elsif (!$old_count) {
+       push @diffs, "New: $msg ($new_count times)";
+      }
+      elsif ($new_count < $old_count) {
+       push @diffs, "Fixed?: $msg (from $old_count to $new_count)";
+      }
+    }
+    ok(!@diffs, "check errors for $file");
+    for my $diff (@diffs) {
+      $diff =~ s/\n/\n# /g;
+      print "# $diff\n";
+    }
+  }
+}
+
+if ($rebuild) {
+  open my $known_file, ">", $known_issues_name
+    or die "Cannot create $known_issues_name; $!\n";
+  binmode $known_file;
+  for my $file (sort keys %found) {
+    for my $issue (@{$found{$file}}) {
+      print $known_file join("\t", $file, @$issue), "\n";
+    }
+  }
+  close $known_file;
+}
+
+{
+  # partly stolen from perl's t/porting/podcheck.t
+  package My::Pod::Checker;
+  use base 'Pod::Checker';
+
+  my $line_reference;
+  my $optional_location;
+
+  BEGIN {
+    my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
+    $optional_location = qr/ (?: $location )? /xi;
+    $line_reference = qr/ [('"]? $optional_location \b line \s+
+                             (?: \d+ | EOF | \Q???\E | - )
+                             [)'"]? /xi;
+
+  }
+
+  sub new {
+    my ($class) = @_;
+
+    my $self = $class->SUPER::new(-quiet => 1,
+                                 -warnings => 200);
+    $self->{imager_errors} = [];
+
+    return $self;
+  }
+
+  sub poderror {
+    my $self = shift;
+
+    my $opts = shift;
+    my $message;
+    if (!ref $opts || ref $opts ne "HASH") {
+      $message = join "", $opts, @_;
+      my $line_number;
+      if ($message =~ s/\s*($line_reference)//) {
+       ($line_number = $1) =~ s/\s*$optional_location//;
+      }
+      else {
+       $line_number = '???';
+      }
+      $opts = { -msg => $message, -line => $line_number };
+    }
+    else {
+      $message = $opts->{-msg};
+    }
+    $message =~ s/^\d+\s+//;
+
+    # this message is so wrong
+    $message =~ /unescaped <> in paragraph/ and return;
+
+    # this one too
+    $message =~ /No items in =over/ and return;
+
+    push @{$self->{imager_errors}}, $opts;
+  }
+
+  sub imager_errors {
+    # fold, spindle, mutilate
+    my %by_error;
+    for my $error (@{$_[0]{imager_errors}}) {
+      ++$by_error{$error->{-msg}};
+    }
+    return
+      (
+       map [ $_, $by_error{$_} ],
+       sort keys %by_error
+      );
+  }
+}
diff --git a/t/courier/by-unit.t b/t/courier/by-unit.t
deleted file mode 100644 (file)
index abf2d9b..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 8;
-use BSE::Cfg;
-use Courier::ByUnitAU;
-
-my $cfg = BSE::Cfg->new_from_text(text => <<EOS, path => ".");
-[by unit au shipping]
-description=testing
-base=1000
-perunit=100
-EOS
-
-my $c = Courier::ByUnitAU->new
-  (
-   config => $cfg,
-  );
-
-ok($c, "create courier object");
-is($c->description, "testing", "test description");
-is($c->name, "by-unit-au", "check name");
-ok($c->can_deliver(country => "AU"), "can deliver to australia");
-ok(!$c->can_deliver(country => "US"), "Can't deliver to US");
-is($c->calculate_shipping
-   (
-    country => "AU",
-    items =>
-    [
-     { units => 1 }
-    ]
-   ), 1000, "one unit order");
-is($c->calculate_shipping
-   (
-    country => "AU",
-    items =>
-    [
-     { units => 2 }
-    ]
-   ), 1100, "two unit order");
-is($c->calculate_shipping
-   (
-    country => "AU",
-    items =>
-    [
-     { units => 2 },
-     { units => 1 },
-     { units => 1 }
-    ]
-   ), 1300, "four unit order");
diff --git a/t/t010template.t b/t/t010template.t
deleted file mode 100644 (file)
index 805c40c..0000000
+++ /dev/null
@@ -1,680 +0,0 @@
-#!perl -w
-# Basic tests for Squirrel::Template
-use strict;
-use Test::More tests => 112;
-
-sub template_test($$$$;$$);
-
-my $gotmodule = require_ok('Squirrel::Template');
-
-SKIP: {
-  skip "couldn't load module", 15 unless $gotmodule;
-
-  my $flag = 0;
-  my $str = "ABC";
-  my $str2 = "DEF";
-  my ($repeat_limit, $repeat_value);
-
-  my %acts =
-    (
-     ifEq => \&tag_ifeq,
-     iterate_repeat_reset =>
-     [ \&iter_repeat_reset, \$repeat_limit, \$repeat_value ],
-     iterate_repeat =>
-     [ \&iter_repeat, \$repeat_limit, \$repeat_value ],
-     repeat => \$repeat_value,
-     strref => \$str,
-     str => $str,
-     str2 => $str2,
-     with_upper => \&tag_with_upper,
-     cat => \&tag_cat,
-     ifFalse => 0,
-     dead => sub { die "foo\n" },
-     noimpl => sub { die "ENOIMPL\n" },
-    );
-  my %vars =
-    (
-     a =>
-     {
-      b =>
-      {
-       c => "CEE"
-      }
-     },
-     str => $str,
-     somelist => [ 'a' .. 'f' ],
-     somehash => { qw(a 11 b 12 c 14 e 8) },
-     num1 => 101,
-     num2 => 202,
-     testclass => Squirrel::Template::Expr::WrapClass->new("TestClass"),
-     error =>
-     {
-      noimpl => sub { die "ENOIMPL\n" },
-     },
-    );
-  template_test("<:str:>", "ABC", "simple", \%acts);
-  template_test("<:strref:>", "ABC", "scalar ref", \%acts);
-  $str = "DEF";
-  template_test("<:strref:>", "DEF", "scalar ref2", \%acts);
-  template_test(<<TEMPLATE, "12345", "iterate", \%acts, "in");
-<:iterator begin repeat 1 5:><:repeat:><:iterator end repeat:>
-TEMPLATE
-  template_test(<<TEMPLATE, "1|2|3|4|5", "iterate sep", \%acts, "in");
-<:iterator begin repeat 1 5:><:repeat:><:
-iterator separator repeat:>|<:iterator end repeat:>
-TEMPLATE
-  template_test('<:ifEq [str] "ABC":>YES<:or:>NO<:eif:>', "YES", 
-               "cond1", \%acts);
-  template_test('<:if Eq [str] "ABC":>YES<:or Eq:>NO<:eif Eq:>', "YES", 
-               "cond2", \%acts);
-  template_test("<:dead:>", "* foo\n *", "dead", \%acts);
-  template_test("<:noimpl:>", "<:noimpl:>", "noimpl", \%acts);
-  template_test("<:unknown:>", "<:unknown:>", "unknown tag", \%acts);
-  template_test("<:ifDead:><:str:><:or:><:str2:><:eif:>",
-               "* foo\n *<:ifDead:>ABC<:or:>DEF<:eif:>", "ifDead", \%acts);
-  template_test("<:ifNoimpl:><:str:><:or:><:str2:><:eif:>",
-               "<:ifNoimpl:>ABC<:or:>DEF<:eif:>", "ifNoimpl", \%acts);
-
-  template_test("<:if!False:>FOO<:eif:>", "FOO", "if!False", \%acts);
-  template_test("<:if !False:>FOO<:eif:>", "FOO", "if !False", \%acts);
-  template_test("<:if!Str:>FOO<:eif:>", "", "if!Str", \%acts);
-  template_test("<:if!Dead:><:str:><:eif:>",
-               "* foo\n *<:if!Dead:>ABC<:eif:>", "if!Dead", \%acts);
-  template_test("<:if!Noimpl:><:str:><:eif:>",
-               "<:if!Noimpl:>ABC<:eif:>", "if!Noimpl", \%acts);
-
-  template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "in");
-<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
-<:param menu:>
-<:param showtitle:>
-TEMPLATE
-<title>foo ABC</title>
-Alpha
-1
-abc
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "both");
-Before
-<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" -:>
-Alpha
-<:param menu:>
-<:param showtitle:>
-<:-endwrap-:>
-After
-TEMPLATE
-Before
-<title>foo ABC</title>
-Alpha
-1
-abc
-After
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "wrap with too much parameter text", \%acts, "in");
-<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" junk :>Alpha
-<:param menu:>
-<:param showtitle:>
-TEMPLATE
-* WARNING: Extra data after parameters ' junk' *<title>foo ABC</title>
-Alpha
-1
-abc
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "wrap recursive", \%acts, "both");
-<:wrap wrapself.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
-<:param menu:>
-<:param showtitle:>
-TEMPLATE
-* Error starting wrap: Too many levels of wrap for 'wrapself.tmpl' *<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-<title>foo ABC</title>
-Alpha
-1
-abc
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "wrap unknown", \%acts, "both");
-<:wrap unknown.tmpl:>
-Body
-TEMPLATE
-* Loading wrap: File unknown.tmpl not found *
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "unwrapped wrap here", \%acts, "both");
-before
-<:wrap here:>
-after
-TEMPLATE
-before
-* wrap here without being wrapped *
-after
-OUTPUT
-
-  # undefined iterator - replacement should happen on the inside
-  template_test(<<TEMPLATE, <<OUTPUT, "undefined iterator", \%acts);
-<:iterator begin unknown:>
-<:if Eq "1" "1":>TRUE<:or:>FALSE<:eif:>
-<:iterator separator unknown:>
-<:if Eq "1" "0":>TRUE<:or:>FALSE<:eif:>
-<:iterator end unknown:>
-TEMPLATE
-<:iterator begin unknown:>
-TRUE
-<:iterator separator unknown:>
-FALSE
-<:iterator end unknown:>
-OUTPUT
-
-  template_test(<<TEMPLATE, <<OUTPUT, "multi wrap", \%acts, "in");
-<:wrap wrapinner.tmpl title => "ABC":>
-Test
-TEMPLATE
-<title>ABC</title>
-
-<head1>ABC</head1>
-
-Test
-OUTPUT
-
-  my $switch = <<IN;
-<:switch:>ignored<:case Eq [strref] "ABC":>ONE<:case Eq [strref] "XYZ":>TWO<:
-case default:>DEF<:endswitch:>
-IN
-  $str = "ABC";
-  template_test($switch, "ONE", "switch1", \%acts, "both");
-  $str = "XYZ";
-  template_test($switch, "TWO", "switch2", \%acts, "both");
-  $str = "DEF";
-  template_test($switch, "DEF", "switch def", \%acts, "both");
-
-  my $switch2 = <<IN;
-<:switch:><:case Eq [strref] "ABC":>ONE<:case Eq [strref] "XYZ":>TWO<:
-case default:>DEF<:endswitch:>
-IN
-  $str = "ABC";
-  template_test($switch2, "ONE", "switch without ignored", \%acts, "both");
-
-  template_test(<<IN, <<OUT, "unimplemented switch (by die)", \%acts, "both");
-<foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Eq [unknown] "ABC":><:endswitch:>
-IN
-<foo>ABC</foo><:switch:><:case Eq [unknown] "ABC":><:endswitch:>
-OUT
-
-  template_test(<<IN, <<OUT, "unimplemented switch (by missing)", \%acts, "both");
-<foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Unknown:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
-IN
-<foo>ABC</foo><:switch:><:case Unknown:>ABC<:case Eq [unknown] "ABC":>DEF<:endswitch:>
-OUT
-
-  template_test(<<IN, <<OUT, "switch with die in case and unknown", \%acts, "both");
-<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
-IN
-* foo
- *<:switch:><:case Eq [unknown] "ABC":>DEF<:endswitch:>
-OUT
-
-  template_test(<<IN, <<OUT, "switch with die no matches", \%acts, "both");
-<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case False:><:str2:><:endswitch:>
-IN
-* foo
- *
-OUT
-
-  template_test(<<IN, <<OUT, "switch with case !", \%acts, "both");
-<:switch:><:case !Str:>NOT STR<:case !False:>FALSE<:endswitch:>
-IN
-FALSE
-OUT
-
-  template_test("<:with begin upper:>Alpha<:with end upper:>", "ALPHA", "with", \%acts);
-
-  template_test("<:with begin unknown:>Alpha<:str:><:with end unknown:>", <<EOS, "with", \%acts, "out");
-<:with begin unknown:>AlphaABC<:with end unknown:>
-EOS
-
-  template_test("<:include doesnt/exist optional:>", "", "optional include", \%acts);
-  template_test("<:include doesnt/exist:>", "* cannot find include doesnt/exist in path *", "failed include", \%acts);
-  template_test("x<:include included.include:>z", "xyz", "include", \%acts);
-
-  template_test <<IN, <<OUT, "nested in undefined if", \%acts;
-<:if Unknown:><:if Eq "1" "1":>Equal<:or Eq:>Not Equal<:eif Eq:><:or Unknown:>false unknown<:eif Unknown:>
-IN
-<:if Unknown:>Equal<:or Unknown:>false unknown<:eif Unknown:>
-OUT
-  template_test <<IN, <<OUT, "nested in undefined switch case", \%acts;
-<:switch:>
-<:case ifUnknown:><:if Eq 1 1:>Equal<:or Eq:>Unequal<:eif Eq:>
-<:endswitch:>
-IN
-<:switch:><:case ifUnknown:>Equal
-<:endswitch:>
-OUT
-
-  { # using - for removing whitespace
-    template_test(<<IN, <<OUT, "space value", \%acts, "both");
-<foo>
-<:-str-:>
-</foo>
-<foo>
-<:str-:>
-</foo>
-<foo>
-<:str:>
-</foo>
-IN
-<foo>ABC</foo>
-<foo>
-ABC</foo>
-<foo>
-ABC
-</foo>
-OUT
-
-    template_test(<<IN, <<OUT, "space simple cond", \%acts, "both");
-<foo>
-<:-ifStr:>TRUE<:or-:><:eif-:>
-</foo>
-<foo2>
-<:-ifStr-:>
-TRUE
-<:-or:><:eif-:>
-</foo2>
-<foo3>
-<:-ifStr-:>
-TRUE
-<:-or-:>
-<:-eif-:>
-</foo3>
-<foo4>
-<:-ifFalse-:>TRUE<:-or-:>FALSE<:-eif-:>
-</foo4>
-<foo5>
-<:-ifFalse-:>
-TRUE
-<:-or-:>
-FALSE
-<:-eif-:>
-</foo5>
-<foo6>
-<:ifFalse:>
-TRUE
-<:or:>
-FALSE
-<:eif:>
-</foo6>
-IN
-<foo>TRUE</foo>
-<foo2>TRUE</foo2>
-<foo3>TRUE</foo3>
-<foo4>FALSE</foo4>
-<foo5>FALSE</foo5>
-<foo6>
-
-FALSE
-
-</foo6>
-OUT
-
-    template_test(<<IN, <<OUT, "space iterator", \%acts, "both");
-<foo>
-<:-iterator begin repeat 1 5 -:>
-<:-repeat-:>
-<:-iterator end repeat -:>
-</foo>
-<foo2>
-<:-iterator begin repeat 1 5 -:>
-<:-repeat-:>
-<:-iterator separator repeat -:>
-,
-<:-iterator end repeat -:>
-</foo2>
-IN
-<foo>12345</foo>
-<foo2>1,2,3,4,5</foo2>
-OUT
-
-    template_test(<<IN, <<OUT, "space switch", \%acts, "both");
-<foo>
-<:- switch:>
-
- <:- case default:>FOO
-<:- endswitch:>
-</foo>
-IN
-<foo>FOO
-</foo>
-OUT
-
-    template_test(<<IN, <<OUT, "space complex", \%acts, "both");
-<div class="window">
-  <h1><:str:></h1>
-  <ul class="children list">
-    <:iterator begin repeat 1 2:>
-    <:- switch:>
-    <:- case False:>
-    <li class="error message"><:repeat:></li>
-    <:case str:>
-  </ul>
-  <h2><:repeat:></h2>
-  <ul class="children list">
-    <:- case default:>
-    <li><:repeat:></li>
-    <:- endswitch:>
-    <:iterator end repeat:>
-  </ul>
-</div>
-IN
-<div class="window">
-  <h1>ABC</h1>
-  <ul class="children list">
-    
-  </ul>
-  <h2>1</h2>
-  <ul class="children list">
-    
-  </ul>
-  <h2>2</h2>
-  <ul class="children list">
-    
-  </ul>
-</div>
-OUT
-  }
-
-  template_test("<:= unknown :>", "<:= unknown :>", "unknown", \%acts, "", \%vars);
-  template_test(<<TEMPLATE, "2", "multi-statement", \%acts, "", \%vars);
-<:.set foo = [] :><:% foo.push(1); foo.push(2) :><:= foo.size() -:>
-TEMPLATE
-
-  template_test(<<TEMPLATE, "2", "multi-statement no ws", \%acts, "", \%vars);
-<:.set foo=[]:><:%foo.push(1);foo.push(2):><:= foo.size() -:>
-TEMPLATE
-
-  template_test("<:= str :>", "ABC", "simple exp", \%acts, "", \%vars);
-  template_test("<:=str:>", "ABC", "simple exp no ws", \%acts, "", \%vars);
-  template_test("<:= a.b.c :>", "CEE", "hash methods", \%acts, "", \%vars);
-  template_test(<<IN, <<OUT, "simple set", \%acts, "both", \%vars);
-<:.set d = "test" -:><:= d :>
-IN
-test
-OUT
-  my @expr_tests =
-    (
-     [ 'num1 + num2', 303 ],
-     [ 'num1 - num2', -101 ],
-     [ 'num1 + num2 * 2', 505 ],
-     [ 'num2 mod 5', '2' ],
-     [ 'num1 / 5', '20.2' ],
-     [ 'num1 div 5', 20 ],
-     [ '+num1', 101 ],
-     [ '-(num1 + num2)', -303 ],
-     [ '"hello " _ str', 'hello ABC' ],
-     [ 'num1 < num2', 1 ],
-     [ 'num1 < 101', '' ],
-     [ 'num1 < 100', '' ],
-     [ 'num1 > num2', '' ],
-     [ 'num2 > num1', 1 ],
-     [ 'num1 > 101', '' ],
-     [ 'num1 == 101.0', '1' ],
-     [ 'num1 == 101', '1' ],
-     [ 'num1 == 100', '' ],
-     [ 'num1 != 101', '' ],
-     [ 'num1 != "101.0"', '' ],
-     [ 'num1 != 100', 1 ],
-     [ 'num1 >= 101', 1 ],
-     [ 'num1 >= 100', 1 ],
-     [ 'num1 >= 102', '' ],
-     [ 'num1 <= 101', 1 ],
-     [ 'num1 <= 100', '' ],
-     [ 'num1 <= 102', '1' ],
-     [ 'str eq "ABC"', '1' ],
-     [ 'str eq "AB"', '' ],
-     [ 'str ne "AB"', '1' ],
-     [ 'str ne "ABC"', '' ],
-     [ 'str.lower', 'abc' ],
-     [ 'somelist.size', 6 ],
-     [ '[ 4, 2, 3 ].first', 4 ],
-     [ '[ 1, 4, 9 ].join(",")', "1,4,9" ],
-     [ '[ "xx", "aa" .. "ad", "zz" ].join(" ")', "xx aa ab ac ad zz" ],
-     [ '1 ? "TRUE" : "FALSE"', 'TRUE' ],
-     [ '0 ? "TRUE" : "FALSE"', 'FALSE' ],
-     [ '[ 1 .. 4 ][2]', 3 ],
-     [ 'somelist[2]', "c" ],
-     [ 'somehash["b"]', "12" ],
-     [ 'not 1', '' ],
-     [ 'not 1 or 1', 1 ],
-     [ 'not 1 and 1', "" ],
-     [ '"xabcy" =~ /abc/', 1 ],
-     [ '[ "abc" =~ /(.)(.)/ ][1]', "b" ],
-     [ '{ "a": 11, "b": 12, "c": 20 }["b"]', 12 ],
-     [ 'testclass.foo', "[TestClass.foo]" ],
-    );
-  for my $test (@expr_tests) {
-    my ($expr, $result) = @$test;
-
-    template_test("<:= $expr :>", $result, "expr: $expr", \%acts, "", \%vars);
-  }
-
-  template_test(<<IN, "", "define no use", \%acts, "both", \%vars);
-<:-.define foo:>
-<:.end-:>
-<:-.define bar:>
-<:.end define-:>
-IN
-  template_test(<<IN, "avaluebvalue", "define with call", \%acts, "both", \%vars);
-<:-.define foo:>
-<:-= avar -:>
-<:.end-:>
-<:.call "foo", "avar":"avalue"-:>
-<:.call "foo",
-  "avar":"bvalue"-:>
-IN
-  template_test(<<IN, "other value", "external call", \%acts, "", \%vars);
-<:.call "called.tmpl", "avar":"other value"-:>
-IN
-  template_test(<<IN, "This was preloaded", "call preloaded", \%acts, "both", \%vars);
-<:.call "preloaded"-:>
-IN
-  template_test(<<IN, <<OUT, "simple .for", \%acts, "", \%vars);
-<:.for x in [ "a" .. "d" ] -:>
-Value: <:= x :> Index: <:= loop.index :> Count: <:= loop.count:> Prev: <:= loop.prev :> Next: <:= loop.next :> Even: <:= loop.even :> Odd: <:= loop.odd :> Parity: <:= loop.parity :> is_first: <:= loop.is_first :> is_last: <:= loop.is_last :>-
-<:.end-:>
-IN
-Value: a Index: 0 Count: 1 Prev:  Next: b Even:  Odd: 1 Parity: odd is_first: 1 is_last: -
-Value: b Index: 1 Count: 2 Prev: a Next: c Even: 1 Odd:  Parity: even is_first:  is_last: -
-Value: c Index: 2 Count: 3 Prev: b Next: d Even:  Odd: 1 Parity: odd is_first:  is_last: -
-Value: d Index: 3 Count: 4 Prev: c Next:  Even: 1 Odd:  Parity: even is_first:  is_last: 1-
-OUT
-  template_test(<<IN, <<OUT, "simple .if", \%acts, "", \%vars);
-<:.if "a" eq "b" :>FAIL<:.else:>SUCCESS<:.end:>
-<:.if "a" eq "a" :>SUCCESS<:.else:>FAIL<:.end:>
-<:.if "a" eq "c" :>FAIL1<:.elsif "a" eq "a":>SUCCESS<:.else:>FAIL2<:.end:>
-IN
-SUCCESS
-SUCCESS
-SUCCESS
-OUT
-  template_test(<<IN, <<OUT, "unknown .if", \%acts, "", \%vars);
-<:.if unknown:>TRUE<:.end:>
-<:.if "a" eq "a":>TRUE<:.elsif unknown:>TRUE<:.end:>
-<:.if "a" eq "b" :>TRUE<:.elsif unknown:>TRUE<:.end:>
-<:.if "a" ne "a" :>TRUE<:.elsif 0:>ELIF<:.elsif unknown:>TRUE<:.end:>
-IN
-<:.if unknown:>TRUE<:.end:>
-TRUE
-<:.if 0 :><:.elsif unknown:>TRUE<:.end:>
-<:.if 0 :><:.elsif unknown:>TRUE<:.end:>
-OUT
-
-  template_test(<<IN, <<OUT, "stack overflow on .call", \%acts, "", \%vars);
-<:.define foo:>
-<:-.call "foo"-:>
-<:.end:>
-<:-.call "foo"-:>
-IN
-Error opening scope for call: Too many scope levels
-Backtrace:
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:1
-  .call 'foo' from test:3
-OUT
-
-  template_test(<<IN, <<OUT, "evaltags", \%acts, "", \%vars);
-<:= "str".evaltag :>
-<:= "cat [str] [str2]".evaltag :>
-IN
-ABC
-ABCDEF
-OUT
-
-  template_test(<<IN, <<OUT, "set undef", \%acts, "", \%vars);
-<:.set foo = unknown :>
-<:.set bar = error.noimpl :>
-IN
-<:.set foo = unknown :>
-<:.set bar = error.noimpl :>
-OUT
-}
-
-sub template_test ($$$$;$$) {
-  my ($in, $out, $desc, $acts, $stripnl, $vars) = @_;
-
-  $stripnl ||= 'none';
-  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
-  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
-
-  my $templater = Squirrel::Template->new
-    (
-     template_dir=>'t/templates',
-     preload => "preload.tmpl"
-    );
-
-  my $result = $templater->replace_template($in, $acts, undef, "test", $vars);
-
-  is($result, $out, $desc);
-}
-
-sub iter_repeat_reset {
-  my ($rlimit, $rvalue, $args) = @_;
-
-  ($$rvalue, $$rlimit) = split ' ', $args;
-  --$$rvalue;
-}
-
-sub iter_repeat {
-  my ($rlimit, $rvalue) = @_;
-
-  ++$$rvalue <= $$rlimit;
-}
-
-sub tag_ifeq {
-  my ($args, $acts, $func, $templater) = @_;
-
-  my @args = get_expr($args, $acts, $templater);
-
-  @args >= 2
-    or die "ifEq takes 2 arguments";
-
-  $args[0] eq $args[1];
-}
-
-sub get_expr {
-  my ($origargs, $acts, $templater) = @_;
-
-  my @values;
-  my $args = $origargs;
-  while ($args) {
-    if ($args =~ s/\s*\[([^\[\]]+)\]\s*//) {
-      my $expr = $1;
-      my ($func, $funcargs) = split ' ', $expr, 2;
-      exists $acts->{$func} or die "ENOIMPL\n";
-      push @values, scalar $templater->perform($acts, $func, $funcargs, $expr);
-    }
-    elsif ($args =~ s/\s*\"((?:[^\"\\]|\\[\"\\]|\"\")*)\"\s*//) {
-      my $str = $1;
-      $str =~ s/(?:\\([\"\\])|\"(\"))/$1 || $2/eg;
-      push @values, $str;
-    }
-    elsif ($args =~ s/\s*(\S+)\s*//) {
-      push @values, $1;
-    }
-    else {
-      print "Arg parse failure with '$origargs' at '$args'\n";
-      exit;
-    }
-  }
-  
-  @values;
-}
-
-sub tag_with_upper {
-  my ($args, $text) = @_;
-
-  return uc($text);
-}
-
-sub tag_cat {
-  my ($args, $acts, $func, $templater) = @_;
-
-  return join "", $templater->get_parms($args, $acts);
-}
-
-package TestClass;
-
-sub foo {
-  return "[TestClass.foo]";
-}
diff --git a/t/t011dhdates.t b/t/t011dhdates.t
deleted file mode 100644 (file)
index 142df40..0000000
+++ /dev/null
@@ -1,95 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests=>46;
-
-my $gotmodule;
-BEGIN { $gotmodule = use_ok('DevHelp::Date', ':all'); }
-
-SKIP:
-{
-  skip "couldn't load module", 41 unless $gotmodule;
-  my $msg;
-  is_deeply([ dh_parse_time("10:00", \$msg) ], [ 10, 0, 0 ], "parse 10:00");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("10pm", \$msg) ], [ 22, 0, 0 ], "parse 10pm");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("10 05", \$msg) ], [ 10, 5, 0 ], "parse 10 05");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("12am", \$msg) ], [ 0, 0, 0 ], "parse 12am");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("12pm", \$msg) ], [ 12, 0, 0 ], "parse 12pm");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("12.01pm", \$msg) ], [ 12, 1, 0 ], "parse 12.01pm");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("1pm", \$msg) ], [ 13, 0, 0 ], "parse 1pm");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("1.00PM", \$msg) ], [ 13, 0, 0 ], "parse 1.00PM");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("12:59PM", \$msg) ], [ 12, 59, 0 ], 
-           "parse 12:59PM");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("0000", \$msg) ], [ 0, 0, 0 ], "parse 0000");
-  is($msg, undef, "no error");
-  undef $msg;
-  is_deeply([ dh_parse_time("1101", \$msg) ], [ 11, 1, 0 ], "parse 1101");
-  is($msg, undef, "no error");
-
-  is_deeply([ dh_parse_time("11:01:02", \$msg) ], [ 11, 1, 2 ],
-           "parse 11:01:02") or diag $msg;
-  is_deeply([ dh_parse_time("11:01:02pm", \$msg) ], [23, 1, 2 ],
-           "parse 11:01:02pm") or diag $msg;
-
-  # fail a bit
-  undef $msg;
-  is_deeply([ dh_parse_time("xxx", \$msg) ], [], "parse xxx");
-  is($msg, "Unknown time format", "got an error");
-  undef $msg;
-  is_deeply([ dh_parse_time("0pm", \$msg) ], [], "parse 0pm");
-  is($msg, "Hour must be from 1 to 12 for 12 hour time", "got an error");
-  undef $msg;
-  is_deeply([ dh_parse_time("13pm", \$msg) ], [], "parse 13pm");
-  is($msg, "Hour must be from 1 to 12 for 12 hour time", "got an error");
-  undef $msg;
-  is_deeply([ dh_parse_time("12:60am", \$msg) ], [], "parse 12:60am");
-  is($msg, "Minutes must be from 0 to 59", "got an error");
-  undef $msg;
-  is_deeply([ dh_parse_time("2400", \$msg) ], [], "parse 2400");
-  is($msg, "Hour must be from 0 to 23 for 24-hour time", "got an error");
-  undef $msg;
-  is_deeply([ dh_parse_time("1360", \$msg) ], [], "parse 1360");
-  is($msg, "Minutes must be from 0 to 59", "got an error");
-
-  # sql times
-  
-  undef $msg;
-  is(dh_parse_time_sql("2:30pm"), "14:30:00", "2:30pm to sql");
-  is($msg, undef, "no error");
-
-  # parse SQL date
-  is_deeply([ dh_parse_sql_date("2005-07-12") ], [ 2005, 7, 12 ],
-           "simple sql date parse");
-  is_deeply([ dh_parse_sql_date("20") ], [ ],
-           "invalid sql date parse");
-  is_deeply([ dh_parse_sql_datetime("2005-06-30 12:00:05") ],
-           [ 2005, 6, 30, 12, 0, 5 ], "parse SQL date time");
-  is_deeply([ dh_parse_sql_datetime("2005-06-30 12") ],
-           [ ], "invalid parse SQL date time");
-  is(dh_strftime_sql_datetime("%d/%m/%Y", "2005-06-30 12:00:05"),
-     "30/06/2005", "dh_strftime_sql_datetime");
-
-  is(dh_strftime_sql_datetime("%a %U %j %d/%m/%Y", "2005-06-30 12:00:05"),
-     "Thu 26 181 30/06/2005", "dh_strftime_sql_datetime dow check");
-
-  is(dh_strftime("%a %U %j %F %T", 20, 5, 12, 30, 5, 105),
-     "Thu 26 181 2005-06-30 12:05:20",
-     "dh_strftime");
-}
diff --git a/t/t012validate.t b/t/t012validate.t
deleted file mode 100644 (file)
index 37b3a72..0000000
+++ /dev/null
@@ -1,79 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 16;
-
-BEGIN { use_ok('DevHelp::Validate'); }
-
-{
-  my %built_ins =
-    (
-     oneline =>
-     {
-      rules => "dh_one_line"
-     },
-    );
-  my $val = DevHelp::Validate::Hash->new(fields => \%built_ins);
-  ok($val, "got built-ins validation object");
-  {
-    my %errors;
-    ok($val->validate({ oneline => "abc" }, \%errors), "valid oneline");
-    is_deeply(\%errors, {}, "no errors set");
-  }
-  {
-    my %errors;
-    ok(!$val->validate({ oneline => "\x0D" }, \%errors), "invalid oneline (CR)");
-    ok($errors{oneline}, "message for oneline");
-  }
-  {
-    my %errors;
-    ok(!$val->validate({ oneline => "\x0A" }, \%errors), "invalid oneline (LF)");
-    ok($errors{oneline}, "message for oneline");
-  }
-}
-
-{
-  my %simple_date =
-    (
-     date => 
-     {
-      rules => 'date'
-     },
-    );
-  
-  my $val = DevHelp::Validate::Hash->new(fields => \%simple_date);
-  ok($val, "got validation object");
-  {
-    my %errors;
-    ok($val->validate({ date => "30/12/67" }, \%errors), "valid date");
-  }
-  {
-    my %errors;
-    ok(!$val->validate({ date => "32/12/67" }, \%errors),
-       "obviously invalid date");
-  }
-  {
-    my %errors;
-    ok(!$val->validate({ date => "31/9/67" }, \%errors),
-       "not so obviously invalid date");
-  }
-  {
-    my %errors;
-    ok(!$val->validate({ date => "29/2/67" }, \%errors),
-       "leap year check 29/2/67");
-  }
-  {
-    my %errors;
-    ok($val->validate({ date => "28/2/67" }, \%errors),
-       "leap year check 28/2/67");
-  }
-  {
-    my %errors;
-    ok($val->validate({ date => "29/2/80" }, \%errors),
-       "leap year check 29/2/80");
-  }
-  {
-    my %errors;
-    ok($val->validate({ date => "29/12/2000" }, \%errors),
-       "leap year check 29/2/2000");
-  }
-}
diff --git a/t/t013country.t b/t/t013country.t
deleted file mode 100644 (file)
index 34938ff..0000000
+++ /dev/null
@@ -1,9 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 3;
-
-use BSE::Countries qw(bse_country_code);
-
-is(bse_country_code("Australia"), "AU", "we know where australia is");
-is(bse_country_code("new zealand"), "NZ", "we know where new zealand is");
-is(bse_country_code("not a country"), undef, "we know how to fail");
diff --git a/t/t014bsesort.t b/t/t014bsesort.t
deleted file mode 100644 (file)
index 9c29202..0000000
+++ /dev/null
@@ -1,23 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 3;
-
-BEGIN { use_ok("BSE::Sort", "bse_sort"); }
-
-{
-  my $a100 = { a => 100, b => 3 };
-  my $a2 = { a => 2, b => 2 };
-  my $a30 = { a => 30, b => 4 };
-
-  my @in = ( $a2, $a100, $a30 );
-  my %types = qw(a n b n);
-
-  {
-    my @out = bse_sort(\%types, "sort=a", @in);
-    is_deeply(\@out, [ $a2, $a30, $a100 ], "check simple numeric sort");
-  }
-  {
-    my @out = bse_sort(\%types, "filter= b >= 3", @in);
-    is_deeply(\@out, [ $a100, $a30 ], "check simple filtering");
-  }
-}
diff --git a/t/t020checktemplates.t b/t/t020checktemplates.t
deleted file mode 100644 (file)
index 93cdd93..0000000
+++ /dev/null
@@ -1,34 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-use Squirrel::Template;
-
-my $mani = maniread();
-
-$| = 1;
-my @templates = map m(^site/templates/(.*)$),
-  sort grep m(^site/templates/.*\.tmpl$), keys %$mani;
-
-plan tests => scalar @templates;
-
-my $templater = Squirrel::Template->new
-   (
-    charset => "utf-8",
-    utf8 => 1,
-    template_dir => "site/templates",
-   );
-for my $file (@templates) {
-  my ($p, $message) = $templater->parse_file($file);
-  if ($p) {
-    my @errors = $templater->errors;
-    ok(!@errors, "check $file for template errors");
-    diag("$_->[3]:$_->[2]: $_->[4]") for @errors;
-    $templater->clear_errors;
-  }
-  else {
-    fail("check $file for template errors");
-    diag($message);
-  }
-}
diff --git a/t/t050format.t b/t/t050format.t
deleted file mode 100644 (file)
index 1d8976e..0000000
+++ /dev/null
@@ -1,351 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 97;
-
-sub format_test($$$;$);
-sub noformat_test($$$;$);
-
-my $gotmodule = require_ok('DevHelp::Formatter');
-
-SKIP: {
-  skip "couldn't load module", 63 unless $gotmodule;
-  format_test 'acronym[hello]', '<p><acronym>hello</acronym></p>', 'acronym';
-  format_test 'acronym[|hello]', '<p><acronym>hello</acronym></p>', 'acronym with empty title';
-  format_test 'acronym[foo|hello]', '<p><acronym title="foo">hello</acronym></p>', 'acronym with title';
-  format_test 'acronym[foo|bar|hello]', '<p><acronym class="bar" title="foo">hello</acronym></p>', 'acronym with class and title';
-  format_test 'bdo[ltr|hello]', '<p><bdo dir="ltr">hello</bdo></p>', 'bdo with dir';
-  format_test 'code[hello]', '<p><code>hello</code></p>', 'code';
-  format_test 'code[|hello]', '<p><code>hello</code></p>', 'code empty class';
-  format_test 'code[foo|hello]', '<p><code class="foo">hello</code></p>', 'code with class';
-  format_test 'code[var[x]="1"]', '<p><code><var>x</var>=&quot;1&quot;</code></p>', 'code with var';
-  format_test 'blockquote[hello]', '<blockquote><p>hello</p></blockquote>', 'blockquote';
-  format_test 'blockquote[|hello]', '<blockquote><p>hello</p></blockquote>', 'blockquote with empty class';
-  format_test 'blockquote[foo|hello]', '<blockquote class="foo"><p>hello</p></blockquote>', 'blockquote with class';
-  format_test <<IN, <<OUT, 'strong over paras', 'both';
-strong[foo|hello
-
-foo]
-IN
-<p><strong class="foo">hello</strong></p>
-<p><strong class="foo">foo</strong></p>
-OUT
-  format_test <<IN, <<OUT, 'blockquote list h1 var', 'both';
-blockquote[
-** one
-** two
-h1[quux]var[hello
-there]
-
-foo]
-IN
-<blockquote><ul><li>one</li><li>two</li></ul>
-<h1>quux</h1>
-<p><var>hello<br />
-there</var></p>
-<p>foo</p></blockquote>
-OUT
-  format_test <<IN, <<OUT, 'address class h1 abbr over paras', 'both';
-address[foo|h1[bar
-
-quux]abbr[my abbr|hello]
-
-class[foo|b[bold|E=MCsup[2]]]
-
-foo]
-IN
-<address class="foo"><h1>bar</h1>
-<h1>quux</h1>
-<p><abbr title="my abbr">hello</abbr></p>
-<p class="foo"><b class="bold">E=MC<sup>2</sup></b></p>
-<p>foo</p></address>
-OUT
-  format_test <<IN, <<OUT, 'div blockquote h1 class over paras', 'both';
-div[quux|blockquote[foo|h1[bar]
-b[hello]
-class[foo|b[bold|E=MCsup[2
-
-kbd[xxx|super]]]]
-
-foo]]
-IN
-<div class="quux"><blockquote class="foo"><h1>bar</h1>
-<p><b>hello</b><br />
-<span class="foo"><b class="bold">E=MC<sup>2</sup></b></span></p>
-<p class="foo"><b class="bold"><sup><kbd class="xxx">super</kbd></sup></b></p>
-<p>foo</p></blockquote></div>
-OUT
-  format_test <<IN, <<OUT, 'bold', 'both';
-b[hello]
-IN
-<p><b>hello</b></p>
-OUT
-  format_test 'i[hello]', '<p><i>hello</i></p>', 'italic';
-  format_test 'b[i[hello]]', '<p><b><i>hello</i></b></p>', 'bold/italic';
-  format_test <<IN, <<OUT, 'bold over lines', 'both';
-b[hello
-foo]
-IN
-<p><b>hello<br />
-foo</b></p>
-OUT
-  format_test <<IN, <<OUT, 'bold over paras', 'both';
-b[hello
-
-foo]
-IN
-<p><b>hello</b></p>
-<p><b>foo</b></p>
-OUT
-  format_test <<IN, <<OUT, 'combo over paras', 'both';
-i[b[hello
-
-foo
-
-bar]]
-IN
-<p><i><b>hello</b></i></p>
-<p><i><b>foo</b></i></p>
-<p><i><b>bar</b></i></p>
-OUT
-  format_test <<IN, <<OUT, 'link', 'both';
-link[http://foo/|bar
-
-quux]
-IN
-<p><a href="http://foo/">bar</a></p>
-<p><a href="http://foo/">quux</a></p>
-OUT
-  format_test 'tt[hello]', '<p><tt>hello</tt></p>', 'tt';
-  format_test 'font[-1|text]', '<p><font size="-1">text</font></p>', 'fontsize';
-  format_test 'fontcolor[-1|black|text]', '<p><font size="-1" color="black">text</font></p>', 'fontsizecolor';
-  format_test 'anchor[somename]', '<p><a name="somename"></a></p>', 'anchor';
-  format_test <<IN, <<OUT, 'pre', 'both';
-
-
-pre[hello there
-Joe]
-IN
-<pre>hello there
-Joe</pre>
-OUT
-  format_test <<IN, <<OUT, 'pre with bold', 'both';
-pre[b[hello there
-
-Joe]]
-IN
-<pre><b>hello there</b>
-
-<b>Joe</b></pre>
-OUT
-  format_test <<IN, <<OUT, 'html', 'both';
-html[<object foo="bar" />]
-IN
-<object foo="bar" />
-OUT
-
-  format_test 'embed[foo]', '', 'embed1';
-  format_test 'embed[foo,bar]', '', 'embed2';
-  format_test 'embed[foo,bar,quux]', '', 'embed3';
-  format_test 'h1[|text]', '<h1>text</h1>', 'h1';
-  format_test 'h1[someclass|text]', '<h1 class="someclass">text</h1>', 'h1class';
-  format_test 'h6[|te>xt]', '<h6>te&gt;xt</h6>', 'h6';
-  format_test 'h1[|foo]h2[|bar]', "<h1>foo</h1>\n<h2>bar</h2>", 'h1h2';
-  format_test 'h1[|foo]texth2[|bar]', 
-    "<h1>foo</h1>\n<p>text</p>\n<h2>bar</h2>", 'h1texth2';
-  format_test 'align[left|some text]', '<div align="left"><p>some text</p></div>', 'align';
-  format_test 'hr[]', '<hr />', 'hr0';
-  format_test 'hr[80%]', '<hr width="80%" />', 'hr1';
-  format_test 'hr[80%|10]', '<hr width="80%" size="10" />', 'hr2';
-  format_test <<IN, <<OUT, 'table1', 'both';
-table[80%
-bgcolor="black"|quux|blarg
-|hello|there
-]
-IN
-<table width="80%"><tr bgcolor="black"><td>quux</td><td>blarg</td></tr><tr><td>hello</td><td>there</td></tr></table>
-OUT
-  format_test <<IN, <<OUT, 'table2', 'both';
-table[80%|#808080|2|2|Arial
-bgcolor="black"|quux|blarg
-|hello|there
-]
-IN
-<table width="80%" bgcolor="#808080" cellpadding="2"><tr bgcolor="black"><td><font size="2" face="Arial">quux</font></td><td><font size="2" face="Arial">blarg</font></td></tr><tr><td><font size="2" face="Arial">hello</font></td><td><font size="2" face="Arial">there</font></td></tr></table>
-OUT
-  format_test <<IN, <<OUT, 'table3', 'both';
-table[80%|foo]
-IN
-<table width="80%"><tr><td>foo</td></tr></table>
-OUT
-  format_test <<IN, <<OUT, 'ol1', 'both';
-## one
-## two
-IN
-<ol><li>one</li><li>two</li></ol>
-OUT
-  format_test <<IN, <<OUT, 'ol2', 'both';
-## one
-
-## two
-IN
-<ol><li><p>one</p></li><li>two</li></ol>
-OUT
-  format_test <<IN, <<OUT, 'ol1 alpha', 'both';
-%% one
-%% two
-IN
-<ol type="a"><li>one</li><li>two</li></ol>
-OUT
-  format_test <<IN, <<OUT, 'ol2 alpha', 'both';
-%% one
-
-%% two
-IN
-<ol type="a"><li><p>one</p></li><li>two</li></ol>
-OUT
-  format_test <<IN, <<OUT, 'ul1', 'both';
-** one
-** two
-IN
-<ul><li>one</li><li>two</li></ul>
-OUT
-  format_test <<IN, <<OUT, 'ul2', 'both';
-** one
-
-** two
-IN
-<ul><li><p>one</p></li><li>two</li></ul>
-OUT
-
-  format_test <<IN, <<OUT, 'ul indented', 'both';
-  ** one
-**two
-IN
-<ul><li>one</li><li>two</li></ul>
-OUT
-
-  format_test <<IN, <<OUT, "don't ul at end of line", 'both';
-this shouldn't be a bullet ** some text
-
-** this should be a bullet
-** so should this
-IN
-<p>this shouldn't be a bullet ** some text</p>
-<ul><li>this should be a bullet</li><li>so should this</li></ul>
-OUT
-
-  format_test <<IN, <<OUT, 'mixed', 'both';
-** joe
-** bob
-## one
-## two
-IN
-<ul><li>joe</li><li>bob</li></ul><ol><li>one</li><li>two</li></ol>
-OUT
-
-  format_test <<IN, <<OUT, 'spaces between', 'both';
-** joe
-** bob
-
-** jane
-IN
-<ul><li><p>joe</p></li><li><p>bob</p></li><li>jane</li></ul>
-OUT
-
-  format_test 'indent[text]', '<ul>text</ul>', 'indent';
-  format_test 'center[text]', '<center>text</center>', 'center';
-  format_test 'hrcolor[80|10|#FF0000]', <<OUT, 'hrcolor', 'out';
-<table width="80" height="10" border="0" bgcolor="#FF0000" cellpadding="0" cellspacing="0"><tr><td><img src="/images/trans_pixel.gif" width="1" height="1" alt="" /></td></tr></table>
-OUT
-  format_test 'image[foo]', '<p></p>', 'image';
-
-  format_test 'class[xxx|yyy]', '<p class="xxx">yyy</p>', 'class';
-  format_test "class[xxx|yy\n\nzz]", <<EOS, 'class2', 'out';
-<p class="xxx">yy</p>
-<p class="xxx">zz</p>
-EOS
-  format_test 'div[someclass|h1[|foo]barh2[|quux]]', <<EOS, 'divblock', 'out';
-<div class="someclass"><h1>foo</h1>
-<p>bar</p>
-<h2>quux</h2></div>
-EOS
-
-  format_test "h1[#foo|test]", q!<h1 id="foo">test</h1>!, 'h1#id';
-  format_test "h1[#foo bar|test]", q!<h1 id="foo" class="bar">test</h1>!, 'h1#id class';
-  format_test "h1[#foo bar quux|test]", q!<h1 id="foo" class="bar quux">test</h1>!, 'h1#id class class';
-  format_test "h1[text-align: center;|test]", q!<h1 style="text-align: center;">test</h1>!, 'h1 styled';
-  format_test "h1[#foo text-align: center;|test]", q!<h1 id="foo" style="text-align: center;">test</h1>!, 'h1 styled, id';
-
-  format_test "div[text-align: center;|test\n\ntest2]", <<EOS, 'div styled', 'out';
-<div style="text-align: center;"><p>test</p>
-<p>test2</p></div>
-EOS
-
-  format_test "div[#foo|test\n\ntest2]", <<EOS, 'div #id', 'out';
-<div id="foo"><p>test</p>
-<p>test2</p></div>
-EOS
-
-  format_test "abc comment[foo] def", "<p>abc  def</p>", "comment";
-
-  # remove_format() tests
-  noformat_test 'image[foo]', '', 'image';
-  noformat_test 'code[something [bar]]', 'something [bar]', 'nested []';
-
-  noformat_test "abc comment[foo] def", "abc  def", "comment";
-
-  noformat_test 'class[foo|image[bar]]', '', 'class with image content';
-  noformat_test 'abbr[image[bar]]', '', 'abbr[] with image content';
-  noformat_test 'abbr[foo|image[bar]]', '', 'abbr[x|x] with image content';
-  noformat_test 'abbr[|image[bar]]', '', 'abbr[|x] with image content';
-  noformat_test 'strong[image[bar]]', '', 'strong[x] with image content';
-  noformat_test 'strong[|image[bar]]', '', 'strong[|x] with image content';
-  noformat_test 'strong[foo|image[bar]]', '', 'strong[x|x] with image content';
-
-  noformat_test 'div[foo|image[bar]]', '', 'div[x|x] with image content';
-  noformat_test 'comment[image[bar]]', '', 'comment[image[xx]] with image content';
-  noformat_test 'h1[foo|image[bar]]', '', 'h1[x|x] with image content';
-  noformat_test 'h1[|image[bar]]', '', 'h1[|x] with image content';
-  noformat_test 'h1[image[bar]]', '', 'h1[x] with image content';
-  
-  noformat_test 'poplink[xxx|image[bar]]', '', 'poplink[x|x] with image content';
-  noformat_test 'poplink[image[bar]]', '', 'poplink[x] with image content';
-  noformat_test 'link[xxx|image[bar]]', '', 'link[x|x] with image content';
-  noformat_test 'link[image[bar]]', '', 'link[x] with image content';
-  noformat_test 'align[xxx|image[bar]]', '', 'align[x|x] with image content';
-  noformat_test 'font[xxx|image[bar]]', '', 'font[x|x] with image content';
-  noformat_test 'hr[xxx|image[bar]]', '', 'hr[x|x] with image content';
-  noformat_test 'anchor[image[bar]]', '', 'anchor[x] with image content';
-  noformat_test '**image[bar]', '', '** list with image content';
-  noformat_test '%%image[bar]', '', '%% list with image content';
-  noformat_test '##image[bar]', '', '## list with image content';
-}
-
-sub format_test ($$$;$) {
-  my ($in, $out, $desc, $stripnl) = @_;
-
-  $stripnl ||= 'none';
-  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
-  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
-
-  my $formatter = DevHelp::Formatter->new;
-
-  my $result = $formatter->format($in);
-
-  is($result, $out, $desc);
-}
-
-sub noformat_test($$$;$) {
-  my ($in, $out, $desc, $stripnl) = @_;
-
-  $stripnl ||= 'none';
-  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
-  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
-
-  my $formatter = DevHelp::Formatter->new;
-
-  my $result = $formatter->remove_format($in);
-
-  is($result, $out, $desc);
-}
diff --git a/t/t060parms.t b/t/t060parms.t
deleted file mode 100644 (file)
index 6ed8750..0000000
+++ /dev/null
@@ -1,56 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 6;
-use Squirrel::Template;
-
-sub format_test($$$$;$);
-
-my $gotmodule = require_ok('DevHelp::Tags');
-
-SKIP: {
-  skip "couldn't load module", 5 unless $gotmodule;
-
-  my %acts =
-    (
-     alpha => 'abc',
-     gamma => 'cde',
-     upper => 
-     sub { 
-       my ($args, $acts, $func, $templater) = @_;
-
-       my @parms = DevHelp::Tags->get_parms($args, $acts, $templater);
-
-       uc "@parms";
-     },
-     lcfirst => 
-     sub { 
-       my ($args, $acts, $func, $templater) = @_;
-
-       my @parms = DevHelp::Tags->get_parms($args, $acts, $templater);
-
-       lcfirst "@parms";
-     },
-    );
-  format_test(\%acts, "<:upper abc:>", "ABC", 'simple');
-  format_test(\%acts, qq/<:upper "abc":>/, "ABC", 'quoted');
-  format_test(\%acts, qq/<:upper [alpha]:>/, "ABC", 'function');
-  format_test(\%acts, qq/<:upper [alpha] "[alpha beta]":>/,
-             "ABC [ALPHA BETA]", 'combo');
-  format_test(\%acts, qq/<:lcfirst [upper [alpha] "[alpha beta]"]:>/,
-             "aBC [ALPHA BETA]", 'nested');
-  
-}
-
-sub format_test ($$$$;$) {
-  my ($acts, $in, $out, $desc, $stripnl) = @_;
-
-  $stripnl ||= 'none';
-  $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
-  $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
-
-  my $formatter = Squirrel::Template->new();
-
-  my $result = $formatter->replace_template($in, $acts);
-
-  is($result, $out, $desc);
-}
diff --git a/t/t070sqldates.t b/t/t070sqldates.t
deleted file mode 100644 (file)
index efd0560..0000000
+++ /dev/null
@@ -1,32 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests=>11;
-
-use BSE::Util::SQL qw(:all);
-
-is(sql_normal_date("2004/02/10"), "2004-02-10", "separators");
-is(sql_normal_date("2004-02-10 10:00:00"), "2004-02-10", "strip time");
-
-# sql_add_date_months():
-is(sql_add_date_months("2004-02-10", 2), "2004-04-10", 
-   "add months, simple");
-is(sql_add_date_months("2004-02-10", 12), "2005-02-10",
-   "add months, one year");
-is(sql_add_date_months("2004-02-10", 11), "2005-01-10",
-   "add months, 11 months");
-is(sql_add_date_months("2004-02-10", 13), "2005-03-10",
-   "add months, 13 months");
-is(sql_add_date_months("2004-01-30", 1), "2004-02-29",
-   "add months, to a shorter month");
-is(sql_add_date_months("2004-01-30", 13), "2005-02-28",
-   "add months, to a shorter month in non-leap year");
-
-
-# sql_add_date_days():
-is(sql_add_date_days("2004-02-10", 2), "2004-02-12",
-   "add days, simple");
-is(sql_add_date_days("2004-02-29", 1), "2004-03-01",
-   "add days, span month");
-is(sql_add_date_days("2004-12-31", 1), "2005-01-01",
-   "add days, span year");
-
diff --git a/t/t080escape.t b/t/t080escape.t
deleted file mode 100644 (file)
index 8833279..0000000
+++ /dev/null
@@ -1,13 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests=>2;
-
-my $gotmodule = require_ok('DevHelp::HTML');
-
-SKIP: {
-  skip "couldn't load module", 9 unless $gotmodule;
-
-  DevHelp::HTML->import('escape_xml');
-
-  is(escape_xml("<&\xE9"), "&lt;&amp;\xE9", "don't escape like html");
-}
diff --git a/t/t081cfg.t b/t/t081cfg.t
deleted file mode 100644 (file)
index 734931f..0000000
+++ /dev/null
@@ -1,52 +0,0 @@
-#!perl -w
-# BSE::Cfg tests
-use strict;
-use Test::More;
-
-BEGIN {
-  eval "use BSE::Cfg; 1"
-    or plan skip_all => "Cannot load BSE::Cfg";
-}
-
-plan tests => 15;
-
-#ok(chdir "t/cfg", "chdir to cfg dir");
-my $cfg = eval { BSE::Cfg->new(path => "t/cfg") };
-ok($cfg, "made a config");
-is($cfg->entry("alpha", "beta"), "one", "check simple lookup");
-is($cfg->entryVar("var", "varb"), "ab", "simple variable lookup");
-is($cfg->entryVar("var", "varc"), "tt", "complex variable lookup");
-
-is($cfg->entry("isafile", "key"), "value", "value from include");
-
-# values from directory includes, conflict resolution
-is($cfg->entry("conflict", "keya"), "valuez", "conflict resolution");
-
-# utf8
-is($cfg->entry("utf8", "omega"), "\x{2126}", "check utf8 parsed");
-is($cfg->entry("utf8", "omega2"), "\x{2126}", "check utf8 parsed from include");
-
-# missing values
-is($cfg->entry("unknown", "keya"), undef, "missing value no default");
-is($cfg->entry("unknown", "keya", "abc"), "abc", "missing value with default");
-
-# include included by variable name
-is($cfg->entry("varinc", "vara"), "somevalue", "include included by variable name");
-
-# get entire sections
-is_deeply({ $cfg->entriesCS("conflict") },
-         { keya => "valuez" }, "CS section with a value");
-is_deeply([ $cfg->orderCS("conflict") ],
-         [ qw/keya keya/ ], "original case keys in order of appearance");
-
-{
-  my $cfg = BSE::Cfg->new_from_text(text => <<EOS, path => ".");
-[by unit au shipping]
-description=testing
-base=1000
-unit=100
-EOS
-  ok($cfg, "make cfg from text");
-  is($cfg->entry("by unit au shipping", "description"), "testing",
-     "test we got the cfg");
-}
diff --git a/t/t090tags.t b/t/t090tags.t
deleted file mode 100644 (file)
index f4e61fa..0000000
+++ /dev/null
@@ -1,42 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 10;
-use BSE::Cfg;
-use Squirrel::Template;
-
-use_ok("BSE::Util::Tags");
-
-my $cfg = BSE::Cfg->new(path => "t/tags/");
-
-my %acts =
-  (
-   BSE::Util::Tags->static(undef, $cfg),
-   pi => "3.14159265",
-   large => 1234567890,
-  );
-
-my @tests =
-  ( # comment, template, output
-   [ "num default", "<:number default [pi]:>", "3.14159265" ],
-   [ "num places", "<:number places [pi]:>", "3" ],
-   [ "num default large", "<:number default [large]:>", "1,234,567,890" ],
-   [ "num new comma", "<:number space [large]:>", "1 234 567 890" ],
-   [ "num comma limit", "<:number 9999 9999:>", "9999" ],
-   [ "num comma limit2", "<:number 9999 10000:>", "10,000" ],
-   [ "num cents", "<:number cents [large]:>", "12,345,678.90" ],
-   [ "num cents", "<:number cents 999999:>", "9,999.99" ],
-   [ "num decimal", "<:number decimal [large]:>", "12 345 678,90" ],
-  );
-
-for my $test (@tests) {
-  my ($comment, $in, $out) = @$test;
-  template_test($comment, $in, $out, \%acts);
-}
-
-sub template_test {
-  my ($note, $in, $out, $acts) = @_;
-
-  my $templater = Squirrel::Template->new;
-  my $result = $templater->replace_template($in, $acts);
-  return is($result, $out, $note);
-}
diff --git a/t/t091iter.t b/t/t091iter.t
deleted file mode 100644 (file)
index 9123aa5..0000000
+++ /dev/null
@@ -1,132 +0,0 @@
-#!perl -w
-use strict;
-use Test::More tests => 3;
-use BSE::Cfg;
-use Squirrel::Template;
-
-use_ok("BSE::Util::Iterate");
-
-my $cfg = BSE::Cfg->new(path => "t/tags/");
-
-my @firsts =
-  (
-   { name => "one", id => 3 },
-   { name => "two", id => 1 },
-   { name => "three", id => 2 },
-  );
-
-my @ids = map $_->{id}, @firsts;
-my %ids = map { $_->{id} => $_ } @firsts;
-
-my $it = BSE::Util::Iterate->new(cfg => $cfg);
-my %acts =
-  (
-   BSE::Util::Tags->static(undef, $cfg),
-   pi => "3.14159265",
-   large => 1234567890,
-   $it->make
-   (
-    single => "first",
-    plural => "firsts",
-    data => \@firsts,
-   ),
-   $it->make
-   (
-    single => "load",
-    plural => "loads",
-    data => \@ids,
-    fetch => [ \&fetcher, \%ids ],
-   ),
-  );
-
-template_test("simple iter", <<IN, <<OUT, \%acts);
-<:iterator begin firsts
-:><:first id:>: <:first name:>
-  index: <:first_index:>
-  number: <:first_number:>
-  first: <:ifFirstFirst:>Y<:or:>N<:eif:>
-  last: <:ifLastFirst:>Y<:or:>N<:eif:>
-  prev name: <:previous_first name:>
-  next name: <:next_first name:>
-<:iterator end firsts:>
-IN
-3: one
-  index: 0
-  number: 1
-  first: Y
-  last: N
-  prev name: 
-  next name: two
-1: two
-  index: 1
-  number: 2
-  first: N
-  last: N
-  prev name: one
-  next name: three
-2: three
-  index: 2
-  number: 3
-  first: N
-  last: Y
-  prev name: two
-  next name: 
-
-OUT
-
-template_test("fetch iter", <<IN, <<OUT, \%acts);
-<:iterator begin loads
-:><:load id:>: <:load name:>
-  index: <:load_index:>
-  number: <:load_number:>
-  first: <:ifFirstLoad:>Y<:or:>N<:eif:>
-  last: <:ifLastLoad:>Y<:or:>N<:eif:>
-  ifPrev: <:ifPreviousLoad:>Y<:or:>N<:eif:>
-  ifNext: <:ifNextLoad:>Y<:or:>N<:eif:>
-  prev name: <:previous_load name:>
-  next name: <:next_load name:>
-<:iterator end loads:>
-IN
-3: one
-  index: 0
-  number: 1
-  first: Y
-  last: N
-  ifPrev: N
-  ifNext: Y
-  prev name: 
-  next name: two
-1: two
-  index: 1
-  number: 2
-  first: N
-  last: N
-  ifPrev: Y
-  ifNext: Y
-  prev name: one
-  next name: three
-2: three
-  index: 2
-  number: 3
-  first: N
-  last: Y
-  ifPrev: Y
-  ifNext: N
-  prev name: two
-  next name: 
-
-OUT
-
-sub fetcher {
-  my ($ids, $id) = @_;
-
-  return $ids->{$id};
-}
-
-sub template_test {
-  my ($note, $in, $out, $acts) = @_;
-
-  my $templater = Squirrel::Template->new;
-  my $result = $templater->replace_template($in, $acts);
-  return is($result, $out, $note);
-}
diff --git a/t/t10edit.t b/t/t10edit.t
deleted file mode 100644 (file)
index be20480..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-#!perl -w
-use strict;
-use BSE::Test qw(base_url make_ua skip check_form post_ok ok 
-                 check_content follow_ok);
-use URI::QueryParam;
-#use WWW::Mechanize;
-++$|;
-print "1..22\n";
-my $baseurl = base_url;
-my $ua = make_ua;
-
-ok($ua->get("$baseurl/cgi-bin/admin/add.pl?parentid=-1"), "edit page");
-  check_content($ua->{content}, 'edit page',
-             qr!No\s+parent\s+-\s+this\s+is\s+a\s+section
-             .*
-             common/default.tmpl
-             .*
-             Add\s+New\s+Page\s+Lev1
-             !xs);
-check_form($ua->{content},
-          "edit form",
-          parentid=>[ -1, 'select' ],
-          id => [ '', 'hidden' ],
-          template=> [ 'common/default.tmpl', 'select' ],
-          body => [ '', 'textarea' ],
-          listed => [ 1, 'select' ],
-         );
-$ua->field(title=>'Test Article');
-$ua->field(body=>'This is a test body');
-ok($ua->click('save'), 'submit modified edit form');
-# should redirect to admin mode page
-check_content($ua->{content}, "admin mode", 
-          qr!
-          <title>.*Test\ Article.*</title>
-          .*
-          This\ is\ a\ test\ body
-          !xsm);
-my $uri = $ua->uri;
-my $id = $uri->query_param("id");
-# manage sections
-ok($ua->get("$baseurl/cgi-bin/admin/add.pl?id=-1"), "sections page");
-follow_ok($ua, "clean up",
-         {
-          text => "Delete",
-          url_regex => qr/id=$id/
-         }, qr/Article deleted/);
diff --git a/t/t11save.t b/t/t11save.t
deleted file mode 100644 (file)
index efd7588..0000000
+++ /dev/null
@@ -1,547 +0,0 @@
-#!perl -w
-use strict;
-use BSE::Test qw(make_ua base_url);
-use JSON;
-use DevHelp::HTML;
-use Test::More;
-use Article;
-
-my @cols = Article->columns;
-
-my $base = 119;
-
-my $count = $base + (@cols - 13) * 4;
-
-plan tests => $count;
-
-$| = 1;
-
-my $ua = make_ua;
-my $baseurl = base_url;
-
-my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
-
-my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
-
-my %add_req =
-  (
-   save => 1,
-   title => "test",
-   parentid => -1,
-   _context => "test context",
-  );
-my $art_data = do_req($add_url, \%add_req, "add article");
-
-SKIP:
-{
-  $art_data or skip("no response to add", 20);
-  ok($art_data->{success}, "successful json response");
-
-  is($art_data->{context}, "test context", "check context returned");
-
-  my $art = $art_data->{article};
-  my $orig_lastmod = $art->{lastModified};
-
-  # try to fetch by id
- SKIP:
-  {
-    my %fetch_req =
-      (
-       a_article => 1,
-       id => $art->{id},
-      );
-    my $data = do_req($add_url, \%fetch_req, "fetch just saved")
-      or skip("no json", 2);
-    ok($data->{success}, "successful");
-    ok($data->{article}, "has an article");
-    my %temp = %$art;
-    for my $field (qw/release expire/) {
-      delete $temp{$field};
-      delete $data->{article}{$field};
-    }
-    is_deeply($data->{article}, \%temp, "check it matches what we saved");
-    ok($data->{article}{tags}, "has a tags member");
-    is_deeply($data->{article}{tags}, [], "which is an empty array ref");
-  }
-
-  my @fields = grep 
-    {
-      defined $art->{$_}
-       && !/^(id|created|link|admin|files|images|cached_dynamic|createdBy|generator|level|lastModified(By)?|displayOrder)$/
-         && !/^thumb/
-       } keys %$art;
-
-  for my $field (@fields) {
-    print "# save test $field\n";
-    my %reqdata =
-      (
-       save => 1,
-       id => $art->{id},
-       $field => $art->{$field},
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%reqdata, "set $field");
-  SKIP:
-    {
-      $data or skip("Not json from setting $field", 2);
-      ok($data->{success}, "success flag is set");
-      ok($data->{article}, "has an article object");
-      $art = $data->{article};
-    }
-  }
-
-  { # try to set a bad value for category
-    my %req_data = 
-      (
-       save => 1,
-       id => $art->{id},
-       category => "A" . rand(),
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%req_data, "save bad category");
-  SKIP:
-    {
-      $data or skip("Not json from setting bad category", 4);
-      ok(!$data->{success}, "shouldn't be successful");
-      ok(!$data->{article}, "should be no article object");
-      is($data->{error_code}, "FIELD", "should be a field error");
-      ok($data->{errors} && $data->{errors}{category},
-        "should be an error message for category");
-    }
-  }
-
-  my $tag_name1 = "YHUIOP";
-  my $tag_name2 = "zyx: alpha";
-  { # save tags
-    my %reqdata =
-      (
-       save => 1,
-       id => $art->{id},
-       _save_tags => 1,
-       tags => [ $tag_name2, " $tag_name1 " ],
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%reqdata, "set tags");
-  SKIP:
-    {
-      $data or skip("Not json from setting tags", 2);
-      ok($data->{success}, "success flag set");
-      is_deeply($data->{article}{tags}, [ $tag_name1, $tag_name2 ],
-               "check tags saved");
-      $art = $data->{article};
-    }
-  }
-
-  { # grab the tree
-    my %tree_req =
-      (
-       a_tree => 1,
-       id => -1,
-      );
-    my $data = do_req($add_url, \%tree_req, "fetch tree");
-    $data or skip("not a json response", 6);
-    ok($data->{success}, "was successful");
-    ok($data->{articles}, "has articles");
-    my $art = $data->{articles}[0];
-    ok(defined $art->{level}, "entries have level");
-    ok($art->{title}, "entries have a title");
-    ok(defined $art->{listed}, "entries have a listed");
-    ok($art->{lastModified}, "entries have a lastModified");
-  }
-
-  { # grab the tags
-    my %tag_req =
-      (
-       a_tags => 1,
-       id => -1,
-      );
-    my $data = do_req($add_url, \%tag_req, "fetch tags");
-  SKIP:
-    {
-      $data or skip("not a json response", 4);
-      ok($data->{tags}, "it has tags");
-      my ($xyz_tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
-      ok($xyz_tag, "check we found the tag we set");
-      is($xyz_tag->{cat}, "zyx", "check cat");
-      is($xyz_tag->{val}, "alpha", "check val");
-    }
-  }
-
-  my $tag1;
-  my $tag2;
-  { # grab them with article ids
-    my %tag_req =
-      (
-       a_tags => 1,
-       id => -1,
-       showarts => 1,
-      );
-    my $data = do_req($add_url, \%tag_req, "fetch tags");
-  SKIP:
-    {
-      $data or skip("not a json response", 6);
-      ok($data->{tags}, "it has tags");
-      ($tag1) = grep $_->{name} eq $tag_name1, @{$data->{tags}};
-      ($tag2) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
-      ok($tag2, "check we found the tag we set");
-      is($tag2->{cat}, "zyx", "check cat");
-      is($tag2->{val}, "alpha", "check val");
-      ok($tag2->{articles}, "has articles");
-      ok(grep($_ == $art->{id}, @{$tag2->{articles}}),
-             "has our article id in it");
-    }
-  }
-
- SKIP:
-  { # delete a tag globally
-    $tag2
-      or skip("didn't find the tag we want to remove", 6);
-    my %del_req =
-      (
-       a_tagdelete => 1,
-       id => -1,
-       tag_id => $tag2->{id},
-      );
-    my $data = do_req($add_url, \%del_req, "delete tag");
-  SKIP:
-    {
-      $data or skip("not a json response", 7);
-      ok($data->{success}, "successful");
-
-      # refetch tag list and make sure it's gone
-      my %get_req =
-       (
-        a_tags => 1,
-        id => -1,
-       );
-      my $tags_data = do_req($add_url, \%get_req, "refetch tags");
-      my ($tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
-      ok(!$tag, "should be gone");
-
-      # try to delete it again
-      my $redel_data = do_req($add_url, \%del_req, "delete should fail");
-      $redel_data
-       or skip("not a json response", 3);
-      ok(!$redel_data->{success}, "should fail");
-      is($redel_data->{error_code}, "FIELD", "check error code");
-      ok($redel_data->{errors}{tag_id}, "and error message on field");
-    }
-  }
-
-  { # rename a tag
-    my %ren_req =
-      (
-       a_tagrename => 1,
-       id => -1,
-       tag_id => $tag1->{id},
-       name => $tag_name2, # rename over just removed tag
-      );
-
-    my $data = do_req($add_url, \%ren_req, "rename tag");
-  SKIP:
-    {
-      $data
-       or skip("not a json response", 4);
-      ok($data->{success}, "successful");
-      ok($data->{tag}, "returned updated tag");
-      is($data->{tag}{name}, $tag_name2, "check name saved");
-    }
-  }
-
-  { # refetch the article to check the tags
-    my %fetch_req =
-      (
-       a_article => 1,
-       id => $art->{id},
-      );
-    my $data = do_req($add_url, \%fetch_req, "fetch just saved")
-      or skip("no json", 2);
-    ok($data->{success}, "check success");
-    is_deeply($data->{article}{tags}, [ $tag_name2 ],
-             "check the tags");
-  }
-
-  # error handling on save
- SKIP:
-  { # bad title
-    my %bad_title =
-      (
-       save => 1,
-       id => $art->{id},
-       title => "",
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%bad_title, "save bad title");
-    $data or skip("not a json response", 2);
-    ok(!$data->{success}, "should be failure");
-    is($data->{error_code}, "FIELD", "should be a field error");
-    ok($data->{errors}{title}, "should be a message for the title");
-  }
- SKIP:
-  { # bad template
-    my %bad_template =
-      (
-       save => 1,
-       id => $art->{id},
-       template => "../../etc/passwd",
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%bad_template, "save bad template");
-    $data or skip("not a json response", 2);
-    ok(!$data->{success}, "should be failure");
-    is($data->{error_code}, "FIELD", "should be a field error");
-    ok($data->{errors}{template}, "should be a message for the template");
-  }
- SKIP:
-  { # bad last modified
-    my %bad_lastmod =
-      (
-       save => 1,
-       id => $art->{id},
-       title => "test",
-       lastModified => $orig_lastmod,
-      );
-    my $data = do_req($add_url, \%bad_lastmod, "save bad lastmod");
-    $data or skip("not a json response", 2);
-    ok(!$data->{success}, "should be failure");
-    is($data->{error_code}, "LASTMOD", "should be a last mod error");
-  }
- SKIP:
-  { # bad parent
-    my %bad_parent =
-      (
-       save => 1,
-       id => $art->{id},
-       parentid => $art->{id},
-       lastModified => $art->{lastModified},
-      );
-    my $data = do_req($add_url, \%bad_parent, "save bad parent");
-    $data or skip("not a json response", 2);
-    ok(!$data->{success}, "should be failure");
-    is($data->{error_code}, "PARENT", "should be a parent error");
-  }
-
-  # grab config data for the article
- SKIP:
-  {
-    my %conf_req =
-      (
-       a_config => 1,
-       id => $art->{id},
-      );
-    my $data = do_req($add_url, \%conf_req, "config data");
-    $data or skip("no json to check", 7);
-    ok($data->{success}, "check for success");
-    ok($data->{templates}, "has templates");
-    ok($data->{thumb_geometries}, "has geometries");
-    ok($data->{defaults}, "has defaults");
-    ok($data->{child_types}, "has child types");
-    is($data->{child_types}[0], "Article", "check child type value");
-    ok($data->{flags}, "has flags");
-  }
-
- SKIP:
-  { # config article for children of the article
-    my %conf_req =
-      (
-       a_config => 1,
-       parentid => $art->{id},
-      );
-    my $data = do_req($add_url, \%conf_req, "config data");
-    $data or skip("no json to check", 3);
-    ok($data->{success}, "check for success");
-    ok($data->{templates}, "has templates");
-    ok($data->{thumb_geometries}, "has geometries");
-    ok($data->{defaults}, "has defaults");
-  }
-
- SKIP:
-  { # section config
-    my %conf_req =
-      (
-       a_config => 1,
-       parentid => -1,
-      );
-    my $data = do_req($add_url, \%conf_req, "section config data");
-    $data or skip("no json to check", 3);
-    ok($data->{success}, "check for success");
-    ok($data->{templates}, "has templates");
-    ok($data->{thumb_geometries}, "has geometries");
-    ok($data->{defaults}, "has defaults");
-    use Data::Dumper;
-    note(Dumper($data));
-  }
-
- SKIP:
-  {
-    my $parent = do_add($add_url, { parentid => -1, title => "parent" }, "add parent");
-    my $kid1 = do_add($add_url, { parentid => $parent->{id}, title => "kid1" }, "add first kid");
-    sleep 2;
-    my $kid2 = do_add($add_url,
-                     {
-                      parentid => $parent->{id},
-                      title => "kid2",
-                      _after => $kid1->{id},
-                     }, "add second child");
-    my @expected_order = ( $kid1->{id}, $kid2->{id} );
-    my %tree_req =
-      (
-       a_tree => 1,
-       id => $parent->{id},
-      );
-    my $data = do_req($add_url, \%tree_req, "get newly ordered tree");
-    ok($data->{success}, "got the tree");
-    my @saved_order = map $_->{id}, @{$data->{articles}};
-    is_deeply(\@saved_order, \@expected_order, "check saved order");
-
-    {
-      {
-       # stepkids
-       my %add_step =
-         (
-          add_stepkid => 1,
-          id => $parent->{id},
-          stepkid => $art->{id},
-          _after => $kid1->{id},
-         );
-       sleep(2);
-       my $result = do_req($add_url, \%add_step, "add stepkid in order");
-       ok($result->{success}, "Successfully");
-       my $rel = $result->{relationship};
-       ok($rel, "has a relationship");
-       is($rel->{childId}, $art->{id}, "check the rel child id");
-       is($rel->{parentId}, $parent->{id}, "check the rel parent id");
-      }
-
-      {
-       # refetch the tree
-       my $data = do_req($add_url, \%tree_req, "get tree with stepkid");
-       my @expected_order = ( $kid1->{id}, $art->{id}, $kid2->{id} );
-       my @found_order = map $_->{id}, @{$data->{allkids}};
-       is_deeply(\@found_order, \@expected_order, "check new order");
-      }
-
-      {
-       # remove the stepkid
-       my %del_step =
-         (
-          del_stepkid => 1,
-          id => $parent->{id},
-          stepkid => $art->{id},
-          _after => $kid1->{id},
-         );
-       my $result = do_req($add_url, \%del_step, "delete stepkid");
-       ok($result->{success}, "check success");
-
-       $result = do_req($add_url, \%del_step, "delete stepkid again (should failed)");
-       ok(!$result->{success}, "it failed");
-
-       my $data = do_req($add_url, \%tree_req, "get tree with stepkid removed");
-       my @expected_order = ( $kid1->{id}, $kid2->{id} );
-       my @found_order = map $_->{id}, @{$data->{allkids}};
-       is_deeply(\@found_order, \@expected_order, "check new order with stepkid removed");
-      }
-    }
-
-    do_req($add_url, { remove => 1, id => $kid1->{id} }, "remove kid1");
-    do_req($add_url, { remove => 1, id => $kid2->{id} }, "remove kid2");
-    do_req($add_url, { remove => 1, id => $parent->{id} }, "remove parent");
-  }
-
-  # delete it
- SKIP:
-  {
-    my %del_req =
-      (
-       remove => 1,
-       id => $art->{id},
-       _context => $art->{id},
-      );
-    my $data = do_req($add_url, \%del_req, "remove test article");
-    $data or skip("no json from req", 3);
-    ok($data->{success}, "successfully deleted");
-    is($data->{article_id}, $art->{id}, "check id returned");
-    is($data->{context}, $art->{id}, "check context returned");
-  }
-
-  # shouldn't be fetchable anymore
- SKIP:
-  {
-    my %fetch_req =
-      (
-       a_article => 1,
-       id => $art->{id},
-      );
-    my $data = do_req($add_url, \%fetch_req, "fetch just deleted")
-      or skip("no json", 2);
-    ok(!$data->{success}, "failed as expected");
-  }
-}
-
-SKIP:
-{ # tag cleanup
-  my %clean_req =
-    (
-     a_tagcleanup => 1,
-     id => -1,
-    );
-  my $data = do_req($add_url, \%clean_req, "tag cleanup");
-  $data
-    or skip("no json response", 2);
-  ok($data->{success}, "successful");
-  ok($data->{count}, "should have cleaned up something");
-}
-
-sub do_req {
-  my ($url, $req_data, $comment) = @_;
-
-  my @entries;
-  for my $key (keys %$req_data) {
-    my $value = $req_data->{$key};
-    if (ref $value) {
-      for my $val (@$value) {
-       push @entries, "$key=" . escape_uri($val);
-      }
-    }
-    else {
-      push @entries, "$key=" . escape_uri($value);
-    }
-  }
-  my $content = join("&", @entries);
-
-  print <<EOS;
-# Request:
-# URL: $add_url
-# Content: $content
-EOS
-
-  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
-
-  $req->content($content);
-
-  my $resp = $ua->request($req);
-  ok($resp->is_success, "$comment successful at http level");
-  my $data = eval { from_json($resp->decoded_content) };
-  ok($data, "$comment response decoded as json")
-    or print "# $@\n";
-
-  return $data;
-}
-
-sub do_add {
-  my ($url, $req, $comment) = @_;
-
-  $req->{save} = 1;
-
-  my $result = do_req($url, $req, $comment);
-  my $article;
- SKIP:
-  {
-    $result or skip("No JSON result", 1);
-    if (ok($result->{success} && $result->{article}, "check success and article")) {
-      return $result->{article};
-    }
-  };
-
-  return;
-}
diff --git a/t/t12cat.t b/t/t12cat.t
deleted file mode 100644 (file)
index 115ae9f..0000000
+++ /dev/null
@@ -1,145 +0,0 @@
-#!perl -w
-use strict;
-use BSE::Test qw(make_ua base_url);
-use JSON;
-use DevHelp::HTML;
-use Test::More tests => 34;
-use Data::Dumper;
-
-my $ua = make_ua;
-my $baseurl = base_url;
-
-my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
-
-my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
-
-# make a catalog
-my $cat = do_add($add_url, 
-                { 
-                 parentid => 3,
-                 title => "Test Catalog",
-                 type => "Catalog",
-                }, "make test catalog");
-
-is($cat->{generator}, "Generate::Catalog", "make sure it's a catalog");
-
-# and an article
-my $art = do_add($add_url, 
-                {
-                 parentid => -1,
-                 title => "Test article",
-                }, "make test article");
-
-is($art->{generator}, "Generate::Article", "make sure it's an article");
-
-my $prod;
-{
-  # make a product
-  my $result = do_add
-    ($add_url,
-     {
-      type => "Product",
-      parentid => $cat->{id},
-      title => "Some Product",
-     }, "make test product");
-  is($result->{generator}, "Generate::Product",
-     "check generator");
-  $prod = $result;
-}
-
-{
-  # fail to make a product (empty title)
-  my $result = do_req
-    ($add_url,
-     {
-      type => "Product",
-      parentid => $cat->{id},
-      title => "",
-      save => 1,
-     }, "fail to make a product");
-  ok(!$result->{success}, "yep, it failed");
-  is($result->{error_code}, "FIELD", "and correct error code");
-  ok($result->{errors}{title}, "has a title error");
-}
-
-{ # fail to set empty title for a product
-  my $result = do_req
-    ($add_url,
-     {
-      id => $prod->{id},
-      title => "",
-      lastModified => $prod->{lastModified},
-      save => 1,
-     }, "fail to set title to empty");
-  ok(!$result->{success}, "yep, it failed");
-  is($result->{error_code}, "FIELD", "and correct error code");
-  ok($result->{errors}{title}, "has a title error");
-}
-
-{
-  # attempt to reparent the article under the catalog, should fail
-  my $result = do_req($add_url, 
-                     { 
-                      save => 1, 
-                      id=> $art->{id},
-                      parentid => $cat->{id},
-                      lastModified => $art->{lastModified},
-                     },
-                     "reparent article under catalog");
-  ok(!$result->{success}, "should have failed")
-    and print "# $result->{error_code}: $result->{message}\n";
-}
-{
-  # and the other way around
-  my $result = do_req($add_url, 
-                     { 
-                      save => 1, 
-                      id=> $cat->{id},
-                      parentid => $art->{id},
-                      lastModified => $cat->{lastModified},
-                     },
-                     "reparent catalog under article");
-  ok(!$result->{success}, "should have failed")
-    and print "# $result->{error_code}: $result->{message}\n";
-}
-
-do_req($add_url, { remove => 1, id => $prod->{id} }, "remove product");
-do_req($add_url, { remove => 1, id => $art->{id} }, "remove article");
-do_req($add_url, { remove => 1, id => $cat->{id} }, "remove catalog");
-
-sub do_req {
-  my ($url, $req_data, $comment) = @_;
-
-  my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
-  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
-
-  $req->content($content);
-  
-  my $resp = $ua->request($req);
-  ok($resp->is_success, "$comment successful at http level");
-  my $data = eval { from_json($resp->decoded_content) };
-  ok($data, "$comment response decoded as json")
-    or print "# $@: ", $resp->decoded_content, "\n";
-
-  return $data;
-}
-
-sub do_add {
-  my ($url, $req, $comment) = @_;
-
-  $req->{save} = 1;
-
-  my $result = do_req($url, $req, $comment);
-  my $article;
- SKIP:
-  {
-    $result or skip("No JSON result", 1);
-    if (ok($result->{success} && $result->{article}, "check success and article")) {
-      return $result->{article};
-    }
-
-    print STDERR Dumper($result);
-  };
-
-  return;
-}
diff --git a/t/t13parent.t b/t/t13parent.t
deleted file mode 100644 (file)
index d689667..0000000
+++ /dev/null
@@ -1,79 +0,0 @@
-#!perl -w
-use strict;
-use BSE::Test qw(make_ua base_url);
-use JSON;
-use DevHelp::HTML;
-use Test::More tests => 13;
-
-my $ua = make_ua;
-my $baseurl = base_url;
-
-my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
-
-my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
-
-# make a parent
-my $par = do_add($add_url, 
-                { 
-                 parentid => -1,
-                 title => "parent",
-                }, "make test parent");
-
-# and a child
-my $child = do_add($add_url, 
-                {
-                 parentid => $par->{id},
-                 title => "child",
-                }, "make test child");
-
-{
-  # attempt to reparent the parent under the child, should fail
-  my $result = do_req($add_url, 
-                     { 
-                      save => 1, 
-                      id=> $par->{id},
-                      parentid => $child->{id},
-                      lastModified => $par->{lastModified},
-                     },
-                     "reparent parent under child");
-  ok(!$result->{success}, "should have failed")
-    and print "# $result->{error_code}: $result->{message}\n";
-}
-
-do_req($add_url, { remove => 1, id => $child->{id} }, "remove child");
-do_req($add_url, { remove => 1, id => $par->{id} }, "remove parent");
-
-sub do_req {
-  my ($url, $req_data, $comment) = @_;
-
-  my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
-  my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
-
-  $req->content($content);
-  
-  my $resp = $ua->request($req);
-  ok($resp->is_success, "$comment successful at http level");
-  my $data = eval { from_json($resp->decoded_content) };
-  ok($data, "$comment response decoded as json")
-    or print "# $@\n";
-
-  return $data;
-}
-
-sub do_add {
-  my ($url, $req, $comment) = @_;
-
-  $req->{save} = 1;
-
-  my $result = do_req($url, $req, $comment);
-  my $article;
- SKIP:
-  {
-    $result or skip("No JSON result", 1);
-    if (ok($result->{success} && $result->{article}, "check success and article")) {
-      return $result->{article};
-    }
-  };
-
-  return;
-}
diff --git a/t/t13steps.t b/t/t13steps.t
deleted file mode 100644 (file)
index 00934b8..0000000
+++ /dev/null
@@ -1,208 +0,0 @@
-#!perl -w
-use strict;
-use BSE::Test qw(make_ua base_url);
-use JSON;
-use DevHelp::HTML;
-use Test::More tests => 93;
-use Data::Dumper;
-
-my $ua = make_ua;
-my $baseurl = base_url;
-
-my $add_url = $baseurl . "/cgi-bin/admin/add.pl";
-
-my @ajax_hdr = qw(X-Requested-With: XMLHttpRequest);
-
-my $parent = do_add({ parentid => -1, title => "parent2" }, "make parent");
-sleep 1;
-my @kids1;
-my @kids2;
-for my $num (1..3) {
-  push @kids1, 
-    do_add({ parentid => $parent->{id}, title => "kid$num"}, "make parent  first kid");
-sleep 1;
-}
-
-for my $num (1..3) {
-  push @kids2,
-    do_add({ parentid => $kids1[1]{id}, title => "kid2 - kid $num"}, "make kid2 1 first kid");
-  sleep 1;
-}
-
-my $base = do_add({ parentid => -1, title => "base" }, "make base article");
-sleep 1;
-
-{
-  my %add_step =
-    (
-     add_stepkid => 1,
-     id => $parent->{id},
-     stepkid => $base->{id},
-     _after => $kids1[1]{id},
-    );
-  my $step_res = do_req($add_url, \%add_step, "add step kid in order");
-  ok($step_res->{success}, "add step kid success")
-    or diag(Dumper($step_res));
-
-  my %tree_req =
-    (
-     a_tree => 1,
-     id => $parent->{id},
-    );
-  my $result = do_req($add_url, \%tree_req, "get order");
-  ok($result->{success}, "got tree ok");
-  my @got_order = map $_->{id}, @{$result->{allkids}};
-  my @exp_order = ( $kids1[2]{id}, $kids1[1]{id}, $base->{id}, $kids1[0]{id} );
-  is_deeply(\@got_order, \@exp_order, "check kid inserted correctly")
-}
-
-{
-  my %move_step =
-    (
-     a_restepkid => 1,
-     id => $base->{id},
-     parentid => $parent->{id},
-     newparentid => $kids1[1]{id},
-     _after => $kids2[1]{id},
-    );
-  my $restep_res = do_req($add_url, \%move_step, "move stepkid in order");
-  ok($restep_res->{success}, "restep kid success")
-    or diag(Dumper($restep_res));
-
-  {
-    # shouldn't be under $parent anymore
-    my %tree_req =
-      (
-       a_tree => 1,
-       id => $parent->{id},
-      );
-    my $result = do_req($add_url, \%tree_req, "get parent order");
-    ok($result->{success}, "got tree ok");
-    my @got_order = map $_->{id}, @{$result->{allkids}};
-    my @exp_order = ( $kids1[2]{id}, $kids1[1]{id}, $kids1[0]{id} );
-    is_deeply(\@got_order, \@exp_order, "check kid moved away correctly")
-  }
-  {
-    my %tree_req =
-      (
-       a_tree => 1,
-       id => $kids1[1]->{id},
-      );
-    my $result = do_req($add_url, \%tree_req, "get kids1[1] order");
-    ok($result->{success}, "got tree ok");
-    my @got_order = map $_->{id}, @{$result->{allkids}};
-    my @exp_o