t/testload.pm

   1 package testload;
   2
   3 use vars qw( @ISA @EXPORT $Dat_Dir );
   4
   5 use strict;
   6 use warnings;
   7 use Test::More;
   8
   9 use Cwd qw( abs_path );
  10
  11 my $DEBUG = 0;
  12
  13 require Exporter;
  14 @ISA = qw(Exporter);
  15
  16 use vars qw(
  17   $Dat_Dir
  18   $Bulk_File
  19   $Odd_File
  20   $Woy_File
  21   $I8N_File
  22   $Narrow_File
  23 );
  24
  25 @EXPORT = qw(
  26   $Dat_Dir
  27   $Bulk_File $Odd_File $Woy_File $I8N_File $Narrow_File
  28   check_datetool
  29   check_bulk_with_datetool
  30   check_odd_with_datetool
  31   check_woy_with_datetool
  32   check_i8n
  33   check_narrow
  34
  35   bulk_count
  36   odd_count
  37   woy_count
  38   i8n_count
  39   narrow_count
  40
  41   clean
  42 );
  43
  44 use File::Spec;
  45
  46 use HTML::CalendarMonth;
  47 use HTML::CalendarMonth::DateTool;
  48
  49 BEGIN {
  50   my($vol, $dir, $file) = File::Spec->splitpath(abs_path(__FILE__));
  51   $dir = File::Spec->catdir($dir, 'dat');
  52   $Dat_Dir = File::Spec->catpath($vol, $dir, '');
  53 }
  54
  55 $Bulk_File   = File::Spec->catdir($Dat_Dir,   'bulk.dat');
  56 $Odd_File    = File::Spec->catdir($Dat_Dir,    'odd.dat');
  57 $Woy_File    = File::Spec->catdir($Dat_Dir,    'woy.dat');
  58 $I8N_File    = File::Spec->catdir($Dat_Dir,    'i8n.dat');
  59 $Narrow_File = File::Spec->catdir($Dat_Dir, 'narrow.dat');
  60
  61 my(@Bulk, @Odd, @Woy, @I8N, @Nar);
  62
  63 sub _load_file {
  64   my $f   = shift;
  65   my $cal = shift || [];
  66   local(*F);
  67   return unless open(F, '<', $f);
  68   while (my $h = <F>) {
  69     chomp $h;
  70     my($d, $wb) = split(/\s+/, $h);
  71     my($y, $m) = split(/\//, $d);
  72     my $c = <F>;
  73     chomp $c;
  74     push(@$cal, [$d, $y, $m, $wb, clean($c)]);
  75   }
  76   $cal;
  77 }
  78
  79 _load_file($Bulk_File, \@Bulk   );
  80 _load_file($Odd_File,   \@Odd   );
  81 _load_file($Woy_File,    \@Woy  );
  82 _load_file($I8N_File,     \@I8N );
  83 _load_file($Narrow_File,   \@Nar);
  84
  85 sub bulk_count   { scalar @Bulk }
  86 sub odd_count    { scalar @Odd  }
  87 sub woy_count    { scalar @Woy  }
  88 sub i8n_count    { scalar @I8N  }
  89 sub narrow_count { scalar @Nar  }
  90
  91 # Today's date
  92 my($month, $year) = (localtime(time))[4,5];
  93 ++$month;
  94 $year += 1900;
  95
  96 my $today         = sprintf("%d/%02d", $year, $month);
  97 my $year_from_now = sprintf("%d/%02d", $year+1, $month);
  98
  99 # keep the next year
 100 @Bulk = grep { $_ ge $today && $_->[0] le $year_from_now } @Bulk;
 101
 102 ###
 103
 104 sub clean {
 105   my $str = shift || Carp::confess "string required";
 106   $str =~ s/^\s*//; $str =~ s/\s*$//;
 107   # guard against HTML::Tree starting to quote numeric attrs as of
 108   # v3.19_02
 109   $str =~ s/\"(\d+)\"/$1/g;
 110   $str;
 111 }
 112
 113 sub check_datetool {
 114   my $datetool = shift;
 115   my $module = HTML::CalendarMonth::DateTool->_toolmap($datetool);
 116   ok($module, "toolmap($datetool) : $module");
 117   require_ok($module);
 118 }
 119
 120 sub check_bulk_with_datetool {
 121   my $datetool = shift;
 122   my @days;
 123   foreach (@Bulk) {
 124     my($d, $y, $m, $wb, $tc) = @$_;
 125     my $c = HTML::CalendarMonth->new(
 126       year       => $y,
 127       month      => $m,
 128       week_begin => $wb,
 129       datetool   => $datetool,
 130     );
 131     @days = $c->dayheaders unless @days;
 132     my $day1 = $days[$wb - 1];
 133     my $method = $c->_caltool->_name;
 134     $method = "auto-select ($method)" unless $datetool;
 135     my $msg = sprintf(
 136       "(%d/%02d %s 1st day) using %s",
 137       $y, $m, $day1, $method
 138     );
 139     cmp_ok(clean($c->as_HTML), 'eq', $tc, $msg);
 140   }
 141 }
 142
 143 sub check_odd_with_datetool {
 144   my $datetool = shift;
 145   my @days;
 146   foreach (@Odd) {
 147     my($d, $y, $m, $wb, $tc) = @$_;
 148     SKIP: {
 149       my $c;
 150       eval {
 151         $c = HTML::CalendarMonth->new(
 152           year       => $y,
 153           month      => $m,
 154           week_begin => $wb,
 155           datetool   => $datetool,
 156         );
 157       };
 158       if ($@ || !$c) {
 159         croak $@ unless $@ =~ /(no|in)\s*valid date tool/i;
 160         skip("$datetool skip odd $y/$m", 1);
 161       }
 162       @days = $c->dayheaders unless @days;
 163       my $day1 = $days[$wb - 1];
 164       my $method = $c->_caltool->_name;
 165       $method = "auto-select ($method)" unless $datetool;
 166       my $msg = sprintf(
 167         "(%d/%02d %s 1st day) using %s",
 168         $y, $m, $day1, $method
 169       );
 170       cmp_ok(clean($c->as_HTML), 'eq', $tc, $msg);
 171     }
 172   }
 173 }
 174
 175 sub check_woy_with_datetool {
 176   my $datetool = shift;
 177   foreach (@Woy) {
 178     my($d, $y, $m, $wb, $tc) = @$_;
 179     my $c = HTML::CalendarMonth->new(
 180       year       => $y,
 181       month      => $m,
 182       head_week  => 1,
 183       datetool   => $datetool,
 184     );
 185     my $msg = sprintf("(%d/%02d week of year) using %s", $y, $m, $datetool);
 186     cmp_ok(clean($c->as_HTML), 'eq', $tc, $msg);
 187   }
 188 }
 189
 190 sub check_i8n {
 191   foreach (@I8N) {
 192     my($d, $y, $m, $id, $tc) = @$_;
 193     my $c = HTML::CalendarMonth->new(
 194       year   => $y,
 195       month  => $m,
 196       locale => $id,
 197     );
 198     my $name = $c->loc->loc->name;
 199     my $msg = sprintf(
 200       "(%d/%02d i8n) %s (wb:%d) using auto-detect",
 201       $y, $m, $name, $c->week_begin
 202     );
 203     cmp_ok(clean($c->as_HTML), 'eq', $tc, $msg);
 204   }
 205 }
 206
 207 sub check_narrow {
 208   my @days;
 209   foreach (@Nar) {
 210     my($d, $y, $m, $wb, $tc) = @$_;
 211     my $c = HTML::CalendarMonth->new(
 212       year       => $y,
 213       month      => $m,
 214       week_begin => $wb,
 215       full_days  => -1,
 216     );
 217     @days = $c->dayheaders unless @days;
 218     my $day1 = $days[$wb - 1];
 219     my $msg = sprintf(
 220       "(%d/%02d %s/%s 1st day) narrow/alias using auto-detect",
 221       $y, $m, $day1, $c->item_alias($day1)
 222     );
 223     cmp_ok(clean($c->as_HTML), 'eq', $tc, $msg);
 224   }
 225 }
 226
 227 sub debug_dump {
 228   my($l1, $str1, $l2, $str2) = @_;
 229   local(*DUMP);
 230   open(DUMP, ">$DEBUG") or die "Could not dump to $DEBUG: $!\n";
 231   print DUMP "<html><body><table><tr><td>$l1</td><td>$l2</td></tr><tr><td>\n";
 232   print DUMP "$str1\n</td><td>\n";
 233   print DUMP "$str2\n</td></tr></table></body></html>\n";
 234   close(DUMP);
 235   print STDERR "\nDumped tables to $DEBUG. Aborting test.\n";
 236   exit;
 237 }
 238
 239 1;