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