lib/HTML/CalendarMonth/DateTool.pm

   1 package HTML::CalendarMonth::DateTool;
   2 BEGIN {
   3   $HTML::CalendarMonth::DateTool::VERSION = '1.25';
   4 }
   5
   6 # Base class for determining what date calculation package to use.
   7
   8 use strict;
   9 use warnings;
  10 use Carp;
  11
  12 use File::Which qw( which );
  13
  14 my %Toolmap = (
  15   'Time::Local' => 'TimeLocal',
  16   'Date::Calc'  => 'DateCalc',
  17   'DateTime'    => 'DateTime',
  18   'Date::Manip' => 'DateManip',
  19   'ncal'        => 'Ncal',
  20   'cal'         => 'Cal',
  21 );
  22
  23 my %Classmap;
  24 $Classmap{lc $Toolmap{$_}} = $_ foreach keys %Toolmap;
  25
  26 my($Cal_Cmd, $Ncal_Cmd);
  27
  28 sub _toolmap {
  29   shift;
  30   my $str = shift;
  31   my $tool = $Toolmap{$str};
  32   unless ($tool) {
  33     foreach (values %Toolmap) {
  34       if ($str =~ /^$_$/i) {
  35         $tool = $_;
  36         last;
  37       }
  38     }
  39   }
  40   return unless $tool;
  41   join('::', __PACKAGE__, $tool);
  42 }
  43
  44 sub new {
  45   my $class = shift;
  46   my $self = {};
  47   bless $self, $class;
  48   my %parms = @_;
  49   $self->{year}     = $parms{year};
  50   $self->{month}    = $parms{month};
  51   $self->{weeknum}  = $parms{weeknum};
  52   $self->{historic} = $parms{historic};
  53   if (! $self->{year}) {
  54     my @dmy = $self->_dmy_now;
  55     $self->{year}    = $dmy[2];
  56     $self->{month} ||= $dmy[1];
  57   }
  58   $self->{month} ||= 1;
  59   if ($parms{datetool}) {
  60     $self->{datetool} = $self->_toolmap($parms{datetool})
  61       or croak "Sorry, didn't find a tool for datetool '$parms{datetool}'\n";
  62   }
  63   my $dc = $self->_summon_date_class;
  64   unless (eval "require $dc") {
  65     croak "Problem loading $dc ($@)\n";
  66   }
  67   # rebless into new class
  68   bless $self, $dc;
  69 }
  70
  71 sub year     { shift->{year}     }
  72 sub month    { shift->{month}    }
  73 sub weeknum  { shift->{weeknum}  }
  74 sub historic { shift->{historic} }
  75 sub datetool { shift->{datetool} }
  76
  77 sub _name {
  78   my $class = shift;
  79   $class = ref $class || $class;
  80   lc((split(/::/, $class))[-1]);
  81 }
  82
  83 sub _cal_cmd {
  84   my $self = shift;
  85   if (! defined $Cal_Cmd) {
  86     $Cal_Cmd = which('cal') || '';
  87     if ($Cal_Cmd) {
  88       my @out = grep { ! /^\s*$/ } `$Cal_Cmd 9 1752`;
  89       #   September 1752
  90       #Su Mo Tu We Th Fr Sa
  91       #       1  2 14 15 16
  92       #17 18 19 20 21 22 23
  93       #24 25 26 27 28 29 30
  94       my @pat = (
  95         qr/^\s*\S+\s+\d+$/,
  96         qr/^\s*\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s*$/,
  97         qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
  98         qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
  99         qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
 100       );
 101       if (@out == @pat) {
 102         for my $i (0 .. $#out) {
 103           if ($out[$i] !~ $pat[$i]) {
 104             $Cal_Cmd = '';
 105             last;
 106           }
 107         }
 108       }
 109       else {
 110         $Cal_Cmd = '';
 111       }
 112     }
 113   }
 114   $Cal_Cmd;
 115 }
 116
 117 sub _ncal_cmd {
 118   my $self = shift;
 119   if (! defined $Ncal_Cmd) {
 120     $Ncal_Cmd = which('ncal') || '';
 121     if ($Ncal_Cmd) {
 122       my @out = grep { ! /^\s*$/ } map { s/^\s*//; $_ } `$Ncal_Cmd 9 1752`;
 123       #    September 1752
 124       #Mo    18 25
 125       #Tu  1 19 26
 126       #We  2 20 27
 127       #Th 14 21 28
 128       #Fr 15 22 29
 129       #Sa 16 23 30
 130       #Su 17 24
 131       my @pat = (
 132         qr/^\s*\S+\s+\d+$/,
 133         qr/^\s*\S+\s+\d+\s+\d+\s*$/,
 134         qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
 135         qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
 136         qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
 137         qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
 138         qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
 139         qr/^\s*\S+\s+\d+\s+\d+\s*$/,
 140       );
 141       if (@out == @pat) {
 142         for my $i (0 .. $#out) {
 143           if ($out[$i] !~ $pat[$i]) {
 144             $Ncal_Cmd = '';
 145             last;
 146           }
 147         }
 148       }
 149       else {
 150         $Ncal_Cmd = '';
 151       }
 152     }
 153   }
 154   $Ncal_Cmd;
 155 }
 156
 157 sub day_epoch {
 158   # in case our subclasses are lazy
 159   my($self, $day, $month, $year) = @_;
 160   $month ||= $self->month;
 161   $year  ||= $self->year;
 162   Time::Local::timegm(0,0,0,1,$month,$year);
 163 }
 164
 165 sub _skips {
 166   my $self = shift;
 167   @_ ? $self->{skips} = shift : $self->{skips};
 168 }
 169
 170 sub dow1st  { (shift->dow1st_and_lastday)[0] }
 171
 172 sub lastday { (shift->dow1st_and_lastday)[1] }
 173
 174 sub _dmy_now {
 175   my $self = shift;
 176   my $ts = @_ ? shift : time;
 177   my($d, $m, $y) = (localtime($ts))[3,4,5];
 178   ++$m; $y += 1900;
 179   ($d, $m, $y);
 180 }
 181
 182 sub _dom_now {
 183   my $self = shift;
 184   my $ts = @_ ? shift : time;
 185   my($d, $m, $y);
 186   if ($ts =~ /^\d+$/) {
 187     if (length $ts <= 2) {
 188       ($d, $m, $y) = ($ts, $self->month, $self->year);
 189       croak "invalid day of month (1 .. " . $self->lastday . ") '$ts'"
 190         unless $ts >= 1 && $ts <= $self->lastday;
 191     }
 192     else {
 193       ($d, $m, $y) = $self->_dmy_now($ts);
 194     }
 195   }
 196   else {
 197     ($y, $m, $d) = $ts =~ m{^(\d+)/(\d\d)/(\d\d)$};
 198     croak "invalid yyyy/mm/dd date string '$ts'" unless defined $d;
 199   }
 200   my($cy, $cm) = ($self->year, $self->month);
 201   my $first = sprintf("%04d/%02d/%02d", $cy, $cm, 1);
 202   my $last  = sprintf("%04d/%02d/%02d", $cy, $cm, $self->lastday);
 203   my $pivot = sprintf("%04d/%02d/%02d", $y, $m, $d);
 204   return -1 if $pivot gt $last;
 205   return  0 if $pivot lt $first;
 206   $d;
 207 }
 208
 209 sub _summon_date_class {
 210   my $self = shift;
 211   my @tools;
 212   if (my $c = $self->datetool) {
 213     @tools = $c->_name;
 214   }
 215   else {
 216     @tools = qw( timelocal datecalc datetime datemanip ncal cal );
 217   }
 218   my($dc, @fails);
 219   for my $tool (@tools) {
 220     my $method = join('_', '', lc($tool), 'fails');
 221     if (my $f = $self->$method) {
 222       push(@fails, [$tool, $f]);
 223     }
 224     else {
 225       $dc = $self->_toolmap($tool);
 226       last;
 227     }
 228   }
 229   return $dc if $dc;
 230   if (@tools == 1) {
 231     croak "invalid date tool " . join(': ', @{$fails[0]}) if @tools == 1;
 232   }
 233   else {
 234     croak join("\n",
 235       "no valid date tool found:",
 236       map(sprintf("%11s: %s", @$_), @fails),
 237       "\n"
 238     );
 239   }
 240 }
 241
 242 sub _dump_tests {
 243   my $self = shift;
 244   print "Time::Local : ", $self->_timelocal_fails || 1, "\n";
 245   print " Date::Calc : ", $self->_datecalc_fails  || 1, "\n";
 246   print "   DateTime : ", $self->_datetime_fails  || 1, "\n";
 247   print "Date::Manip : ", $self->_datemanip_fails || 1, "\n";
 248   print "       ncal : ", $self->_ncal_fails      || 1, "\n";
 249   print "        cal : ", $self->_cal_fails       || 1, "\n";
 250 }
 251
 252 sub _is_julian {
 253   my $self = shift;
 254   my $y = $self->year;
 255   $y < 1752 || ($y == 1752 && $self->month <= 9);
 256 }
 257
 258 sub _timelocal_fails {
 259   my $self = shift;
 260   return "not installed" unless $self->_timelocal_present;
 261   return "week-of-year numbering unsupported" if $self->weeknum;
 262   my $y = $self->year;
 263   return "only years between 1970 and 2038 supported"
 264     if $y < 1970 || $y >= 2038;
 265   return;
 266 }
 267
 268 sub _ncal_fails {
 269   my $self = shift;
 270   return "command not found" unless $self->_ncal_present;
 271   return "week-of-year numbering not supported prior to 1752/09"
 272     if $self->weeknum && $self->_is_julian;
 273   return;
 274 }
 275
 276 sub _cal_fails  {
 277   my $self = shift;
 278   return "command not found" unless $self->_cal_present;
 279   return "week-of-year numbering not supported" if $self->weeknum;
 280   return;
 281 }
 282
 283 sub _datecalc_fails {
 284   my $self = shift;
 285   return "not installed" unless $self->_datecalc_present;
 286   return "historic mode prior to 1752/09 not supported"
 287     if $self->historic && $self->_is_julian;
 288   return;
 289 }
 290
 291 sub _datetime_fails {
 292   my $self = shift;
 293   return "not installed" unless $self->_datetime_present;
 294   return "historic mode prior to 1752/09 not supported"
 295     if $self->historic && $self->_is_julian;
 296   return;
 297 }
 298
 299 sub _datemanip_fails {
 300   my $self = shift;
 301   return "not installed" unless $self->_datemanip_present;
 302   return "historic mode prior to 1752/09 not supported"
 303     if $self->historic && $self->_is_julian;
 304   return;
 305 }
 306
 307 sub _timelocal_present { eval "require Time::Local"; return !$@ }
 308 sub _datecalc_present  { eval "require Date::Calc";  return !$@ }
 309 sub _datetime_present  { eval "require DateTime";    return !$@ }
 310 sub _datemanip_present { eval "require Date::Manip"; return !$@ }
 311 sub _ncal_present      { shift->_ncal_cmd }
 312 sub _cal_present       { shift->_cal_cmd  };
 313
 314 1;
 315
 316 __END__
 317
 318 =head1 NAME
 319
 320 HTML::CalendarMonth::DateTool - Base class for determining which date package to use for calendrical calculations.
 321
 322 =head1 SYNOPSIS
 323
 324   my $date_tool = HTML::CalendarMonth::DateTool->new(
 325                     year     => $YYYY_year,
 326                     month    => $one_thru_12_month,
 327                     weeknum  => $weeknum_mode,
 328                     historic => $historic_mode,
 329                     datetool => $specific_datetool_if_desired,
 330                   );
 331
 332 =head1 DESCRIPTION
 333
 334 This module attempts to utilize the best date calculation package
 335 available on the current system. For most contemporary dates this
 336 usually ends up being the internal Time::Local package of perl. For more
 337 exotic dates, or when week number of the years are desired, other
 338 methods are attempted including DateTime, Date::Calc, Date::Manip, and
 339 the linux/unix 'ncal' or 'cal' commands. Each of these has a specific
 340 subclass of this module offering the same utility methods needed by
 341 HTML::CalendarMonth.
 342
 343 =head1 METHODS
 344
 345 =over
 346
 347 =item new()
 348
 349 Constructor. Takes the following parameters:
 350
 351 =over
 352
 353 =item year
 354
 355 Year of calendar in question (required). If you are rendering exotic
 356 dates (i.e. dates outside of 1970 to 2038) then something besides
 357 Time::Local will be used for calendrical calculations.
 358
 359 =item month
 360
 361 Month of calendar in question (required). 1 through 12.
 362
 363 =item weeknum
 364
 365 Optional. When specified, will limit class excursions to those that are
 366 currently set up for week of year calculations.
 367
 368 =item historic
 369
 370 Optional. If the the ncal or cal commands are available, use one of them
 371 rather than other available date modules since these utilities
 372 accurately handle some specific historical artifacts such as the
 373 transition from Julian to Gregorian.
 374
 375 =item datetool
 376
 377 Optional. Mostly for debugging, this option can be used to indicate a
 378 specific HTML::CalendarMonth::DateTool subclass for instantiation. The
 379 value can be either the actual utility class, e.g., Date::Calc, or the
 380 name of the CalendarMonth handler leaf class, e.g. DateCalc. Use 'ncal'
 381 or 'cal', respectively, for the wrappers around those commands.
 382
 383 =back
 384
 385 =back
 386
 387 There are number of methods automatically available:
 388
 389 =over
 390
 391 =item month()
 392
 393 =item year()
 394
 395 =item weeknum()
 396
 397 =item historical()
 398
 399 =item datetool()
 400
 401 Accessors for the parameters provided to C<new()> above.
 402
 403 =item dow1st()
 404
 405 Returns the day of week number for the 1st of the C<year> and C<month>
 406 specified during the call to C<new()>. Relies on the presence of
 407 C<dow1st_and_lastday()>. Should be 0..6 starting with Sun.
 408
 409 =item lastday()
 410
 411 Returns the last day of the month for the C<year> and C<month> specified
 412 during the call to C<new()>. Relies on the presence of
 413 C<dow1st_and_lastday()>.
 414
 415 =back
 416
 417 =head1 Overridden methods
 418
 419 Subclasses of this module must provide at least the C<day_epoch()> and
 420 C<dow1st_and_lastday()> methods.
 421
 422 =over
 423
 424 =item dow1st_and_lastday()
 425
 426 Required. Provides a list containing the day of the week of the first
 427 day of the month (0..6 starting with Sun) along with the last day of
 428 the month.
 429
 430 =item day_epoch()
 431
 432 Optional unless interested in epoch values for wacky dates. For a given
 433 day, and optionally C<month> and C<year> if they are different from
 434 those specified in C<new()>, provide the unix epoch in seconds for that
 435 day at midnight.
 436
 437 =back
 438
 439 If the subclass is expected to provide week of year numbers, three more
 440 methods are necessary:
 441
 442 =over
 443
 444 =item dow()
 445
 446 For a given day, and optionally C<month> and C<year> if they are
 447 different from those specified in C<new()>, provide the day of week
 448 number. (1=Sunday, 7=Saturday).
 449
 450 =item add_days($days, $delta, $day, [$month], [$year])
 451
 452 For a given day, and optionally C<month> and C<year> if they are
 453 different from those specified in C<new()>, provide a list of year,
 454 month, and day once C<delta> days have been added.
 455
 456 =item week_of_year($day, [$month], [$year])
 457
 458 For a given day, and optionally C<month> and C<year> if they are
 459 different from those specified in C<new()>, provide a list with the week
 460 number of the year along with the year. (some days of a particular year
 461 can end up belonging to the prior or following years).
 462
 463 =back
 464
 465 =head1 AUTHOR
 466
 467 Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt>
 468
 469 =head1 COPYRIGHT
 470
 471 Copyright (c) 2010 Matthew P. Sisk. All rights reserved. All wrongs
 472 revenged. This program is free software; you can redistribute it and/or
 473 modify it under the same terms as Perl itself.
 474
 475 =head1 SEE ALSO
 476
 477 HTML::CalendarMonth(3), Time::Local(3), DateTime(3), Date::Calc(3),
 478 Date::Manip(3), cal(1)