t/testload.pm

   1 package testload;
   2
   3 use vars qw( @ISA @EXPORT $Dat_Dir );
   4
   5 use strict;
   6 use Test::More;
   7
   8 my $DEBUG = 0;
   9
  10 require Exporter;
  11 @ISA = qw(Exporter);
  12 @EXPORT = qw( $Dat_Dir check_datetool case_count
  13               check_basic_with_datetool
  14               check_woy_with_datetool
  15               dq_nums
  16             );
  17
  18 use File::Spec;
  19
  20 use HTML::CalendarMonth;
  21 use HTML::CalendarMonth::DateTool;
  22
  23 my($base_dir, $vol, $dir);
  24 BEGIN {
  25   my $pkg = __PACKAGE__;
  26   $pkg =~ s%::%/%g;
  27   $pkg .= '.pm';
  28   $pkg = File::Spec->canonpath($INC{$pkg});
  29   my $file;
  30   ($vol, $dir, $file) = File::Spec->splitpath($pkg);
  31   $base_dir = File::Spec->catpath($vol, $dir, '');
  32 }
  33 $Dat_Dir = $base_dir;
  34
  35 my($tcount, $rds, %dates, @tmethods, @twy_methods, @Cals);
  36
  37 # Required test dates
  38 my $dat_file = File::Spec->catpath($vol, $dir, 'test.dat');
  39 open(D, "<$dat_file") or die "Problem reading $dat_file: $!\n";
  40 $rds = <D>;
  41 foreach (split(' ', $rds)) {
  42   ++$dates{$_};
  43 }
  44
  45 my %WOY_data;
  46 eval join('', <DATA>);
  47 die "Oops on eval: $@\n" if $@;
  48
  49 # Today's date
  50 my($month, $year) = (localtime(time))[4,5];
  51 ++$month;
  52 $year += 1900;
  53
  54 # Flag tests for a year
  55 foreach my $y ($year .. $year + 1) {
  56   foreach my $m (1 .. 12) {
  57     ++$dates{sprintf("%d/%02d", $y, $m)};
  58   }
  59 }
  60
  61 # Yank test cases
  62 while (<D>) {
  63   chomp;
  64   my($d, $wb) = split(' ', $_);
  65   my($y, $m) = split('/', $d);
  66   my $cal = <D>;
  67   push(@Cals, [$y, $m, $cal, $wb]) if $dates{"$y/$m"};
  68 }
  69
  70 close(D);
  71
  72 #############
  73
  74 # guard against HTML::Tree starting to quote numeric attrs as of
  75 # v3.19_02
  76
  77 sub dq_nums {
  78   my $str = shift;
  79   $str =~ s/\"(\d+)\"/$1/g;
  80   return $str;
  81 }
  82
  83 sub case_count { scalar @Cals }
  84
  85 sub check_datetool {
  86   my $datetool = shift;
  87   my $module = HTML::CalendarMonth::DateTool->toolmap($datetool);
  88   ok($module, "toolmap($datetool) : $module");
  89   require_ok($module);
  90 }
  91
  92 sub check_basic_with_datetool {
  93   my $datetool = shift;
  94   my @days = qw( Sun Mon Tue Wed Thr Fri Sat );
  95   my $method = $datetool || 'auto-select';
  96   foreach my $cal (@Cals) {
  97     my $c = HTML::CalendarMonth->new(
  98       year       => $cal->[0],
  99       month      => $cal->[1],
 100       week_begin => $cal->[3],
 101       datetool   => $datetool,
 102     );
 103     # Because HTML::TreeBuilder has changed a few times, this can't be exactly equal
 104     my $gen_html = $c->as_HTML;
 105     $gen_html =~ s/\=\"(\d+)\"/=$1/g;
 106     my $day1 = $days[$cal->[3] - 1];
 107     cmp_ok(dq_nums($c->as_HTML), 'eq', $cal->[2],
 108        sprintf("(%d/%-02d %s 1st day) using %s",
 109                $cal->[0], $cal->[1], $day1, $method));
 110     if ($DEBUG && $c->as_HTML ne $cal->[2]) {
 111       debug_dump('Broken', $c->as_HTML, 'Test Data', $cal->[2]);
 112     }
 113   }
 114 }
 115
 116 sub check_woy_with_datetool {
 117   my $datetool = shift;
 118   my $year = 2000;
 119   foreach my $month (qw(01 12)) {
 120     my $tc = $WOY_data{"$year/$month"};
 121     my $cal = HTML::CalendarMonth->new(
 122       year       => $year,
 123       month      => $month,
 124       head_week  => 1,
 125       datetool   => $datetool,
 126     );
 127     my $ct = dq_nums($cal->as_HTML);
 128     chomp $ct;
 129     $ct =~ s/\=\"(\d+)\"/=$1/g;
 130     cmp_ok($ct, 'eq', $tc, "($year/$month week of year) using $datetool");
 131     if ($DEBUG && $ct ne $tc) {
 132       debug_dump('Broken', $ct, 'Test Data', $tc);
 133     }
 134   }
 135 }
 136
 137 sub debug_dump {
 138   my($l1, $str1, $l2, $str2) = @_;
 139   local(*DUMP);
 140   open(DUMP, ">$DEBUG") or die "Could not dump to $DEBUG: $!\n";
 141   print DUMP "<html><body><table><tr><td>$l1</td><td>$l2</td></tr><tr><td>\n";
 142   print DUMP "$str1\n</td><td>\n";
 143   print DUMP "$str2\n</td></tr></table></body></html>\n";
 144   close(DUMP);
 145   print STDERR "\nDumped tables to $DEBUG. Aborting test.\n";
 146   exit;
 147 }
 148
 149 __DATA__
 150 $WOY_data{'2000/01'} = '<table bgcolor="white" border=1 cellpadding=0 cellspacing=0><tr align="center"><td align="left" colspan=6>January</td><td align="center" colspan=2>2000</td></tr><tr align="center"><td align="center">Sun</td><td align="center">Mon</td><td align="center">Tue</td><td align="center">Wed</td><td align="center">Thu</td><td align="center">Fri</td><td align="center">Sat</td><td align="center">&nbsp; </td></tr><tr align="center"><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">1</td><td align="center">52</td></tr><tr align="center"><td align="center">2</td><td align="center">3</td><td align="center">4</td><td align="center">5</td><td align="center">6</td><td align="center">7</td><td align="center">8</td><td align="center">1</td></tr><tr align="center"><td align="center">9</td><td align="center">10</td><td align="center">11</td><td align="center">12</td><td align="center">13</td><td align="center">14</td><td align="center">15</td><td align="center">2</td></tr><tr align="center"><td align="center">16</td><td align="center">17</td><td align="center">18</td><td align="center">19</td><td align="center">20</td><td align="center">21</td><td align="center">22</td><td align="center">3</td></tr><tr align="center"><td align="center">23</td><td align="center">24</td><td align="center">25</td><td align="center">26</td><td align="center">27</td><td align="center">28</td><td align="center">29</td><td align="center">4</td></tr><tr align="center"><td align="center">30</td><td align="center">31</td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">5</td></tr></table>';
 151 $WOY_data{'2000/12'} = '<table bgcolor="white" border=1 cellpadding=0 cellspacing=0><tr align="center"><td align="left" colspan=6>December</td><td align="center" colspan=2>2000</td></tr><tr align="center"><td align="center">Sun</td><td align="center">Mon</td><td align="center">Tue</td><td align="center">Wed</td><td align="center">Thu</td><td align="center">Fri</td><td align="center">Sat</td><td align="center">&nbsp; </td></tr><tr align="center"><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">1</td><td align="center">2</td><td align="center">48</td></tr><tr align="center"><td align="center">3</td><td align="center">4</td><td align="center">5</td><td align="center">6</td><td align="center">7</td><td align="center">8</td><td align="center">9</td><td align="center">49</td></tr><tr align="center"><td align="center">10</td><td align="center">11</td><td align="center">12</td><td align="center">13</td><td align="center">14</td><td align="center">15</td><td align="center">16</td><td align="center">50</td></tr><tr align="center"><td align="center">17</td><td align="center">18</td><td align="center">19</td><td align="center">20</td><td align="center">21</td><td align="center">22</td><td align="center">23</td><td align="center">51</td></tr><tr align="center"><td align="center">24</td><td align="center">25</td><td align="center">26</td><td align="center">27</td><td align="center">28</td><td align="center">29</td><td align="center">30</td><td align="center">52</td></tr><tr align="center"><td align="center">31</td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">&nbsp; </td><td align="center">1</td></tr></table>';