current/lib/HTML/CalendarMonth/DateTool.pm

   1 package HTML::CalendarMonth::DateTool;
   2 {
   3   $HTML::CalendarMonth::DateTool::VERSION = '1.26';
   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     eval "use $c";
 214     die "invalid date tool $c : $@" if $@;
 215     @tools = $c->_name;
 216   }
 217   else {
 218     @tools = qw( timelocal datecalc datetime datemanip ncal cal );
 219   }
 220   my($dc, @fails);
 221   for my $tool (@tools) {
 222     my $method = join('_', '', lc($tool), 'fails');
 223     if (my $f = $self->$method) {
 224       push(@fails, [$tool, $f]);
 225     }
 226     else {
 227       $dc = $self->_toolmap($tool);
 228       last;
 229     }
 230   }
 231   return $dc if $dc;
 232   if (@tools == 1) {
 233     croak "invalid date tool " . join(': ', @{$fails[0]});
 234   }
 235   else {
 236     croak join("\n",
 237       "no valid date tool found:",
 238       map(sprintf("%11s: %s", @$_), @fails),
 239       "\n"
 240     );
 241   }
 242 }
 243
 244 sub _dump_tests {
 245   my $self = shift;
 246   print "Time::Local : ", $self->_timelocal_fails || 1, "\n";
 247   print " Date::Calc : ", $self->_datecalc_fails  || 1, "\n";
 248   print "   DateTime : ", $self->_datetime_fails  || 1, "\n";
 249   print "Date::Manip : ", $self->_datemanip_fails || 1, "\n";
 250   print "       ncal : ", $self->_ncal_fails      || 1, "\n";
 251   print "        cal : ", $self->_cal_fails       || 1, "\n";
 252 }
 253
 254 sub _is_julian {
 255   my $self = shift;
 256   my $y = $self->year;
 257   $y < 1752 || ($y == 1752 && $self->month <= 9);
 258 }
 259
 260 sub _timelocal_fails {
 261   my $self = shift;
 262   return "not installed" unless $self->_timelocal_present;
 263   return "week-of-year numbering unsupported" if $self->weeknum;
 264   my $y = $self->year;
 265   return "only years between 1970 and 2038 supported"
 266     if $y < 1970 || $y >= 2038;
 267   return;
 268 }
 269
 270 sub _ncal_fails {
 271   my $self = shift;
 272   return "command not found" unless $self->_ncal_present;
 273   return "week-of-year numbering not supported prior to 1752/09"
 274     if $self->weeknum && $self->_is_julian;
 275   return;
 276 }
 277
 278 sub _cal_fails  {
 279   my $self = shift;
 280   return "command not found" unless $self->_cal_present;
 281   return "week-of-year numbering not supported" if $self->weeknum;
 282   return;
 283 }
 284
 285 sub _datecalc_fails {
 286   my $self = shift;
 287   return "not installed" unless $self->_datecalc_present;
 288   return "historic mode prior to 1752/09 not supported"
 289     if $self->historic && $self->_is_julian;
 290   return;
 291 }
 292
 293 sub _datetime_fails {
 294   my $self = shift;
 295   return "not installed" unless $self->_datetime_present;
 296   return "historic mode prior to 1752/09 not supported"
 297     if $self->historic && $self->_is_julian;
 298   return;
 299 }
 300
 301 sub _datemanip_fails {
 302   my $self = shift;
 303   return "not installed" unless $self->_datemanip_present;
 304   return "historic mode prior to 1752/09 not supported"
 305     if $self->historic && $self->_is_julian;
 306   eval { require Date::Manip && Date::Manip::Date_Init() };
 307   return "init failure: $@" if $@;
 308   return;
 309 }
 310
 311 sub _timelocal_present { eval "require Time::Local"; return !$@ }
 312 sub _datecalc_present  { eval "require Date::Calc";  return !$@ }
 313 sub _datetime_present  { eval "require DateTime";    return !$@ }
 314 sub _datemanip_present { eval "require Date::Manip"; return !$@ }
 315 sub _ncal_present      { shift->_ncal_cmd }
 316 sub _cal_present       { shift->_cal_cmd  };
 317
 318
 319 1;
 320
 321 __END__
 322
 323 =head1 NAME
 324
 325 HTML::CalendarMonth::DateTool - Base class for determining which date package to use for calendrical calculations.
 326
 327 =head1 SYNOPSIS
 328
 329   my $date_tool = HTML::CalendarMonth::DateTool->new(
 330                     year     => $YYYY_year,
 331                     month    => $one_thru_12_month,
 332                     weeknum  => $weeknum_mode,
 333                     historic => $historic_mode,
 334                     datetool => $specific_datetool_if_desired,
 335                   );
 336
 337 =head1 DESCRIPTION
 338
 339 This module attempts to utilize the best date calculation package
 340 available on the current system. For most contemporary dates this
 341 usually ends up being the internal Time::Local package of perl. For more
 342 exotic dates, or when week number of the years are desired, other
 343 methods are attempted including DateTime, Date::Calc, Date::Manip, and
 344 the linux/unix 'ncal' or 'cal' commands. Each of these has a specific
 345 subclass of this module offering the same utility methods needed by
 346 HTML::CalendarMonth.
 347
 348 =head1 METHODS
 349
 350 =over
 351
 352 =item new()
 353
 354 Constructor. Takes the following parameters:
 355
 356 =over
 357
 358 =item year
 359
 360 Year of calendar in question (required). If you are rendering exotic
 361 dates (i.e. dates outside of 1970 to 2038) then something besides
 362 Time::Local will be used for calendrical calculations.
 363
 364 =item month
 365
 366 Month of calendar in question (required). 1 through 12.
 367
 368 =item weeknum
 369
 370 Optional. When specified, will limit class excursions to those that are
 371 currently set up for week of year calculations.
 372
 373 =item historic
 374
 375 Optional. If the the ncal or cal commands are available, use one of them
 376 rather than other available date modules since these utilities
 377 accurately handle some specific historical artifacts such as the
 378 transition from Julian to Gregorian.
 379
 380 =item datetool
 381
 382 Optional. Mostly for debugging, this option can be used to indicate a
 383 specific HTML::CalendarMonth::DateTool subclass for instantiation. The
 384 value can be either the actual utility class, e.g., Date::Calc, or the
 385 name of the CalendarMonth handler leaf class, e.g. DateCalc. Use 'ncal'
 386 or 'cal', respectively, for the wrappers around those commands.
 387
 388 =back
 389
 390 =back
 391
 392 There are number of methods automatically available:
 393
 394 =over
 395
 396 =item month()
 397
 398 =item year()
 399
 400 =item weeknum()
 401
 402 =item historical()
 403
 404 =item datetool()
 405
 406 Accessors for the parameters provided to C<new()> above.
 407
 408 =item dow1st()
 409
 410 Returns the day of week number for the 1st of the C<year> and C<month>
 411 specified during the call to C<new()>. Relies on the presence of
 412 C<dow1st_and_lastday()>. Should be 0..6 starting with Sun.
 413
 414 =item lastday()
 415
 416 Returns the last day of the month for the C<year> and C<month> specified
 417 during the call to C<new()>. Relies on the presence of
 418 C<dow1st_and_lastday()>.
 419
 420 =back
 421
 422 =head1 Overridden methods
 423
 424 Subclasses of this module must provide at least the C<day_epoch()> and
 425 C<dow1st_and_lastday()> methods.
 426
 427 =over
 428
 429 =item dow1st_and_lastday()
 430
 431 Required. Provides a list containing the day of the week of the first
 432 day of the month (0..6 starting with Sun) along with the last day of
 433 the month.
 434
 435 =item day_epoch()
 436
 437 Optional unless interested in epoch values for wacky dates. For a given
 438 day, and optionally C<month> and C<year> if they are different from
 439 those specified in C<new()>, provide the unix epoch in seconds for that
 440 day at midnight.
 441
 442 =back
 443
 444 If the subclass is expected to provide week of year numbers, three more
 445 methods are necessary:
 446
 447 =over
 448
 449 =item dow()
 450
 451 For a given day, and optionally C<month> and C<year> if they are
 452 different from those specified in C<new()>, provide the day of week
 453 number. (1=Sunday, 7=Saturday).
 454
 455 =item add_days($days, $delta, $day, [$month], [$year])
 456
 457 For a given day, and optionally C<month> and C<year> if they are
 458 different from those specified in C<new()>, provide a list of year,
 459 month, and day once C<delta> days have been added.
 460
 461 =item week_of_year($day, [$month], [$year])
 462
 463 For a given day, and optionally C<month> and C<year> if they are
 464 different from those specified in C<new()>, provide a list with the week
 465 number of the year along with the year. (some days of a particular year
 466 can end up belonging to the prior or following years).
 467
 468 =back
 469
 470 =head1 AUTHOR
 471
 472 Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt>
 473
 474 =head1 COPYRIGHT
 475
 476 Copyright (c) 2010 Matthew P. Sisk. All rights reserved. All wrongs
 477 revenged. This program is free software; you can redistribute it and/or
 478 modify it under the same terms as Perl itself.
 479
 480 =head1 SEE ALSO
 481
 482 HTML::CalendarMonth(3), Time::Local(3), DateTime(3), Date::Calc(3),
 483 Date::Manip(3), cal(1)