source: trunk/Cocoa/Pester/Source/Manip.pm @ 618

Last change on this file since 618 was 618, checked in by Nicholas Riley, 10 years ago

Update to Date::Manip 5.55 (with a fix to require Perl 5.8 rather than 5.10 in DM5abbrevs.pm).

File size: 229.8 KB
Line 
1package Date::Manip;
2# Copyright (c) 1995-2010 Sullivan Beck.  All rights reserved.
3# This program is free software; you can redistribute it and/or modify it
4# under the same terms as Perl itself.
5
6###########################################################################
7###########################################################################
8
9use warnings;
10
11use vars qw($OS %Lang %Holiday %Events %Curr %Cnf %Zone $VERSION @ISA @EXPORT);
12
13# Determine the type of OS...
14$OS="Unix";
15$OS="Windows"  if ((defined $^O and
16                    $^O =~ /MSWin32/i ||
17                    $^O =~ /Windows_95/i ||
18                    $^O =~ /Windows_NT/i) ||
19                   (defined $ENV{OS} and
20                    $ENV{OS} =~ /MSWin32/i ||
21                    $ENV{OS} =~ /Windows_95/i ||
22                    $ENV{OS} =~ /Windows_NT/i));
23$OS="Unix"     if (defined $^O and
24                   $^O =~ /cygwin/i);
25$OS="Netware"  if (defined $^O and
26                   $^O =~ /NetWare/i);
27$OS="Mac"      if ((defined $^O and
28                    $^O =~ /MacOS/i) ||
29                   (defined $ENV{OS} and
30                    $ENV{OS} =~ /MacOS/i));
31$OS="MPE"      if (defined $^O and
32                   $^O =~ /MPE/i);
33$OS="OS2"      if (defined $^O and
34                   $^O =~ /os2/i);
35$OS="VMS"      if (defined $^O and
36                   $^O =~ /VMS/i);
37$OS="AIX"      if (defined $^O and
38                   $^O =~ /aix/i);
39
40# Determine if we're doing taint checking
41#if ($] < 5.0080) {
42  $Date::Manip::NoTaint = eval { local $^W=0; eval("#" . substr($^X, 0, 0)); 1 };
43#} else {
44#  $Date::Manip::NoTaint = (${^TAINT} == 0 ? 1 : 0);
45#}
46
47###########################################################################
48# CUSTOMIZATION
49###########################################################################
50#
51# See the section of the POD documentation section CUSTOMIZING DATE::MANIP
52# below for a complete description of each of these variables.
53
54
55# Location of a the global config file.  Tilde (~) expansions are allowed.
56# This should be set in Date_Init arguments.
57$Cnf{"GlobalCnf"}="";
58$Cnf{"IgnoreGlobalCnf"}="";
59
60# Name of a personal config file and the path to search for it.  Tilde (~)
61# expansions are allowed.  This should be set in Date_Init arguments or in
62# the global config file.
63
64@Date::Manip::DatePath=();
65if ($OS eq "Windows") {
66  $Cnf{"PathSep"}         = ";";
67  $Cnf{"PersonalCnf"}     = "Manip.cnf";
68  $Cnf{"PersonalCnfPath"} = ".";
69
70} elsif ($OS eq "Netware") {
71  $Cnf{"PathSep"}         = ";";
72  $Cnf{"PersonalCnf"}     = "Manip.cnf";
73  $Cnf{"PersonalCnfPath"} = ".";
74
75} elsif ($OS eq "MPE") {
76  $Cnf{"PathSep"}         = ":";
77  $Cnf{"PersonalCnf"}     = "Manip.cnf";
78  $Cnf{"PersonalCnfPath"} = ".";
79
80} elsif ($OS eq "OS2") {
81  $Cnf{"PathSep"}         = ":";
82  $Cnf{"PersonalCnf"}     = "Manip.cnf";
83  $Cnf{"PersonalCnfPath"} = ".";
84
85} elsif ($OS eq "Mac") {
86  $Cnf{"PathSep"}         = ":";
87  $Cnf{"PersonalCnf"}     = "Manip.cnf";
88  $Cnf{"PersonalCnfPath"} = ".";
89
90} elsif ($OS eq "VMS") {
91  # VMS doesn't like files starting with "."
92  $Cnf{"PathSep"}         = ",";
93  $Cnf{"PersonalCnf"}     = "Manip.cnf";
94  $Cnf{"PersonalCnfPath"} = "/sys\$login";
95
96} else {
97  # Unix
98  $Cnf{"PathSep"}         = ":";
99  $Cnf{"PersonalCnf"}     = ".DateManip.cnf";
100  $Cnf{"PersonalCnfPath"} = ".:~";
101  @Date::Manip::DatePath=qw(/bin /usr/bin /usr/local/bin);
102}
103
104### Date::Manip variables set in the global or personal config file
105
106# Which language to use when parsing dates.
107$Cnf{"Language"}="English";
108
109# 12/10 = Dec 10 (US) or Oct 12 (anything else)
110$Cnf{"DateFormat"}="US";
111
112# Local timezone
113$Cnf{"TZ"}="";
114
115# Timezone to work in (""=local, "IGNORE", or a timezone)
116$Cnf{"ConvTZ"}="";
117
118# Date::Manip internal format (0=YYYYMMDDHH:MN:SS, 1=YYYYHHMMDDHHMNSS)
119$Cnf{"Internal"}=0;
120
121# First day of the week (1=monday, 7=sunday).  ISO 8601 says monday.
122$Cnf{"FirstDay"}=1;
123
124# First and last day of the work week  (1=monday, 7=sunday)
125$Cnf{"WorkWeekBeg"}=1;
126$Cnf{"WorkWeekEnd"}=5;
127
128# If non-nil, a work day is treated as 24 hours long (WorkDayBeg/WorkDayEnd
129# ignored)
130$Cnf{"WorkDay24Hr"}=0;
131
132# Start and end time of the work day (any time format allowed, seconds
133# ignored)
134$Cnf{"WorkDayBeg"}="08:00";
135$Cnf{"WorkDayEnd"}="17:00";
136
137# If "today" is a holiday, we look either to "tomorrow" or "yesterday" for
138# the nearest business day.  By default, we'll always look "tomorrow"
139# first.
140$Cnf{"TomorrowFirst"}=1;
141
142# Erase the old holidays
143$Cnf{"EraseHolidays"}="";
144
145# Set this to non-zero to be produce completely backwards compatible deltas
146$Cnf{"DeltaSigns"}=0;
147
148# If this is 0, use the ISO 8601 standard that Jan 4 is in week 1.  If 1,
149# make week 1 contain Jan 1.
150$Cnf{"Jan1Week1"}=0;
151
152# 2 digit years fall into the 100 year period given by [ CURR-N,
153# CURR+(99-N) ] where N is 0-99.  Default behavior is 89, but other useful
154# numbers might be 0 (forced to be this year or later) and 99 (forced to be
155# this year or earlier).  It can also be set to "c" (current century) or
156# "cNN" (i.e.  c18 forces the year to bet 1800-1899).  Also accepts the
157# form cNNNN to give the 100 year period NNNN to NNNN+99.
158$Cnf{"YYtoYYYY"}=89;
159
160# Set this to 1 if you want a long-running script to always update the
161# timezone.  This will slow Date::Manip down.  Read the POD documentation.
162$Cnf{"UpdateCurrTZ"}=0;
163
164# Use an international character set.
165$Cnf{"IntCharSet"}=0;
166
167# Use this to force the current date to be set to this:
168$Cnf{"ForceDate"}="";
169
170# Use this to make "today" mean "today at midnight".
171$Cnf{"TodayIsMidnight"}=0;
172
173###########################################################################
174
175require 5.000;
176require Exporter;
177@ISA = qw(Exporter);
178@EXPORT = qw(
179   DateManipVersion
180   Date_Init
181   ParseDateString
182   ParseDate
183   ParseRecur
184   Date_Cmp
185   DateCalc
186   ParseDateDelta
187   UnixDate
188   Delta_Format
189   Date_GetPrev
190   Date_GetNext
191   Date_SetTime
192   Date_SetDateField
193   Date_IsHoliday
194   Events_List
195
196   Date_DaysInMonth
197   Date_DayOfWeek
198   Date_SecsSince1970
199   Date_SecsSince1970GMT
200   Date_DaysSince1BC
201   Date_DayOfYear
202   Date_DaysInYear
203   Date_WeekOfYear
204   Date_LeapYear
205   Date_DaySuffix
206   Date_ConvTZ
207   Date_TimeZone
208   Date_IsWorkDay
209   Date_NextWorkDay
210   Date_PrevWorkDay
211   Date_NearestWorkDay
212   Date_NthDayOfYear
213);
214use strict;
215use integer;
216use Carp;
217
218use IO::File;
219
220use vars qw($Abbrevs);
221use Date::Manip::DM5abbrevs;
222
223$VERSION="5.55";
224
225########################################################################
226########################################################################
227
228$Curr{"InitLang"}      = 1;     # Whether a language is being init'ed
229$Curr{"InitDone"}      = 0;     # Whether Init_Date has been called
230$Curr{"InitFilesRead"} = 0;
231$Curr{"ResetWorkDay"}  = 1;
232$Curr{"Debug"}         = "";
233$Curr{"DebugVal"}      = "";
234
235$Holiday{"year"}       = 0;
236$Holiday{"dates"}      = {};
237$Holiday{"desc"}       = {};
238
239$Events{"raw"}         = [];
240$Events{"parsed"}      = 0;
241$Events{"dates"}       = [];
242$Events{"recur"}       = [];
243
244########################################################################
245########################################################################
246# THESE ARE THE MAIN ROUTINES
247########################################################################
248########################################################################
249
250# Get rid of a problem with old versions of perl
251no strict "vars";
252# This sorts from longest to shortest element
253sub _sortByLength {
254  return (length $b <=> length $a);
255}
256use strict "vars";
257
258sub DateManipVersion {
259  print "DEBUG: DateManipVersion\n"  if ($Curr{"Debug"} =~ /trace/);
260  return $VERSION;
261}
262
263sub Date_Init {
264  print "DEBUG: Date_Init\n"  if ($Curr{"Debug"} =~ /trace/);
265  $Curr{"Debug"}="";
266
267  my(@args)=@_;
268  $Curr{"InitDone"}=1;
269  local($_)=();
270  my($internal,$firstday)=();
271  my($var,$val,$file,@tmp)=();
272
273  # InitFilesRead = 0    : no conf files read yet
274  #                 1    : global read, no personal read
275  #                 2    : personal read
276
277  $Cnf{"EraseHolidays"}=0;
278  foreach (@args) {
279    s/\s*$//;
280    s/^\s*//;
281    /^(\S+) \s* = \s* (.*)$/x;
282    ($var,$val)=($1,$2);
283    if ($var =~ /^GlobalCnf$/i) {
284      $Cnf{"GlobalCnf"}=$val;
285      if ($val) {
286        $Curr{"InitFilesRead"}=0;
287        EraseHolidays();
288      }
289    } elsif ($var =~ /^PathSep$/i) {
290      $Cnf{"PathSep"}=$val;
291    } elsif ($var =~ /^PersonalCnf$/i) {
292      $Cnf{"PersonalCnf"}=$val;
293      $Curr{"InitFilesRead"}=1  if ($Curr{"InitFilesRead"}==2);
294    } elsif ($var =~ /^PersonalCnfPath$/i) {
295      $Cnf{"PersonalCnfPath"}=$val;
296      $Curr{"InitFilesRead"}=1  if ($Curr{"InitFilesRead"}==2);
297    } elsif ($var =~ /^IgnoreGlobalCnf$/i) {
298      $Curr{"InitFilesRead"}=1  if ($Curr{"InitFilesRead"}==0);
299      $Cnf{"IgnoreGlobalCnf"}=1;
300    } elsif ($var =~ /^EraseHolidays$/i) {
301      EraseHolidays();
302    } else {
303      push(@tmp,$_);
304    }
305  }
306  @args=@tmp;
307
308  # Read global config file
309  if ($Curr{"InitFilesRead"}<1  &&  ! $Cnf{"IgnoreGlobalCnf"}) {
310    $Curr{"InitFilesRead"}=1;
311
312    if ($Cnf{"GlobalCnf"}) {
313      $file=_ExpandTilde($Cnf{"GlobalCnf"});
314      _Date_InitFile($file)  if ($file);
315    }
316  }
317
318  # Read personal config file
319  if ($Curr{"InitFilesRead"}<2) {
320    $Curr{"InitFilesRead"}=2;
321
322    if ($Cnf{"PersonalCnf"}  and  $Cnf{"PersonalCnfPath"}) {
323      $file=_SearchPath($Cnf{"PersonalCnf"},$Cnf{"PersonalCnfPath"},"r");
324      _Date_InitFile($file)  if ($file);
325    }
326  }
327
328  foreach (@args) {
329    s/\s*$//;
330    s/^\s*//;
331    /^(\S+) \s* = \s* (.*)$/x;
332    ($var,$val)=($1,$2);
333    $val=""  if (! defined $val);
334    _Date_SetConfigVariable($var,$val);
335  }
336
337  confess "ERROR: Unknown FirstDay in Date::Manip.\n"
338    if (! _IsInt($Cnf{"FirstDay"},1,7));
339  confess "ERROR: Unknown WorkWeekBeg in Date::Manip.\n"
340    if (! _IsInt($Cnf{"WorkWeekBeg"},1,7));
341  confess "ERROR: Unknown WorkWeekEnd in Date::Manip.\n"
342    if (! _IsInt($Cnf{"WorkWeekEnd"},1,7));
343  confess "ERROR: Invalid WorkWeek in Date::Manip.\n"
344    if ($Cnf{"WorkWeekEnd"} <= $Cnf{"WorkWeekBeg"});
345
346  my(%lang,
347     $tmp,%tmp,$tmp2,@tmp2,
348     $i,$j,@tmp3,
349     @zones)=();
350
351  my($L)=$Cnf{"Language"};
352
353  if ($Curr{"InitLang"}) {
354    $Curr{"InitLang"}=0;
355
356    if ($L eq "English") {
357      _Date_Init_English(\%lang);
358
359    } elsif ($L eq "French") {
360      _Date_Init_French(\%lang);
361
362    } elsif ($L eq "Swedish") {
363      _Date_Init_Swedish(\%lang);
364
365    } elsif ($L eq "German") {
366      _Date_Init_German(\%lang);
367
368    } elsif ($L eq "Polish") {
369      _Date_Init_Polish(\%lang);
370
371    } elsif ($L eq "Dutch"  ||
372             $L eq "Nederlands") {
373      _Date_Init_Dutch(\%lang);
374
375    } elsif ($L eq "Spanish") {
376      _Date_Init_Spanish(\%lang);
377
378    } elsif ($L eq "Portuguese") {
379      _Date_Init_Portuguese(\%lang);
380
381    } elsif ($L eq "Romanian") {
382      _Date_Init_Romanian(\%lang);
383
384    } elsif ($L eq "Italian") {
385      _Date_Init_Italian(\%lang);
386
387    } elsif ($L eq "Russian") {
388      _Date_Init_Russian(\%lang);
389
390    } elsif ($L eq "Turkish") {
391      _Date_Init_Turkish(\%lang);
392
393    } elsif ($L eq "Danish") {
394      _Date_Init_Danish(\%lang);
395
396    } elsif ($L eq "Catalan") {
397      _Date_Init_Catalan(\%lang);
398
399    } else {
400      confess "ERROR: Unknown language in Date::Manip.\n";
401    }
402
403    #  variables for months
404    #   Month   = "(jan|january|feb|february ... )"
405    #   MonL    = [ "Jan","Feb",... ]
406    #   MonthL  = [ "January","February", ... ]
407    #   MonthH  = { "january"=>1, "jan"=>1, ... }
408
409    $Lang{$L}{"MonthH"}={};
410    $Lang{$L}{"MonthL"}=[];
411    $Lang{$L}{"MonL"}=[];
412    _Date_InitLists([$lang{"month_name"},
413                     $lang{"month_abb"}],
414                    \$Lang{$L}{"Month"},"lc,sort,back",
415                    [$Lang{$L}{"MonthL"},
416                     $Lang{$L}{"MonL"}],
417                    [$Lang{$L}{"MonthH"},1]);
418
419    #  variables for day of week
420    #   Week   = "(mon|monday|tue|tuesday ... )"
421    #   WL     = [ "M","T",... ]
422    #   WkL    = [ "Mon","Tue",... ]
423    #   WeekL  = [ "Monday","Tudesday",... ]
424    #   WeekH  = { "monday"=>1,"mon"=>1,"m"=>1,... }
425
426    $Lang{$L}{"WeekH"}={};
427    $Lang{$L}{"WeekL"}=[];
428    $Lang{$L}{"WkL"}=[];
429    $Lang{$L}{"WL"}=[];
430    _Date_InitLists([$lang{"day_name"},
431                     $lang{"day_abb"}],
432                    \$Lang{$L}{"Week"},"lc,sort,back",
433                    [$Lang{$L}{"WeekL"},
434                     $Lang{$L}{"WkL"}],
435                    [$Lang{$L}{"WeekH"},1]);
436    _Date_InitLists([$lang{"day_char"}],
437                    "","lc",
438                    [$Lang{$L}{"WL"}],
439                    [\%tmp,1]);
440    %{ $Lang{$L}{"WeekH"} } =
441      (%{ $Lang{$L}{"WeekH"} },%tmp);
442
443    #  variables for last
444    #   Last      = "(last)"
445    #   LastL     = [ "last" ]
446    #   Each      = "(each)"
447    #   EachL     = [ "each" ]
448    #  variables for day of month
449    #   DoM       = "(1st|first ... 31st)"
450    #   DoML      = [ "1st","2nd",... "31st" ]
451    #   DoMH      = { "1st"=>1,"first"=>1, ... "31st"=>31 }
452    #  variables for week of month
453    #   WoM       = "(1st|first| ... 5th|last)"
454    #   WoMH      = { "1st"=>1, ... "5th"=>5,"last"=>-1 }
455
456    $Lang{$L}{"LastL"}=$lang{"last"};
457    _Date_InitStrings($lang{"last"},
458                      \$Lang{$L}{"Last"},"lc,sort");
459
460    $Lang{$L}{"EachL"}=$lang{"each"};
461    _Date_InitStrings($lang{"each"},
462                      \$Lang{$L}{"Each"},"lc,sort");
463
464    $Lang{$L}{"DoMH"}={};
465    $Lang{$L}{"DoML"}=[];
466    _Date_InitLists([$lang{"num_suff"},
467                     $lang{"num_word"}],
468                    \$Lang{$L}{"DoM"},"lc,sort,back,escape",
469                    [$Lang{$L}{"DoML"},
470                     \@tmp],
471                    [$Lang{$L}{"DoMH"},1]);
472
473    @tmp=();
474    foreach $tmp (keys %{ $Lang{$L}{"DoMH"} }) {
475      $tmp2=$Lang{$L}{"DoMH"}{$tmp};
476      if ($tmp2<6) {
477        $Lang{$L}{"WoMH"}{$tmp} = $tmp2;
478        push(@tmp,$tmp);
479      }
480    }
481    foreach $tmp (@{ $Lang{$L}{"LastL"} }) {
482      $Lang{$L}{"WoMH"}{$tmp} = -1;
483      push(@tmp,$tmp);
484    }
485    _Date_InitStrings(\@tmp,\$Lang{$L}{"WoM"},
486                      "lc,sort,back,escape");
487
488    #  variables for AM or PM
489    #   AM      = "(am)"
490    #   PM      = "(pm)"
491    #   AmPm    = "(am|pm)"
492    #   AMstr   = "AM"
493    #   PMstr   = "PM"
494
495    _Date_InitStrings($lang{"am"},\$Lang{$L}{"AM"},"lc,sort,escape");
496    _Date_InitStrings($lang{"pm"},\$Lang{$L}{"PM"},"lc,sort,escape");
497    _Date_InitStrings([ @{$lang{"am"}},@{$lang{"pm"}} ],\$Lang{$L}{"AmPm"},
498                      "lc,back,sort,escape");
499    $Lang{$L}{"AMstr"}=$lang{"am"}[0];
500    $Lang{$L}{"PMstr"}=$lang{"pm"}[0];
501
502    #  variables for expressions used in parsing deltas
503    #    Yabb   = "(?:y|yr|year|years)"
504    #    Mabb   = similar for months
505    #    Wabb   = similar for weeks
506    #    Dabb   = similar for days
507    #    Habb   = similar for hours
508    #    MNabb  = similar for minutes
509    #    Sabb   = similar for seconds
510    #    Repl   = { "abb"=>"replacement" }
511    # Whenever an abbreviation could potentially refer to two different
512    # strings (M standing for Minutes or Months), the abbreviation must
513    # be listed in Repl instead of in the appropriate Xabb values.  This
514    # only applies to abbreviations which are substrings of other values
515    # (so there is no confusion between Mn and Month).
516
517    _Date_InitStrings($lang{"years"}  ,\$Lang{$L}{"Yabb"}, "lc,sort");
518    _Date_InitStrings($lang{"months"} ,\$Lang{$L}{"Mabb"}, "lc,sort");
519    _Date_InitStrings($lang{"weeks"}  ,\$Lang{$L}{"Wabb"}, "lc,sort");
520    _Date_InitStrings($lang{"days"}   ,\$Lang{$L}{"Dabb"}, "lc,sort");
521    _Date_InitStrings($lang{"hours"}  ,\$Lang{$L}{"Habb"}, "lc,sort");
522    _Date_InitStrings($lang{"minutes"},\$Lang{$L}{"MNabb"},"lc,sort");
523    _Date_InitStrings($lang{"seconds"},\$Lang{$L}{"Sabb"}, "lc,sort");
524    $Lang{$L}{"Repl"}={};
525    _Date_InitHash($lang{"replace"},undef,"lc",$Lang{$L}{"Repl"});
526
527    #  variables for special dates that are offsets from now
528    #    Now      = "now"
529    #    Today    = "today"
530    #    Offset   = "(yesterday|tomorrow)"
531    #    OffsetH  = { "yesterday"=>"-0:0:0:1:0:0:0",... ]
532    #    Times    = "(noon|midnight)"
533    #    TimesH   = { "noon"=>"12:00:00","midnight"=>"00:00:00" }
534    #    SepHM    = hour/minute separator
535    #    SepMS    = minute/second separator
536    #    SepSS    = second/fraction separator
537
538    $Lang{$L}{"TimesH"}={};
539    _Date_InitHash($lang{"times"},
540                   \$Lang{$L}{"Times"},"lc,sort,back",
541                   $Lang{$L}{"TimesH"});
542    _Date_InitStrings($lang{"now"},\$Lang{$L}{"Now"},"lc,sort");
543    _Date_InitStrings($lang{"today"},\$Lang{$L}{"Today"},"lc,sort");
544    $Lang{$L}{"OffsetH"}={};
545    _Date_InitHash($lang{"offset"},
546                   \$Lang{$L}{"Offset"},"lc,sort,back",
547                   $Lang{$L}{"OffsetH"});
548    $Lang{$L}{"SepHM"}=$lang{"sephm"};
549    $Lang{$L}{"SepMS"}=$lang{"sepms"};
550    $Lang{$L}{"SepSS"}=$lang{"sepss"};
551
552    #  variables for time zones
553    #    zones      = regular expression with all zone names (EST)
554    #    n2o        = a hash of all parsable zone names with their offsets
555    #    tzones     = reguar expression with all tzdata timezones (US/Eastern)
556    #    tz2z       = hash of all tzdata timezones to full timezone (EST#EDT)
557
558    $Zone{"n2o"} = {};
559    ($Zone{"zones"},%{ $Zone{"n2o"} })=
560      _Date_Regexp($Abbrevs,"sort,lc,under,back",
561                   "keys");
562
563    $tmp=
564      "US/Pacific  PST8PDT ".
565      "US/Mountain MST7MDT ".
566      "US/Central  CST6CDT ".
567      "US/Eastern  EST5EDT ".
568      "Canada/Pacific  PST8PDT ".
569      "Canada/Mountain MST7MDT ".
570      "Canada/Central  CST6CDT ".
571      "Canada/Eastern  EST5EDT";
572
573    $Zone{"tz2z"} = {};
574    ($Zone{"tzones"},%{ $Zone{"tz2z"} })=
575      _Date_Regexp($tmp,"lc,under,back","keys");
576    $Cnf{"TZ"}=Date_TimeZone();
577
578    #  misc. variables
579    #    At     = "(?:at)"
580    #    Of     = "(?:in|of)"
581    #    On     = "(?:on)"
582    #    Future = "(?:in)"
583    #    Later  = "(?:later)"
584    #    Past   = "(?:ago)"
585    #    Next   = "(?:next)"
586    #    Prev   = "(?:last|previous)"
587
588    _Date_InitStrings($lang{"at"},    \$Lang{$L}{"At"},     "lc,sort");
589    _Date_InitStrings($lang{"on"},    \$Lang{$L}{"On"},     "lc,sort");
590    _Date_InitStrings($lang{"future"},\$Lang{$L}{"Future"}, "lc,sort");
591    _Date_InitStrings($lang{"later"}, \$Lang{$L}{"Later"},  "lc,sort");
592    _Date_InitStrings($lang{"past"},  \$Lang{$L}{"Past"},   "lc,sort");
593    _Date_InitStrings($lang{"next"},  \$Lang{$L}{"Next"},   "lc,sort");
594    _Date_InitStrings($lang{"prev"},  \$Lang{$L}{"Prev"},   "lc,sort");
595    _Date_InitStrings($lang{"of"},    \$Lang{$L}{"Of"},     "lc,sort");
596
597    #  calc mode variables
598    #    Approx   = "(?:approximately)"
599    #    Exact    = "(?:exactly)"
600    #    Business = "(?:business)"
601
602    _Date_InitStrings($lang{"exact"},   \$Lang{$L}{"Exact"},   "lc,sort");
603    _Date_InitStrings($lang{"approx"},  \$Lang{$L}{"Approx"},  "lc,sort");
604    _Date_InitStrings($lang{"business"},\$Lang{$L}{"Business"},"lc,sort");
605
606    ############### END OF LANGUAGE INITIALIZATION
607  }
608
609  if ($Curr{"ResetWorkDay"}) {
610    my($h1,$m1,$h2,$m2)=();
611    if ($Cnf{"WorkDay24Hr"}) {
612      ($Curr{"WDBh"},$Curr{"WDBm"})=(0,0);
613      ($Curr{"WDEh"},$Curr{"WDEm"})=(24,0);
614      $Curr{"WDlen"}=24*60;
615      $Cnf{"WorkDayBeg"}="00:00";
616      $Cnf{"WorkDayEnd"}="23:59";
617
618    } else {
619      confess "ERROR: Invalid WorkDayBeg in Date::Manip.\n"
620        if (! (($h1,$m1)=_CheckTime($Cnf{"WorkDayBeg"})));
621      $Cnf{"WorkDayBeg"}="$h1:$m1";
622      confess "ERROR: Invalid WorkDayEnd in Date::Manip.\n"
623        if (! (($h2,$m2)=_CheckTime($Cnf{"WorkDayEnd"})));
624      $Cnf{"WorkDayEnd"}="$h2:$m2";
625
626      ($Curr{"WDBh"},$Curr{"WDBm"})=($h1,$m1);
627      ($Curr{"WDEh"},$Curr{"WDEm"})=($h2,$m2);
628
629      # Work day length = h1:m1  or  0:len (len minutes)
630      $h1=$h2-$h1;
631      $m1=$m2-$m1;
632      if ($m1<0) {
633        $h1--;
634        $m1+=60;
635      }
636      $Curr{"WDlen"}=$h1*60+$m1;
637    }
638    $Curr{"ResetWorkDay"}=0;
639  }
640
641  # current time
642  my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst,$ampm,$wk)=();
643  if ($Cnf{"ForceDate"}=~
644      /^(\d{4})-(\d{2})-(\d{2})-(\d{2}):(\d{2}):(\d{2})$/) {
645       ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6);
646  } else {
647    ($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst)=localtime(time);
648    $y+=1900;
649    $m++;
650  }
651  _Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk);
652  $Curr{"Y"}=$y;
653  $Curr{"M"}=$m;
654  $Curr{"D"}=$d;
655  $Curr{"H"}=$h;
656  $Curr{"Mn"}=$mn;
657  $Curr{"S"}=$s;
658  $Curr{"AmPm"}=$ampm;
659  $Curr{"Now"}=_Date_Join($y,$m,$d,$h,$mn,$s);
660  if ($Cnf{"TodayIsMidnight"}) {
661    $Curr{"Today"}=_Date_Join($y,$m,$d,0,0,0);
662  } else {
663    $Curr{"Today"}=$Curr{"Now"};
664  }
665
666  $Curr{"Debug"}=$Curr{"DebugVal"};
667
668  # If we're in array context, let's return a list of config variables
669  # that could be passed to Date_Init to get the same state as we're
670  # currently in.
671  if (wantarray) {
672    # Some special variables that have to be in a specific order
673    my(@special)=qw(IgnoreGlobalCnf GlobalCnf PersonalCnf PersonalCnfPath);
674    my(%tmp)=map { $_,1 } @special;
675    my(@tmp,$key,$val);
676    foreach $key (@special) {
677      $val=$Cnf{$key};
678      push(@tmp,"$key=$val");
679    }
680    foreach $key (keys %Cnf) {
681      next  if (exists $tmp{$key});
682      $val=$Cnf{$key};
683      push(@tmp,"$key=$val");
684    }
685    return @tmp;
686  }
687  return ();
688}
689
690sub ParseDateString {
691  print "DEBUG: ParseDateString\n"  if ($Curr{"Debug"} =~ /trace/);
692  local($_)=@_;
693  return ""  if (! $_);
694
695  my($y,$m,$d,$h,$mn,$s,$i,$wofm,$dofw,$wk,$tmp,$z,$num,$err,$iso,$ampm)=();
696  my($date,$z2,$delta,$from,$falsefrom,$to,$which,$midnight)=();
697
698  # We only need to reinitialize if we have to determine what NOW is.
699  Date_Init()  if (! $Curr{"InitDone"}  or  $Cnf{"UpdateCurrTZ"});
700
701  my($L)=$Cnf{"Language"};
702  my($type)=$Cnf{"DateFormat"};
703
704  # Mode is set in DateCalc.  ParseDate only overrides it if the string
705  # contains a mode.
706  if      ($Lang{$L}{"Exact"}  &&
707           s/$Lang{$L}{"Exact"}//) {
708    $Curr{"Mode"}=0;
709  } elsif ($Lang{$L}{"Approx"}  &&
710           s/$Lang{$L}{"Approx"}//) {
711    $Curr{"Mode"}=1;
712  } elsif ($Lang{$L}{"Business"}  &&
713           s/$Lang{$L}{"Business"}//) {
714    $Curr{"Mode"}=2;
715  } elsif (! exists $Curr{"Mode"}) {
716    $Curr{"Mode"}=0;
717  }
718
719  # Unfortunately, some deltas can be parsed as dates.  An example is
720  #    1 second  ==  1 2nd  ==  1 2
721  # But, some dates can be parsed as deltas.  The most important being:
722  #    1998010101:00:00
723  #
724  # We'll check to see if a "date" can be parsed as a delta.  If so, we'll
725  # assume that it is a delta (since they are much simpler, it is much
726  # less likely that we'll mistake a delta for a date than vice versa)
727  # unless it is an ISO-8601 date.
728  #
729  # This is important because we are using DateCalc to test whether a
730  # string is a date or a delta.  Dates are tested first, so we need to
731  # be able to pass a delta into this routine and have it correctly NOT
732  # interpreted as a date.
733  #
734  # We will insist that the string contain something other than digits and
735  # colons so that the following will get correctly interpreted as a date
736  # rather than a delta:
737  #     12:30
738  #     19980101
739
740  $delta="";
741  $delta=ParseDateDelta($_)  if (/[^:0-9]/);
742
743  # Put parse in a simple loop for an easy exit.
744 PARSE: {
745    my(@tmp)=_Date_Split($_);
746    if (@tmp) {
747      ($y,$m,$d,$h,$mn,$s)=@tmp;
748      last PARSE;
749    }
750
751    # Fundamental regular expressions
752
753    my($month)=$Lang{$L}{"Month"};          # (jan|january|...)
754    my(%month)=%{ $Lang{$L}{"MonthH"} };    # { jan=>1, ... }
755    my($week)=$Lang{$L}{"Week"};            # (mon|monday|...)
756    my(%week)=%{ $Lang{$L}{"WeekH"} };      # { mon=>1, monday=>1, ... }
757    my($wom)=$Lang{$L}{"WoM"};              # (1st|...|fifth|last)
758    my(%wom)=%{ $Lang{$L}{"WoMH"} };        # { 1st=>1,... fifth=>5,last=>-1 }
759    my($dom)=$Lang{$L}{"DoM"};              # (1st|first|...31st)
760    my(%dom)=%{ $Lang{$L}{"DoMH"} };        # { 1st=>1, first=>1, ... }
761    my($ampmexp)=$Lang{$L}{"AmPm"};         # (am|pm)
762    my($timeexp)=$Lang{$L}{"Times"};        # (noon|midnight)
763    my($now)=$Lang{$L}{"Now"};              # now
764    my($today)=$Lang{$L}{"Today"};          # today
765    my($offset)=$Lang{$L}{"Offset"};        # (yesterday|tomorrow)
766    my($zone)=$Zone{"zones"};               # (edt|est|...)
767    my($day)='\s*'.$Lang{$L}{"Dabb"};       # \s*(?:d|day|days)
768    my($mabb)='\s*'.$Lang{$L}{"Mabb"};      # \s*(?:mon|month|months)
769    my($wkabb)='\s*'.$Lang{$L}{"Wabb"};     # \s*(?:w|wk|week|weeks)
770    my($next)='\s*'.$Lang{$L}{"Next"};      # \s*(?:next)
771    my($prev)='\s*'.$Lang{$L}{"Prev"};      # \s*(?:last|previous)
772    my($past)='\s*'.$Lang{$L}{"Past"};      # \s*(?:ago)
773    my($future)='\s*'.$Lang{$L}{"Future"};  # \s*(?:in)
774    my($later)='\s*'.$Lang{$L}{"Later"};    # \s*(?:later)
775    my($at)=$Lang{$L}{"At"};                # (?:at)
776    my($of)='\s*'.$Lang{$L}{"Of"};          # \s*(?:in|of)
777    my($on)='(?:\s*'.$Lang{$L}{"On"}.'\s*|\s+)';
778                                            # \s*(?:on)\s*    or  \s+
779    my($last)='\s*'.$Lang{$L}{"Last"};      # \s*(?:last)
780    my($hm)=$Lang{$L}{"SepHM"};             # :
781    my($ms)=$Lang{$L}{"SepMS"};             # :
782    my($ss)=$Lang{$L}{"SepSS"};             # .
783
784    # Other regular expressions
785
786    my($D4)='(\d{4})';                      # 4 digits      (yr)
787    my($YY)='(\d{4}|\d{2})';                # 2 or 4 digits (yr)
788    my($DD)='(\d{2})';                      # 2 digits      (mon/day/hr/min/sec)
789    my($D) ='(\d{1,2})';                    # 1 or 2 digit  (mon/day/hr)
790    my($FS)="(?:$ss\\d+)?";                 # fractional secs
791    my($sep)='[\/.-]';                      # non-ISO8601 m/d/yy separators
792    # absolute time zone     +0700 (GMT)
793    my($hzone)='(?:[0-1][0-9]|2[0-3])';     # 00 - 23
794    my($mzone)='(?:[0-5][0-9])';            # 00 - 59
795    my($zone2)='(?:\s*([+-](?:'."$hzone$mzone|$hzone:$mzone|$hzone))".
796                                            # +0700 +07:00 -07
797      '(?:\s*\([^)]+\))?)';                 # (GMT)
798
799    # A regular expression for the time EXCEPT for the hour part
800    my($mnsec)="$hm$DD(?:$ms$DD$FS)?(?:\\s*$ampmexp)?";
801
802    # A special regular expression for /YYYY:HH:MN:SS used by Apache
803    my($apachetime)='(/\d{4}):' . "$DD$hm$DD$ms$DD";
804
805    my($time)="";
806    $ampm="";
807    $date="";
808
809    # Substitute all special time expressions.
810    if (/(^|[^a-z])$timeexp($|[^a-z])/i) {
811      $tmp=$2;
812      $tmp=$Lang{$L}{"TimesH"}{lc($tmp)};
813      s/(^|[^a-z])$timeexp($|[^a-z])/$1 $tmp $3/i;
814    }
815
816    # Remove some punctuation
817    s/[,]/ /g;
818
819    # When we have a digit followed immediately by a timezone (7EST), we
820    # will put a space between the digit, EXCEPT in the case of a single
821    # character military timezone.  If the single character is followed
822    # by anything, no space is added.
823    $tmp = "";
824    while ( s/^(.*?\d)$zone(\s|$|[0-9])/$3/i ) {
825      my($bef,$z,$aft) = ($1,$2,$3);
826      if (length($z) != 1  ||  length($aft) == 0) {
827        $tmp .= "$bef $z";
828      } else {
829        $tmp .= "$bef$z";
830      }
831    }
832    $_ = "$tmp$_";
833    $zone = '\s+' . $zone . '(?:\s+|$)';
834
835    # Remove the time
836    $iso=1;
837    $midnight=0;
838    $from="24${hm}00(?:${ms}00)?";
839    $falsefrom="${hm}24${ms}00";   # Don't trap XX:24:00
840    $to="00${hm}00${ms}00";
841    $midnight=1  if (!/$falsefrom/  &&  s/$from/$to/);
842
843    $h=$mn=$s=0;
844    if (/$D$mnsec/i || /$ampmexp/i) {
845      $iso=0;
846      $tmp=0;
847      $tmp=1  if (/$mnsec$zone2?\s*$/i  or /$mnsec$zone\s*$/i);
848      $tmp=0  if (/$ampmexp/i);
849      if (s/$apachetime$zone()/$1 /i                            ||
850          s/$apachetime$zone2?/$1 /i                            ||
851          s/(^|[^a-z])$at\s*$D$mnsec$zone()/$1 /i               ||
852          s/(^|[^a-z])$at\s*$D$mnsec$zone2?/$1 /i               ||
853          s/(^|[^0-9])(\d)$mnsec$zone()/$1 /i                   ||
854          s/(^|[^0-9])(\d)$mnsec$zone2?/$1 /i                   ||
855          (s/(t)$D$mnsec$zone()/$1 /i and (($iso=$tmp) || 1))   ||
856          (s/(t)$D$mnsec$zone2?/$1 /i and (($iso=$tmp) || 1))   ||
857          (s/()$DD$mnsec$zone()/ /i and (($iso=$tmp) || 1))     ||
858          (s/()$DD$mnsec$zone2?/ /i and (($iso=$tmp) || 1))     ||
859          s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone()/ /i          ||
860          s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone2?/ /i          ||
861          0
862         ) {
863        ($h,$mn,$s,$ampm,$z,$z2)=($2,$3,$4,$5,$6,$7);
864        if (defined ($z)) {
865          if ($z =~ /^[+-]\d{2}:\d{2}$/) {
866            $z=~ s/://;
867          } elsif ($z =~ /^[+-]\d{2}$/) {
868            $z .= "00";
869          }
870        }
871        $time=1;
872        _Date_TimeCheck(\$h,\$mn,\$s,\$ampm);
873        $y=$m=$d="";
874        # We're going to be calling TimeCheck again below (when we check the
875        # final date), so get rid of $ampm so that we don't have an error
876        # due to "15:30:00 PM".  It'll get reset below.
877        $ampm="";
878        if (/^\s*$/) {
879          Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
880          last PARSE;
881        }
882      }
883    }
884    $time=0  if ($time ne "1");
885    s/\s+$//;
886    s/^\s+//;
887
888    # if a zone was found, get rid of the regexps
889    if ($z) {
890      $zone="";
891      $zone2="";
892    }
893
894    # dateTtime ISO 8601 formats
895    my($orig)=$_;
896
897    # Parse ISO 8601 dates now (which may still have a zone stuck to it).
898    if ( ($iso && /^([0-9-]+(?:W[0-9-]+)?)$zone?$/i)   ||
899         ($iso && /^([0-9-]+(?:W[0-9-]+)?)$zone2?$/i)  ||
900         ($iso && /^([0-9-]+(?:T[0-9-]+)?)$zone?$/i)   ||
901         ($iso && /^([0-9-]+(?:T[0-9-]+)?)$zone2?$/i)  ||
902         ($iso && /^([0-9-]+)T$zone?$/i)   ||
903         ($iso && /^([0-9-]+)T$zone2?$/i)  ||
904         0) {
905
906      # If we already got a timezone, don't get another one.
907      my(@z);
908      if ($z) {
909        @z=($z,$z2);
910        $z="";
911      }
912      ($_,$z,$z2) = ($1,$2,$3);
913      ($z,$z2)=@z  if (@z);
914
915      s,([0-9])\s*-,$1 ,g; # Change all ISO8601 seps to spaces
916      s/^\s+//;
917      s/\s+$//;
918
919      if (/^$D4\s*$DD\s*$DD\s*t?$DD(?:$DD(?:$DD(\d*))?)?$/i ||
920          /^$DD\s+$DD\s*$DD\s*t?$DD(?:$DD(?:$DD(\d*))?)?$/i ||
921          0
922         ) {
923        # ISO 8601 Dates with times
924        #    YYYYMMDDtHHMNSSFFFF...
925        #    YYYYMMDDtHHMNSS
926        #    YYYYMMDDtHHMN
927        #    YYYYMMDDtHH
928        #    YY MMDDtHHMNSSFFFF...
929        #    YY MMDDtHHMNSS
930        #    YY MMDDtHHMN
931        #    YY MMDDtHH
932        # The t is an optional letter "t".
933        ($y,$m,$d,$h,$mn,$s,$tmp)=($1,$2,$3,$4,$5,$6,$7);
934        if ($h==24 && (! defined $mn || $mn==0) && (! defined $s || $s==0)) {
935          $h=0;
936          $midnight=1;
937        }
938        $z = ""    if (! defined $h);
939        return ""  if ($time  &&  defined $h);
940        last PARSE;
941
942      } elsif (/^$D4(?:\s*$DD(?:\s*$DD)?)?$/  ||
943               /^$DD(?:\s+$DD(?:\s*$DD)?)?$/) {
944        # ISO 8601 Dates
945        #    YYYYMMDD
946        #    YYYYMM
947        #    YYYY
948        #    YY MMDD
949        #    YY MM
950        #    YY
951        ($y,$m,$d)=($1,$2,$3);
952        last PARSE;
953
954      } elsif (/^$YY\s+$D\s+$D/) {
955        # YY-M-D
956        ($y,$m,$d)=($1,$2,$3);
957        last PARSE;
958
959      } elsif (/^$YY\s*W$DD\s*(\d)?$/i) {
960        # YY-W##-D
961        ($y,$wofm,$dofw)=($1,$2,$3);
962        ($y,$m,$d)=_Date_NthWeekOfYear($y,$wofm,$dofw);
963        last PARSE;
964
965      } elsif (/^$D4\s*(\d{3})$/ ||
966               /^$DD\s*(\d{3})$/) {
967        # YYDOY
968        ($y,$which)=($1,$2);
969        ($y,$m,$d)=Date_NthDayOfYear($y,$which);
970        last PARSE;
971
972      } elsif ($iso<0) {
973        # We confused something like 1999/August12:00:00
974        # with a dateTtime format
975        $_=$orig;
976
977      } else {
978        return "";
979      }
980    }
981
982    # All deltas that are not ISO-8601 dates are NOT dates.
983    return ""  if ($Curr{"InCalc"}  &&  $delta);
984    if ($delta) {
985      Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
986      return _DateCalc_DateDelta($Curr{"Now"},$delta);
987    }
988
989    # Check for some special types of dates (next, prev)
990    foreach $from (keys %{ $Lang{$L}{"Repl"} }) {
991      $to=$Lang{$L}{"Repl"}{$from};
992      s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i;
993    }
994    if (/$wom/i  ||  /$future/i  ||  /$later/i  ||  /$past/i  ||
995        /$next/i  ||  /$prev/i  ||  /^$week$/i  ||  /$wkabb/i) {
996      $tmp=0;
997
998      if (/^$wom\s*$week$of\s*$month\s*$YY?$/i) {
999        # last friday in October 95
1000        ($wofm,$dofw,$m,$y)=($1,$2,$3,$4);
1001        # fix $m, $y
1002        return ""  if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
1003        $dofw=$week{lc($dofw)};
1004        $wofm=$wom{lc($wofm)};
1005        # Get the first day of the month
1006        $date=_Date_Join($y,$m,1,$h,$mn,$s);
1007        if ($wofm==-1) {
1008          $date=_DateCalc_DateDelta($date,"+0:1:0:0:0:0:0",\$err,0);
1009          $date=Date_GetPrev($date,$dofw,0);
1010        } else {
1011          for ($i=0; $i<$wofm; $i++) {
1012            if ($i==0) {
1013              $date=Date_GetNext($date,$dofw,1);
1014            } else {
1015              $date=Date_GetNext($date,$dofw,0);
1016            }
1017          }
1018        }
1019        last PARSE;
1020
1021      } elsif (/^$last$day$of\s*$month(?:$of?\s*$YY)?/i) {
1022        # last day in month
1023        ($m,$y)=($1,$2);
1024        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1025        $y=_Date_FixYear($y)  if (! defined $y  or  length($y)<4);
1026        $m=$month{lc($m)};
1027        $d=Date_DaysInMonth($m,$y);
1028        last PARSE;
1029
1030      } elsif (/^$week$/i) {
1031        # friday
1032        ($dofw)=($1);
1033        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1034        $date=Date_GetPrev($Curr{"Now"},$Cnf{"FirstDay"},1);
1035        $date=Date_GetNext($date,$dofw,1,$h,$mn,$s);
1036        last PARSE;
1037
1038      } elsif (/^$next\s*$week$/i) {
1039        # next friday
1040        ($dofw)=($1);
1041        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1042        $date=Date_GetNext($Curr{"Now"},$dofw,0,$h,$mn,$s);
1043        last PARSE;
1044
1045      } elsif (/^$prev\s*$week$/i) {
1046        # last friday
1047        ($dofw)=($1);
1048        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1049        $date=Date_GetPrev($Curr{"Now"},$dofw,0,$h,$mn,$s);
1050        last PARSE;
1051
1052      } elsif (/^$next$wkabb$/i) {
1053        # next week
1054        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1055        $date=_DateCalc_DateDelta($Curr{"Now"},"+0:0:1:0:0:0:0",\$err,0);
1056        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1057        last PARSE;
1058      } elsif (/^$prev$wkabb$/i) {
1059        # last week
1060        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1061        $date=_DateCalc_DateDelta($Curr{"Now"},"-0:0:1:0:0:0:0",\$err,0);
1062        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1063        last PARSE;
1064
1065      } elsif (/^$next$mabb$/i) {
1066        # next month
1067        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1068        $date=_DateCalc_DateDelta($Curr{"Now"},"+0:1:0:0:0:0:0",\$err,0);
1069        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1070        last PARSE;
1071      } elsif (/^$prev$mabb$/i) {
1072        # last month
1073        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1074        $date=_DateCalc_DateDelta($Curr{"Now"},"-0:1:0:0:0:0:0",\$err,0);
1075        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1076        last PARSE;
1077
1078      } elsif (/^$future\s*(\d+)$day$/i  ||
1079               /^(\d+)$day$later$/i) {
1080        # in 2 days
1081        # 2 days later
1082        ($num)=($1);
1083        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1084        $date=_DateCalc_DateDelta($Curr{"Now"},"+0:0:0:$num:0:0:0",
1085                                  \$err,0);
1086        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1087        last PARSE;
1088      } elsif (/^(\d+)$day$past$/i) {
1089        # 2 days ago
1090        ($num)=($1);
1091        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1092        $date=_DateCalc_DateDelta($Curr{"Now"},"-0:0:0:$num:0:0:0",
1093                                 \$err,0);
1094        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1095        last PARSE;
1096
1097      } elsif (/^$future\s*(\d+)$wkabb$/i  ||
1098               /^(\d+)$wkabb$later$/i) {
1099        # in 2 weeks
1100        # 2 weeks later
1101        ($num)=($1);
1102        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1103        $date=_DateCalc_DateDelta($Curr{"Now"},"+0:0:$num:0:0:0:0",
1104                                  \$err,0);
1105        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1106        last PARSE;
1107      } elsif (/^(\d+)$wkabb$past$/i) {
1108        # 2 weeks ago
1109        ($num)=($1);
1110        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1111        $date=_DateCalc_DateDelta($Curr{"Now"},"-0:0:$num:0:0:0:0",
1112                                 \$err,0);
1113        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1114        last PARSE;
1115
1116      } elsif (/^$future\s*(\d+)$mabb$/i  ||
1117               /^(\d+)$mabb$later$/i) {
1118        # in 2 months
1119        # 2 months later
1120        ($num)=($1);
1121        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1122        $date=_DateCalc_DateDelta($Curr{"Now"},"+0:$num:0:0:0:0:0",
1123                                  \$err,0);
1124        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1125        last PARSE;
1126      } elsif (/^(\d+)$mabb$past$/i) {
1127        # 2 months ago
1128        ($num)=($1);
1129        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1130        $date=_DateCalc_DateDelta($Curr{"Now"},"-0:$num:0:0:0:0:0",
1131                                  \$err,0);
1132        $date=Date_SetTime($date,$h,$mn,$s)  if (defined $h);
1133        last PARSE;
1134
1135      } elsif (/^$week$future\s*(\d+)$wkabb$/i  ||
1136               /^$week\s*(\d+)$wkabb$later$/i) {
1137        # friday in 2 weeks
1138        # friday 2 weeks later
1139        ($dofw,$num)=($1,$2);
1140        $tmp="+";
1141      } elsif (/^$week\s*(\d+)$wkabb$past$/i) {
1142        # friday 2 weeks ago
1143        ($dofw,$num)=($1,$2);
1144        $tmp="-";
1145      } elsif (/^$future\s*(\d+)$wkabb$on$week$/i  ||
1146               /^(\d+)$wkabb$later$on$week$/i) {
1147        # in 2 weeks on friday
1148        # 2 weeks later on friday
1149        ($num,$dofw)=($1,$2);
1150        $tmp="+"
1151      } elsif (/^(\d+)$wkabb$past$on$week$/i) {
1152        # 2 weeks ago on friday
1153        ($num,$dofw)=($1,$2);
1154        $tmp="-";
1155      } elsif (/^$week\s*$wkabb$/i) {
1156        # monday week    (British date: in 1 week on monday)
1157        $dofw=$1;
1158        $num=1;
1159        $tmp="+";
1160      } elsif ( (/^$now\s*$wkabb$/i   &&  ($tmp="Now"))  ||
1161                (/^$today\s*$wkabb$/i &&  ($tmp="Today")) ) {
1162        # now week     (British date: 1 week from now)
1163        # today week   (British date: 1 week from today)
1164        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1165        $date=_DateCalc_DateDelta($Curr{$tmp},"+0:0:1:0:0:0:0",\$err,0);
1166        $date=Date_SetTime($date,$h,$mn,$s)  if ($time);
1167        last PARSE;
1168      } elsif (/^$offset\s*$wkabb$/i) {
1169        # tomorrow week  (British date: 1 week from tomorrow)
1170        ($offset)=($1);
1171        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1172        $offset=$Lang{$L}{"OffsetH"}{lc($offset)};
1173        $date=_DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0);
1174        $date=_DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0);
1175        if ($time) {
1176          return ""
1177            if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
1178          $date=Date_SetTime($date,$h,$mn,$s);
1179        }
1180        last PARSE;
1181      }
1182
1183      if ($tmp) {
1184        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1185        $date=_DateCalc_DateDelta($Curr{"Now"},
1186                                  $tmp . "0:0:$num:0:0:0:0",\$err,0);
1187        $date=Date_GetPrev($date,$Cnf{"FirstDay"},1);
1188        $date=Date_GetNext($date,$dofw,1,$h,$mn,$s);
1189        last PARSE;
1190      }
1191    }
1192
1193    # Change (2nd, second) to 2
1194    $tmp=0;
1195    if (/(^|[^a-z0-9])$dom($|[^a-z0-9])/i) {
1196      if (/^\s*$dom\s*$/) {
1197        ($d)=($1);
1198        $d=$dom{lc($d)};
1199        $m=$Curr{"M"};
1200        last PARSE;
1201      }
1202      my $from = $2;
1203      my $to   = $dom{ lc($from) };
1204      s/(^|[^a-z])$from($|[^a-z])/$1 $to $2/i;
1205      s/^\s+//;
1206      s/\s+$//;
1207    }
1208
1209    # Another set of special dates (Nth week)
1210    if (/^$D\s*$week(?:$of?\s*$YY)?$/i) {
1211      # 22nd sunday in 1996
1212      ($which,$dofw,$y)=($1,$2,$3);
1213      $y=$Curr{"Y"}  if (! $y);
1214      $y--; # previous year
1215      $tmp=Date_GetNext("$y-12-31",$dofw,0);
1216      if ($which>1) {
1217        $tmp=_DateCalc_DateDelta($tmp,"+0:0:".($which-1).":0:0:0:0",\$err,0);
1218      }
1219      ($y,$m,$d)=(_Date_Split($tmp, 1))[0..2];
1220      last PARSE;
1221    } elsif (/^$week$wkabb\s*$D(?:$of?\s*$YY)?$/i  ||
1222             /^$week\s*$D$wkabb(?:$of?\s*$YY)?$/i) {
1223      # sunday week 22 in 1996
1224      # sunday 22nd week in 1996
1225      ($dofw,$which,$y)=($1,$2,$3);
1226      ($y,$m,$d)=_Date_NthWeekOfYear($y,$which,$dofw);
1227      last PARSE;
1228    }
1229
1230    # Get rid of day of week
1231    if (/(^|[^a-z])$week($|[^a-z])/i) {
1232      $wk=$2;
1233      (s/(^|[^a-z])$week,/$1 /i) ||
1234        s/(^|[^a-z])$week($|[^a-z])/$1 $3/i;
1235      s/^\s+//;
1236      s/\s+$//;
1237    }
1238
1239    {
1240      # So that we can handle negative epoch times, let's convert
1241      # things like "epoch -" to "epochNEGATIVE " before we strip out
1242      # the $sep chars, which include '-'.
1243      s,epoch\s*-,epochNEGATIVE ,g;
1244
1245      # Non-ISO8601 dates
1246      s,\s*$sep\s*, ,g;     # change all non-ISO8601 seps to spaces
1247      s,^\s*,,;             # remove leading/trailing space
1248      s,\s*$,,;
1249
1250      if (/^$D\s+$D(?:\s+$YY)?$/) {
1251        # MM DD YY (DD MM YY non-US)
1252        ($m,$d,$y)=($1,$2,$3);
1253        ($m,$d)=($d,$m)  if ($type ne "US");
1254        last PARSE;
1255
1256      } elsif (/^$D4\s*$D\s*$D$/) {
1257        # YYYY MM DD
1258        ($y,$m,$d)=($1,$2,$3);
1259        last PARSE;
1260
1261      } elsif (s/(^|[^a-z])$month($|[^a-z])/$1 $3/i) {
1262        ($m)=($2);
1263
1264        if (/^\s*$D(?:\s+$YY)?\s*$/) {
1265          # mmm DD YY
1266          # DD mmm YY
1267          # DD YY mmm
1268          ($d,$y)=($1,$2);
1269          last PARSE;
1270
1271        } elsif (/^\s*$D$D4\s*$/) {
1272          # mmm DD YYYY
1273          # DD mmm YYYY
1274          # DD YYYY mmm
1275          ($d,$y)=($1,$2);
1276          last PARSE;
1277
1278        } elsif (/^\s*$D4\s*$D\s*$/) {
1279          # mmm YYYY DD
1280          # YYYY mmm DD
1281          # YYYY DD mmm
1282          ($y,$d)=($1,$2);
1283          last PARSE;
1284
1285        } elsif (/^\s*$D4\s*$/) {
1286          # mmm YYYY
1287          # YYYY mmm
1288          ($y,$d)=($1,1);
1289          last PARSE;
1290
1291        } else {
1292          return "";
1293        }
1294
1295      } elsif (/^epochNEGATIVE (\d+)$/) {
1296        $s=$1;
1297        $date=DateCalc("1970-01-01 00:00 GMT","-0:0:$s");
1298      } elsif (/^epoch\s*(\d+)$/i) {
1299        $s=$1;
1300        $date=DateCalc("1970-01-01 00:00 GMT","+0:0:$s");
1301
1302      } elsif ( (/^$now$/i   &&  ($tmp="Now"))  ||
1303                (/^$today$/i &&  ($tmp="Today")) ) {
1304        # now, today
1305        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1306        $date=$Curr{$tmp};
1307        if ($time) {
1308          return ""
1309            if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
1310          $date=Date_SetTime($date,$h,$mn,$s);
1311        }
1312        last PARSE;
1313
1314      } elsif (/^$offset$/i) {
1315        # yesterday, tomorrow
1316        ($offset)=($1);
1317        Date_Init()  if (! $Cnf{"UpdateCurrTZ"});
1318        $offset=$Lang{$L}{"OffsetH"}{lc($offset)};
1319        $date=_DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0);
1320        if ($time) {
1321          return ""
1322            if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
1323          $date=Date_SetTime($date,$h,$mn,$s);
1324        }
1325        last PARSE;
1326
1327      } else {
1328        return "";
1329      }
1330    }
1331  }
1332
1333  if (! $date) {
1334    return ""  if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
1335    $date=_Date_Join($y,$m,$d,$h,$mn,$s);
1336  }
1337  $date=Date_ConvTZ($date,$z);
1338  if ($midnight) {
1339    $date=_DateCalc_DateDelta($date,"+0:0:0:1:0:0:0");
1340  }
1341  return $date;
1342}
1343
1344sub ParseDate {
1345  print "DEBUG: ParseDate\n"  if ($Curr{"Debug"} =~ /trace/);
1346  Date_Init()  if (! $Curr{"InitDone"});
1347  my($args,@args,@a,$ref,$date)=();
1348  @a=@_;
1349
1350  # @a : is the list of args to ParseDate.  Currently, only one argument
1351  #      is allowed and it must be a scalar (or a reference to a scalar)
1352  #      or a reference to an array.
1353
1354  if ($#a!=0) {
1355    print "ERROR:  Invalid number of arguments to ParseDate.\n";
1356    return "";
1357  }
1358  $args=$a[0];
1359  $ref=ref $args;
1360  if (! $ref) {
1361    return $args  if (_Date_Split($args));
1362    @args=($args);
1363  } elsif ($ref eq "ARRAY") {
1364    @args=@$args;
1365  } elsif ($ref eq "SCALAR") {
1366    return $$args  if (_Date_Split($$args));
1367    @args=($$args);
1368  } else {
1369    print "ERROR:  Invalid arguments to ParseDate.\n";
1370    return "";
1371  }
1372  @a=@args;
1373
1374  # @args : a list containing all the arguments (dereferenced if appropriate)
1375  # @a    : a list containing all the arguments currently being examined
1376  # $ref  : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a
1377  #         reference to a scalar, or a reference to an array was passed in
1378  # $args : the scalar or refererence passed in
1379
1380 PARSE: while($#a>=0) {
1381    $date=join(" ",@a);
1382    $date=ParseDateString($date);
1383    last  if ($date);
1384    pop(@a);
1385  } # PARSE
1386
1387  splice(@args,0,$#a + 1);
1388  @$args= @args  if (defined $ref  and  $ref eq "ARRAY");
1389  $date;
1390}
1391
1392sub Date_Cmp {
1393  my($D1,$D2)=@_;
1394  my($date1)=ParseDateString($D1);
1395  my($date2)=ParseDateString($D2);
1396  return $date1 cmp $date2;
1397}
1398
1399# **NOTE**
1400# The calc routines all call parse routines, so it is never necessary to
1401# call Date_Init in the calc routines.
1402sub DateCalc {
1403  print "DEBUG: DateCalc\n"  if ($Curr{"Debug"} =~ /trace/);
1404  my($D1,$D2,@arg)=@_;
1405  my($ref,$err,$errref,$mode)=();
1406
1407  ($errref,$mode) = (@arg);
1408  $ref=0;
1409
1410  if (defined $errref) {
1411    if (ref $errref) {
1412      $ref=1;
1413    } elsif (! defined $mode) {
1414      $mode=$errref;
1415      $errref="";
1416    }
1417  }
1418
1419  my(@date,@delta,$ret,$tmp,$oldincalc,$oldmode)=();
1420
1421  if (exists $Curr{"Mode"}) {
1422    $oldmode = $Curr{"Mode"};
1423  } else {
1424    $oldmode = 0;
1425  }
1426
1427  if (defined $mode  and  $mode>=0  and  $mode<=3) {
1428    $Curr{"Mode"}=$mode;
1429  } else {
1430    $Curr{"Mode"}=0;
1431  }
1432
1433  if (exists $Curr{"InCalc"}) {
1434    $oldincalc = $Curr{"InCalc"};
1435  } else {
1436    $oldincalc = 0;
1437  }
1438  $Curr{"InCalc"}=1;
1439
1440  if ($tmp=ParseDateString($D1)) {
1441    # If we've already parsed the date, we don't want to do it a second
1442    # time (so we don't convert timezones twice).
1443    if (_Date_Split($D1)) {
1444      push(@date,$D1);
1445    } else {
1446      push(@date,$tmp);
1447    }
1448  } elsif ($tmp=ParseDateDelta($D1)) {
1449    push(@delta,$tmp);
1450  } else {
1451    $$errref=1  if ($ref);
1452    $Curr{"InCalc"} = $oldincalc;
1453    $Curr{"Mode"}   = $oldmode;
1454    return;
1455  }
1456
1457  if ($tmp=ParseDateString($D2)) {
1458    if (_Date_Split($D2)) {
1459      push(@date,$D2);
1460    } else {
1461      push(@date,$tmp);
1462    }
1463  } elsif ($tmp=ParseDateDelta($D2)) {
1464    push(@delta,$tmp);
1465    $mode = $Curr{"Mode"};
1466  } else {
1467    $$errref=2  if ($ref);
1468    $Curr{"InCalc"} = $oldincalc;
1469    $Curr{"Mode"}   = $oldmode;
1470    return;
1471  }
1472
1473  $Curr{"InCalc"} = $oldincalc;
1474  $Curr{"Mode"}   = $oldmode;
1475
1476  if ($#date==1) {
1477    $ret=_DateCalc_DateDate(@date,$mode);
1478  } elsif ($#date==0) {
1479    $ret=_DateCalc_DateDelta(@date,@delta,\$err,$mode);
1480    $$errref=$err  if ($ref);
1481  } else {
1482    $ret=_DateCalc_DeltaDelta(@delta,$mode);
1483  }
1484  $ret;
1485}
1486
1487sub ParseDateDelta {
1488  print "DEBUG: ParseDateDelta\n"  if ($Curr{"Debug"} =~ /trace/);
1489  my($args,@args,@a,$ref)=();
1490  local($_)=();
1491  @a=@_;
1492
1493  # @a : is the list of args to ParseDateDelta.  Currently, only one argument
1494  #      is allowed and it must be a scalar (or a reference to a scalar)
1495  #      or a reference to an array.
1496
1497  if ($#a!=0) {
1498    print "ERROR:  Invalid number of arguments to ParseDateDelta.\n";
1499    return "";
1500  }
1501  $args=$a[0];
1502  $ref=ref $args;
1503  if (! $ref) {
1504    @args=($args);
1505  } elsif ($ref eq "ARRAY") {
1506    @args=@$args;
1507  } elsif ($ref eq "SCALAR") {
1508    @args=($$args);
1509  } else {
1510    print "ERROR:  Invalid arguments to ParseDateDelta.\n";
1511    return "";
1512  }
1513  @a=@args;
1514
1515  # @args : a list containing all the arguments (dereferenced if appropriate)
1516  # @a    : a list containing all the arguments currently being examined
1517  # $ref  : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a
1518  #         reference to a scalar, or a reference to an array was passed in
1519  # $args : the scalar or refererence passed in
1520
1521  my(@colon,@delta,$delta,$dir,$colon,$sign,$val)=();
1522  my($len,$tmp,$tmp2,$tmpl)=();
1523  my($from,$to)=();
1524  my($workweek)=$Cnf{"WorkWeekEnd"}-$Cnf{"WorkWeekBeg"}+1;
1525
1526  Date_Init()  if (! $Curr{"InitDone"});
1527  # A sign can be a sequence of zero or more + and - signs, this
1528  # allows for deltas like '+ -2 days'.
1529  my($signexp)='((?:[+-]\s*)*)';
1530  my($numexp)='(\d+)';
1531  my($exp1)="(?: \\s* $signexp \\s* $numexp \\s*)";
1532  my($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp,$i)=();
1533  $yexp=$mexp=$wexp=$dexp=$hexp=$mnexp=$sexp="()()";
1534  $yexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Yabb"} .")?";
1535  $mexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Mabb"} .")?";
1536  $wexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Wabb"} .")?";
1537  $dexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Dabb"} .")?";
1538  $hexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Habb"} .")?";
1539  $mnexp="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"MNabb"}.")?";
1540  $sexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Sabb"} ."?)?";
1541  my($future)=$Lang{$Cnf{"Language"}}{"Future"};
1542  my($later)=$Lang{$Cnf{"Language"}}{"Later"};
1543  my($past)=$Lang{$Cnf{"Language"}}{"Past"};
1544
1545  $delta="";
1546 PARSE: while (@a) {
1547    $_ = join(" ", grep {defined;} @a);
1548    s/\s+$//;
1549    last  if ($_ eq "");
1550
1551    # Mode is set in DateCalc.  ParseDateDelta only overrides it if the
1552    # string contains a mode.
1553    if      ($Lang{$Cnf{"Language"}}{"Exact"} &&
1554             s/$Lang{$Cnf{"Language"}}{"Exact"}//) {
1555      $Curr{"Mode"}=0;
1556    } elsif ($Lang{$Cnf{"Language"}}{"Approx"} &&
1557             s/$Lang{$Cnf{"Language"}}{"Approx"}//) {
1558      $Curr{"Mode"}=1;
1559    } elsif ($Lang{$Cnf{"Language"}}{"Business"} &&
1560             s/$Lang{$Cnf{"Language"}}{"Business"}//) {
1561      $Curr{"Mode"}=2;
1562    } elsif (! exists $Curr{"Mode"}) {
1563      $Curr{"Mode"}=0;
1564    }
1565    $workweek=7  if ($Curr{"Mode"} != 2);
1566
1567    foreach $from (keys %{ $Lang{$Cnf{"Language"}}{"Repl"} }) {
1568      $to=$Lang{$Cnf{"Language"}}{"Repl"}{$from};
1569      s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i;
1570    }
1571
1572    # in or ago
1573    #
1574    # We need to make sure that $later, $future, and $past don't contain each
1575    # other... Romanian pointed this out where $past is "in urma" and $future
1576    # is "in".  When they do, we have to take this into account.
1577    #   $len  length of best match (greatest wins)
1578    #   $tmp  string after best match
1579    #   $dir  direction (prior, after) of best match
1580    #
1581    #   $tmp2 string before/after current match
1582    #   $tmpl length of current match
1583
1584    $len=0;
1585    $tmp=$_;
1586    $dir=1;
1587
1588    $tmp2=$_;
1589    if ($tmp2 =~ s/(^|[^a-z])($future)($|[^a-z])/$1 $3/i) {
1590      $tmpl=length($2);
1591      if ($tmpl>$len) {
1592        $tmp=$tmp2;
1593        $dir=1;
1594        $len=$tmpl;
1595      }
1596    }
1597
1598    $tmp2=$_;
1599    if ($tmp2 =~ s/(^|[^a-z])($later)($|[^a-z])/$1 $3/i) {
1600      $tmpl=length($2);
1601      if ($tmpl>$len) {
1602        $tmp=$tmp2;
1603        $dir=1;
1604        $len=$tmpl;
1605      }
1606    }
1607
1608    $tmp2=$_;
1609    if ($tmp2 =~ s/(^|[^a-z])($past)($|[^a-z])/$1 $3/i) {
1610      $tmpl=length($2);
1611      if ($tmpl>$len) {
1612        $tmp=$tmp2;
1613        $dir=-1;
1614        $len=$tmpl;
1615      }
1616    }
1617
1618    $_ = $tmp;
1619    s/\s*$//;
1620
1621    # the colon part of the delta
1622    $colon="";
1623    if (s/($signexp?$numexp?(:($signexp?$numexp)?){1,6})$//) {
1624      $colon=$1;
1625      s/\s+$//;
1626    }
1627    @colon=split(/:/,$colon);
1628
1629    # the non-colon part of the delta
1630    $sign="+";
1631    @delta=();
1632    $i=6;
1633    foreach $exp1 ($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp) {
1634      last  if ($#colon>=$i--);
1635      $val=0;
1636      if (s/^$exp1//ix) {
1637        $val=$2   if ($2);
1638        $sign=$1  if ($1);
1639      }
1640
1641      # Collapse a sign like '+ -' into a single character like '-',
1642      # by counting the occurrences of '-'.
1643      #
1644      $sign =~ s/\s+//g;
1645      $sign =~ tr/+//d;
1646      my $count = ($sign =~ tr/-//d);
1647      die "bad characters in sign: $sign" if length $sign;
1648      $sign = $count % 2 ? '-' : '+';
1649
1650      push(@delta,"$sign$val");
1651    }
1652    if (! /^\s*$/) {
1653      pop(@a);
1654      next PARSE;
1655    }
1656
1657    # make sure that the colon part has a sign
1658    for ($i=0; $i<=$#colon; $i++) {
1659      $val=0;
1660      if ($colon[$i] =~ /^$signexp$numexp?/) {
1661        $val=$2   if ($2);
1662        $sign=$1  if ($1);
1663      }
1664      $colon[$i] = "$sign$val";
1665    }
1666
1667    # combine the two
1668    push(@delta,@colon);
1669    if ($dir<0) {
1670      for ($i=0; $i<=$#delta; $i++) {
1671        $delta[$i] =~ tr/-+/+-/;
1672      }
1673    }
1674
1675    # form the delta and shift off the valid part
1676    $delta=join(":",@delta);
1677    splice(@args,0,$#a+1);
1678    @$args=@args  if (defined $ref  and  $ref eq "ARRAY");
1679    last PARSE;
1680  }
1681
1682  $delta=_Delta_Normalize($delta,$Curr{"Mode"});
1683  return $delta;
1684}
1685
1686sub UnixDate {
1687  print "DEBUG: UnixDate\n"  if ($Curr{"Debug"} =~ /trace/);
1688  my($date,@format)=@_;
1689  local($_)=();
1690  my($format,%f,$out,@out,$c,$date1,$date2,$tmp)=();
1691  my($scalar)=();
1692  $date=ParseDateString($date);
1693  return  if (! $date);
1694
1695  my($y,$m,$d,$h,$mn,$s)=($f{"Y"},$f{"m"},$f{"d"},$f{"H"},$f{"M"},$f{"S"})=
1696    _Date_Split($date, 1);
1697  $f{"y"}=substr $f{"Y"},2;
1698  Date_Init()  if (! $Curr{"InitDone"});
1699
1700  if (! wantarray) {
1701    $format=join(" ",@format);
1702    @format=($format);
1703    $scalar=1;
1704  }
1705
1706  # month, week
1707  $_=$m;
1708  s/^0//;
1709  $f{"b"}=$f{"h"}=$Lang{$Cnf{"Language"}}{"MonL"}[$_-1];
1710  $f{"B"}=$Lang{$Cnf{"Language"}}{"MonthL"}[$_-1];
1711  $_=$m;
1712  s/^0/ /;
1713  $f{"f"}=$_;
1714  $f{"U"}=Date_WeekOfYear($m,$d,$y,7);
1715  $f{"W"}=Date_WeekOfYear($m,$d,$y,1);
1716
1717  # check week 52,53 and 0
1718  $f{"G"}=$f{"L"}=$y;
1719  if ($f{"W"}>=52 || $f{"U"}>=52) {
1720    my($dd,$mm,$yy)=($d,$m,$y);
1721    $dd+=7;
1722    if ($dd>31) {
1723      $dd-=31;
1724      $mm=1;
1725      $yy++;
1726      if (Date_WeekOfYear($mm,$dd,$yy,1)==2) {
1727        $f{"G"}=$yy;
1728        $f{"W"}=1;
1729      }
1730      if (Date_WeekOfYear($mm,$dd,$yy,7)==2) {
1731        $f{"L"}=$yy;
1732        $f{"U"}=1;
1733      }
1734    }
1735  }
1736  if ($f{"W"}==0) {
1737    my($dd,$mm,$yy)=($d,$m,$y);
1738    $dd-=7;
1739    $dd+=31  if ($dd<1);
1740    $yy = sprintf "%04d", $yy-1;
1741    $mm=12;
1742    $f{"G"}=$yy;
1743    $f{"W"}=Date_WeekOfYear($mm,$dd,$yy,1)+1;
1744  }
1745  if ($f{"U"}==0) {
1746    my($dd,$mm,$yy)=($d,$m,$y);
1747    $dd-=7;
1748    $dd+=31  if ($dd<1);
1749    $yy = sprintf "%04d", $yy-1;
1750    $mm=12;
1751    $f{"L"}=$yy;
1752    $f{"U"}=Date_WeekOfYear($mm,$dd,$yy,7)+1;
1753  }
1754
1755  $f{"U"}="0".$f{"U"}  if (length $f{"U"} < 2);
1756  $f{"W"}="0".$f{"W"}  if (length $f{"W"} < 2);
1757
1758  # day
1759  $f{"j"}=Date_DayOfYear($m,$d,$y);
1760  $f{"j"} = "0" . $f{"j"}   while (length($f{"j"})<3);
1761  $_=$d;
1762  s/^0/ /;
1763  $f{"e"}=$_;
1764  $f{"w"}=Date_DayOfWeek($m,$d,$y);
1765  $f{"v"}=$Lang{$Cnf{"Language"}}{"WL"}[$f{"w"}-1];
1766  $f{"v"}=" ".$f{"v"}  if (length $f{"v"} < 2);
1767  $f{"a"}=$Lang{$Cnf{"Language"}}{"WkL"}[$f{"w"}-1];
1768  $f{"A"}=$Lang{$Cnf{"Language"}}{"WeekL"}[$f{"w"}-1];
1769  $f{"E"}=Date_DaySuffix($f{"e"});
1770
1771  # hour
1772  $_=$h;
1773  s/^0/ /;
1774  $f{"k"}=$_;
1775  $f{"i"}=$f{"k"}+1;
1776  $f{"i"}=$f{"k"};
1777  $f{"i"}=12          if ($f{"k"}==0);
1778  $f{"i"}=$f{"k"}-12  if ($f{"k"}>12);
1779  $f{"i"}=$f{"i"}-12  if ($f{"i"}>12);
1780  $f{"i"}=" ".$f{"i"} if (length($f{"i"})<2);
1781  $f{"I"}=$f{"i"};
1782  $f{"I"}=~ s/^ /0/;
1783  $f{"p"}=$Lang{$Cnf{"Language"}}{"AMstr"};
1784  $f{"p"}=$Lang{$Cnf{"Language"}}{"PMstr"}  if ($f{"k"}>11);
1785
1786  # minute, second, timezone
1787  $f{"o"}=Date_SecsSince1970($m,$d,$y,$h,$mn,$s);
1788  $f{"s"}=Date_SecsSince1970GMT($m,$d,$y,$h,$mn,$s);
1789  $f{"Z"}=($Cnf{"ConvTZ"} eq "IGNORE" or $Cnf{"ConvTZ"} eq "") ?
1790           $Cnf{"TZ"} : $Cnf{"ConvTZ"};
1791  $f{"z"}=($f{"Z"}=~/^[+-]\d{4}/) ? $f{"Z"} : ($Zone{"n2o"}{lc $f{"Z"}} || "");
1792
1793  # date, time
1794  $f{"c"}=qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $y|;
1795  $f{"C"}=$f{"u"}=
1796    qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $f{"z"} $y|;
1797  $f{"g"}=qq|$f{"a"}, $d $f{"b"} $y $h:$mn:$s $f{"z"}|;
1798  $f{"D"}=$f{"x"}=qq|$m/$d/$f{"y"}|;
1799  $f{"x"}=qq|$d/$m/$f{"y"}|  if ($Cnf{"DateFormat"} ne "US");
1800  $f{"r"}=qq|$f{"I"}:$mn:$s $f{"p"}|;
1801  $f{"R"}=qq|$h:$mn|;
1802  $f{"T"}=$f{"X"}=qq|$h:$mn:$s|;
1803  $f{"V"}=qq|$m$d$h$mn$f{"y"}|;
1804  $f{"Q"}="$y$m$d";
1805  $f{"q"}=qq|$y$m$d$h$mn$s|;
1806  $f{"P"}=qq|$y$m$d$h:$mn:$s|;
1807  $f{"O"}=qq|$y-$m-${d}T$h:$mn:$s|;
1808  $f{"F"}=qq|$f{"A"}, $f{"B"} $f{"e"}, $f{"Y"}|;
1809  if ($f{"W"}==0) {
1810    $y--;
1811    $tmp=Date_WeekOfYear(12,31,$y,1);
1812    $tmp="0$tmp"  if (length($tmp) < 2);
1813    $f{"J"}=qq|$y-W$tmp-$f{"w"}|;
1814  } else {
1815    $f{"J"}=qq|$f{"G"}-W$f{"W"}-$f{"w"}|;
1816  }
1817  $f{"K"}=qq|$y-$f{"j"}|;
1818  # %l is a special case.  Since it requires the use of the calculator
1819  # which requires this routine, an infinite recursion results.  To get
1820  # around this, %l is NOT determined every time this is called so the
1821  # recursion breaks.
1822
1823  # other formats
1824  $f{"n"}="\n";
1825  $f{"t"}="\t";
1826  $f{"%"}="%";
1827  $f{"+"}="+";
1828
1829  foreach $format (@format) {
1830    $format=reverse($format);
1831    $out="";
1832    while ($format ne "") {
1833      $c=chop($format);
1834      if ($c eq "%") {
1835        $c=chop($format);
1836        if ($c eq "l") {
1837          Date_Init();
1838          $date1=_DateCalc_DateDelta($Curr{"Now"},"-0:6:0:0:0:0:0");
1839          $date2=_DateCalc_DateDelta($Curr{"Now"},"+0:6:0:0:0:0:0");
1840          if (Date_Cmp($date,$date1)>=0  &&  Date_Cmp($date,$date2)<=0) {
1841            $f{"l"}=qq|$f{"b"} $f{"e"} $h:$mn|;
1842          } else {
1843            $f{"l"}=qq|$f{"b"} $f{"e"}  $f{"Y"}|;
1844          }
1845          $out .= $f{"$c"};
1846        } elsif (exists $f{"$c"}) {
1847          $out .= $f{"$c"};
1848        } else {
1849          $out .= $c;
1850        }
1851      } else {
1852        $out .= $c;
1853      }
1854    }
1855    push(@out,$out);
1856  }
1857  if ($scalar) {
1858    return $out[0];
1859  } else {
1860    return (@out);
1861  }
1862}
1863
1864# Can't be in "use integer" because we're doing decimal arithmatic
1865no integer;
1866sub Delta_Format {
1867  print "DEBUG: Delta_Format\n"  if ($Curr{"Debug"} =~ /trace/);
1868  my($delta,@arg)=@_;
1869  my($mode);
1870  if (lc($arg[0]) eq "approx") {
1871    $mode = "approx";
1872    shift(@arg);
1873  } else {
1874    $mode = "exact";
1875  }
1876  my($dec,@format) = @arg;
1877
1878  $delta=ParseDateDelta($delta);
1879  return ""  if (! $delta);
1880  my(@out,%f,$out,$c1,$c2,$scalar,$format)=();
1881  local($_)=$delta;
1882  my($y,$M,$w,$d,$h,$m,$s)=_Delta_Split($delta);
1883  # Get rid of positive signs.
1884  ($y,$M,$w,$d,$h,$m,$s)=map { 1*$_; }($y,$M,$w,$d,$h,$m,$s);
1885
1886  if (defined $dec  &&  $dec>0) {
1887    $dec="%." . ($dec*1) . "f";
1888  } else {
1889    $dec="%f";
1890  }
1891
1892  if (! wantarray) {
1893    $format=join(" ",@format);
1894    @format=($format);
1895    $scalar=1;
1896  }
1897
1898  # Length of each unit in seconds
1899  my($sl,$ml,$hl,$dl,$wl,$Ml,$yl)=();
1900  $sl = 1;
1901  $ml = $sl*60;
1902  $hl = $ml*60;
1903  $dl = $hl*24;
1904  $wl = $dl*7;
1905  $yl = $dl*365.25;
1906  $Ml = $yl/12;
1907
1908  # The decimal amount of each unit contained in all smaller units
1909  my($yd,$Md,$sd,$md,$hd,$dd,$wd)=();
1910  if ($mode eq "exact") {
1911    $yd = $M/12;
1912    $Md = 0;
1913  } else {
1914    $yd = ($M*$Ml + $w*$wl + $d*$dl + $h*$hl + $m*$ml + $s*$sl)/$yl;
1915    $Md =          ($w*$wl + $d*$dl + $h*$hl + $m*$ml + $s*$sl)/$Ml;
1916  }
1917
1918  $wd = ($d*$dl + $h*$hl + $m*$ml + $s*$sl)/$wl;
1919  $dd =          ($h*$hl + $m*$ml + $s*$sl)/$dl;
1920  $hd =                   ($m*$ml + $s*$sl)/$hl;
1921  $md =                            ($s*$sl)/$ml;
1922  $sd = 0;
1923
1924  # The amount of each unit contained in higher units.
1925  my($yh,$Mh,$sh,$mh,$hh,$dh,$wh)=();
1926  $yh = 0;
1927  $Mh = ($yh+$y)*12;
1928
1929  if ($mode eq "exact") {
1930    $wh = 0;
1931    $dh = ($wh+$w)*7;
1932  } else {
1933    $wh = ($yh+$y+$M/12)*365.25/7;
1934    $dh = ($wh+$w)*7;
1935  }
1936
1937  $hh = ($dh+$d)*24;
1938  $mh = ($hh+$h)*60;
1939  $sh = ($mh+$m)*60;
1940
1941  # Set up the formats
1942
1943  $f{"yv"} = $y;
1944  $f{"Mv"} = $M;
1945  $f{"wv"} = $w;
1946  $f{"dv"} = $d;
1947  $f{"hv"} = $h;
1948  $f{"mv"} = $m;
1949  $f{"sv"} = $s;
1950
1951  $f{"yh"} = $y+$yh;
1952  $f{"Mh"} = $M+$Mh;
1953  $f{"wh"} = $w+$wh;
1954  $f{"dh"} = $d+$dh;
1955  $f{"hh"} = $h+$hh;
1956  $f{"mh"} = $m+$mh;
1957  $f{"sh"} = $s+$sh;
1958
1959  $f{"yd"} = sprintf($dec,$y+$yd);
1960  $f{"Md"} = sprintf($dec,$M+$Md);
1961  $f{"wd"} = sprintf($dec,$w+$wd);
1962  $f{"dd"} = sprintf($dec,$d+$dd);
1963  $f{"hd"} = sprintf($dec,$h+$hd);
1964  $f{"md"} = sprintf($dec,$m+$md);
1965  $f{"sd"} = sprintf($dec,$s+$sd);
1966
1967  $f{"yt"} = sprintf($dec,$yh+$y+$yd);
1968  $f{"Mt"} = sprintf($dec,$Mh+$M+$Md);
1969  $f{"wt"} = sprintf($dec,$wh+$w+$wd);
1970  $f{"dt"} = sprintf($dec,$dh+$d+$dd);
1971  $f{"ht"} = sprintf($dec,$hh+$h+$hd);
1972  $f{"mt"} = sprintf($dec,$mh+$m+$md);
1973  $f{"st"} = sprintf($dec,$sh+$s+$sd);
1974
1975  $f{"%"}  = "%";
1976
1977  foreach $format (@format) {
1978    $format=reverse($format);
1979    $out="";
1980  PARSE: while ($format) {
1981      $c1=chop($format);
1982      if ($c1 eq "%") {
1983        $c1=chop($format);
1984        if (exists($f{$c1})) {
1985          $out .= $f{$c1};
1986          next PARSE;
1987        }
1988        $c2=chop($format);
1989        if (exists($f{"$c1$c2"})) {
1990          $out .= $f{"$c1$c2"};
1991          next PARSE;
1992        }
1993        $out .= $c1;
1994        $format .= $c2;
1995      } else {
1996        $out .= $c1;
1997      }
1998    }
1999    push(@out,$out);
2000  }
2001  if ($scalar) {
2002    return $out[0];
2003  } else {
2004    return (@out);
2005  }
2006}
2007use integer;
2008
2009sub ParseRecur {
2010  print "DEBUG: ParseRecur\n"  if ($Curr{"Debug"} =~ /trace/);
2011  Date_Init()  if (! $Curr{"InitDone"});
2012
2013  my($recur,$dateb,$date0,$date1,$flag)=@_;
2014  local($_)=$recur;
2015
2016  my($recur_0,$recur_1,@recur0,@recur1)=();
2017  my(@tmp,$tmp,$each,$num,$y,$m,$d,$w,$h,$mn,$s,$delta,$y0,$y1,$yb)=();
2018  my($yy,$n,$dd,@d,@tmp2,$date,@date,@w,@tmp3,@m,@y,$tmp2,$d2,@flags)=();
2019
2020  # $date0, $date1, $dateb, $flag : passed in (these are always the final say
2021  #                                 in determining whether a date matches a
2022  #                                 recurrence IF they are present.
2023  # $date_b, $date_0, $date_1     : if a value can be determined from the
2024  # $flag_t                         recurrence, they are stored here.
2025  #
2026  # If values can be determined from the recurrence AND are passed in, the
2027  # following are used:
2028  #    max($date0,$date_0)    i.e. the later of the two dates
2029  #    min($date1,$date_1)    i.e. the earlier of the two dates
2030  #
2031  # The base date that is used is the first one defined from
2032  #    $dateb $date_b
2033  # The base date is only used if necessary (as determined by the recur).
2034  # For example, "every other friday" requires a base date, but "2nd
2035  # friday of every month" doesn't.
2036
2037  my($date_b,$date_0,$date_1,$flag_t);
2038
2039  #
2040  # Check the arguments passed in.
2041  #
2042
2043  $date0=""  if (! defined $date0);
2044  $date1=""  if (! defined $date1);
2045  $dateb=""  if (! defined $dateb);
2046  $flag =""  if (! defined $flag);
2047
2048  if ($dateb) {
2049    $dateb=ParseDateString($dateb);
2050    return ""  if (! $dateb);
2051  }
2052  if ($date0) {
2053    $date0=ParseDateString($date0);
2054    return ""  if (! $date0);
2055  }
2056  if ($date1) {
2057    $date1=ParseDateString($date1);
2058    return ""  if (! $date1);
2059  }
2060
2061  #
2062  # Parse the recur.  $date_b, $date_0, and $date_e are values obtained
2063  # from the recur.
2064  #
2065
2066  @tmp=_Recur_Split($_);
2067
2068  if (@tmp) {
2069    ($recur_0,$recur_1,$flag_t,$date_b,$date_0,$date_1)=@tmp;
2070    $recur_0 = ""  if (! defined $recur_0);
2071    $recur_1 = ""  if (! defined $recur_1);
2072    $flag_t  = ""  if (! defined $flag_t);
2073    $date_b  = ""  if (! defined $date_b);
2074    $date_0  = ""  if (! defined $date_0);
2075    $date_1  = ""  if (! defined $date_1);
2076
2077    @recur0 = split(/:/,$recur_0);
2078    @recur1 = split(/:/,$recur_1);
2079    return ""  if ($#recur0 + $#recur1 + 2 != 7);
2080
2081    if ($date_b) {
2082      $date_b=ParseDateString($date_b);
2083      return ""  if (! $date_b);
2084    }
2085    if ($date_0) {
2086      $date_0=ParseDateString($date_0);
2087      return ""  if (! $date_0);
2088    }
2089    if ($date_1) {
2090      $date_1=ParseDateString($date_1);
2091      return ""  if (! $date_1);
2092    }
2093
2094  } else {
2095
2096    my($mmm)='\s*'.$Lang{$Cnf{"Language"}}{"Month"};  # \s*(jan|january|...)
2097    my(%mmm)=%{ $Lang{$Cnf{"Language"}}{"MonthH"} };  # { jan=>1, ... }
2098    my($wkexp)='\s*'.$Lang{$Cnf{"Language"}}{"Week"}; # \s*(mon|monday|...)
2099    my(%week)=%{ $Lang{$Cnf{"Language"}}{"WeekH"} };  # { monday=>1, ... }
2100    my($day)='\s*'.$Lang{$Cnf{"Language"}}{"Dabb"};   # \s*(?:d|day|days)
2101    my($month)='\s*'.$Lang{$Cnf{"Language"}}{"Mabb"}; # \s*(?:mon|month|months)
2102    my($week)='\s*'.$Lang{$Cnf{"Language"}}{"Wabb"};  # \s*(?:w|wk|week|weeks)
2103    my($daysexp)=$Lang{$Cnf{"Language"}}{"DoM"};      # (1st|first|...31st)
2104    my(%dayshash)=%{ $Lang{$Cnf{"Language"}}{"DoMH"} };
2105                                                      # { 1st=>1,first=>1,...}
2106    my($of)='\s*'.$Lang{$Cnf{"Language"}}{"Of"};      # \s*(?:in|of)
2107    my($lastexp)=$Lang{$Cnf{"Language"}}{"Last"};     # (?:last)
2108    my($each)=$Lang{$Cnf{"Language"}}{"Each"};        # (?:each|every)
2109
2110    my($D)='\s*(\d+)';
2111    my($Y)='\s*(\d{4}|\d{2})';
2112
2113    # Change 1st to 1
2114    if (/(^|[^a-z])$daysexp($|[^a-z])/i) {
2115      $tmp=lc($2);
2116      $tmp=$dayshash{"$tmp"};
2117      s/(^|[^a-z])$daysexp($|[^a-z])/$1 $tmp $3/i;
2118    }
2119    s/\s*$//;
2120
2121    # Get rid of "each"
2122    if (/(^|[^a-z])$each($|[^a-z])/i) {
2123      s/(^|[^a-z])$each($|[^a-z])/$1 $2/i;
2124      $each=1;
2125    } else {
2126      $each=0;
2127    }
2128
2129    if ($each) {
2130
2131      if (/^$D?$day(?:$of$mmm?$Y)?$/i ||
2132          /^$D?$day(?:$of$mmm())?$/i) {
2133        # every [2nd] day in [june] 1997
2134        # every [2nd] day [in june]
2135        ($num,$m,$y)=($1,$2,$3);
2136        $num=1 if (! defined $num);
2137        $m=""  if (! defined $m);
2138        $y=""  if (! defined $y);
2139
2140        $y=$Curr{"Y"}  if (! $y);
2141        if ($m) {
2142          $m=$mmm{lc($m)};
2143          $date_0=_Date_Join($y,$m,1,0,0,0);
2144          $date_1=_DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0);
2145        } else {
2146          $date_0=_Date_Join($y,  1,1,0,0,0);
2147          $date_1=_Date_Join($y+1,1,1,0,0,0);
2148        }
2149        $date_b=DateCalc($date_0,"-0:0:0:1:0:0:0",0);
2150        @recur0=(0,0,0,$num,0,0,0);
2151        @recur1=();
2152
2153      } elsif (/^$D$day?$of$month(?:$of?$Y)?$/) {
2154        # 2nd [day] of every month [in 1997]
2155        ($num,$y)=($1,$2);
2156        $y=$Curr{"Y"}  if (! $y);
2157
2158        $date_0=_Date_Join($y,  1,1,0,0,0);
2159        $date_1=_Date_Join($y+1,1,1,0,0,0);
2160        $date_b=$date_0;
2161
2162        @recur0=(0,1,0);
2163        @recur1=($num,0,0,0);
2164
2165      } elsif (/^$D$wkexp$of$month(?:$of?$Y)?$/ ||
2166               /^($lastexp)$wkexp$of$month(?:$of?$Y)?$/) {
2167        # 2nd tuesday of every month [in 1997]
2168        # last tuesday of every month [in 1997]
2169        ($num,$d,$y)=($1,$2,$3);
2170        $y=$Curr{"Y"}  if (! $y);
2171        $d=$week{lc($d)};
2172        $num=-1  if ($num !~ /^$D$/);
2173
2174        $date_0=_Date_Join($y,1,1,0,0,0);
2175        $date_1=_Date_Join($y+1,1,1,0,0,0);
2176        $date_b=$date_0;
2177
2178        @recur0=(0,1);
2179        @recur1=($num,$d,0,0,0);
2180
2181      } elsif (/^$D?$wkexp(?:$of$mmm?$Y)?$/i ||
2182               /^$D?$wkexp(?:$of$mmm())?$/i) {
2183        # every tuesday in june 1997
2184        # every 2nd tuesday in june 1997
2185        ($num,$d,$m,$y)=($1,$2,$3,$4);
2186        $y=$Curr{"Y"}  if (! $y);
2187        $num=1 if (! defined $num);
2188        $m=""  if (! defined $m);
2189        $d=$week{lc($d)};
2190
2191        if ($m) {
2192          $m=$mmm{lc($m)};
2193          $date_0=_Date_Join($y,$m,1,0,0,0);
2194          $date_1=_DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0);
2195        } else {
2196          $date_0=_Date_Join($y,1,1,0,0,0);
2197          $date_1=_Date_Join($y+1,1,1,0,0,0);
2198        }
2199        $date_b=DateCalc($date_0,"-0:0:0:1:0:0:0",0);
2200
2201        @recur0=(0,0,$num);
2202        @recur1=($d,0,0,0);
2203
2204      } else {
2205        return "";
2206      }
2207
2208      $date_0=""  if ($date0);
2209      $date_1=""  if ($date1);
2210    } else {
2211      return "";
2212    }
2213  }
2214
2215  #
2216  # Override with any values passed in
2217  #
2218
2219  $date0 = $date_0  if (! $date0);
2220  $date1 = $date_1  if (! $date1);
2221  $dateb = $date_b  if (! $dateb);
2222  if ($flag =~ s/^\+//) {
2223    $flag = "$flag_t,$flag"  if ($flag_t);
2224  }
2225  $flag = $flag_t  if (! $flag);
2226  $flag = ""  if (! $flag);
2227
2228  if (! wantarray) {
2229    $tmp  = join(":",@recur0);
2230    $tmp .= "*" . join(":",@recur1)  if (@recur1);
2231    $tmp .= "*$flag*$dateb*$date0*$date1";
2232    return $tmp;
2233  }
2234  if (@recur0) {
2235    return ()  if (! $date0  ||  ! $date1); # dateb is NOT required in all case
2236  }
2237
2238  #
2239  # Some flags affect parsing.
2240  #
2241
2242  @flags   = split(/,/,$flag);
2243  my($f);
2244  foreach $f (@flags) {
2245    if ($f =~ /^EASTER$/i) {
2246      ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1);
2247      # We want something that will return Jan 1 for the given years.
2248      if ($#recur0==-1) {
2249        @recur1=($y,1,0,1,$h,$mn,$s);
2250      } elsif ($#recur0<=3) {
2251        @recur0=($y,0,0,0);
2252        @recur1=($h,$mn,$s);
2253      } elsif ($#recur0==4) {
2254        @recur0=($y,0,0,0,0);
2255        @recur1=($mn,$s);
2256      } elsif ($#recur0==5) {
2257        @recur0=($y,0,0,0,0,0);
2258        @recur1=($s);
2259      } else {
2260        @recur0=($y,0,0,0,0,0,0);
2261      }
2262    }
2263  }
2264
2265  #
2266  # Determine the dates referenced by the recur.  Also, fix the base date
2267  # as necessary for the recurrences which require it.
2268  #
2269
2270  ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1);
2271  @y=@m=@w=@d=();
2272  my(@time)=($h,$mn,$s);
2273
2274 RECUR: while (1) {
2275
2276    if ($#recur0==-1) {
2277      # * 0-M-W-D-H-MN-S   => 0 * M-W-D-H-MN-S
2278
2279      if ($y eq "0") {
2280        push(@recur0,1);
2281        shift(@recur1);
2282        next RECUR;
2283      }
2284
2285      # Y-M-W-D-H-MN-S
2286
2287      @y=_ReturnList($y);
2288      foreach $y (@y) {
2289        $y=_Date_FixYear($y)  if (length($y)==2);
2290        return ()  if (length($y)!=4  ||  ! _IsInt($y));
2291      }
2292
2293      $date0=ParseDate("0000-01-01")          if (! $date0);
2294      $date1=ParseDate("9999-12-31 23:59:59") if (! $date1);
2295
2296      if ($m eq "0"  and  $w eq "0") {
2297
2298        # * Y-0-0-0-H-MN-S
2299        # * Y-0-0-DOY-H-MN-S
2300
2301        if ($d eq "0") {
2302          @d=(1);
2303        } else {
2304          @d=_ReturnList($d);
2305          return ()  if (! @d);
2306          foreach $d (@d) {
2307            return ()  if (! _IsInt($d,-366,366)  ||  $d==0);
2308          }
2309        }
2310
2311        @date=();
2312        foreach $yy (@y) {
2313          my $diy = Date_DaysInYear($yy);
2314          foreach $d (@d) {
2315            my $tmpd = $d;
2316            $tmpd += ($diy+1)  if ($tmpd < 0);
2317            next  if (! _IsInt($tmpd,1,$diy));
2318            ($y,$m,$dd)=Date_NthDayOfYear($yy,$tmpd);
2319            push(@date, _Date_Join($y,$m,$dd,0,0,0));
2320          }
2321        }
2322        last RECUR;
2323
2324      } elsif ($w eq "0") {
2325
2326        # * Y-M-0-0-H-MN-S
2327        # * Y-M-0-DOM-H-MN-S
2328
2329        @m=_ReturnList($m);
2330        return ()  if (! @m);
2331        foreach $m (@m) {
2332          return ()  if (! _IsInt($m,1,12));
2333        }
2334
2335        if ($d eq "0") {
2336          @d=(1);
2337        } else {
2338          @d=_ReturnList($d);
2339          return ()  if (! @d);
2340          foreach $d (@d) {
2341            return ()  if (! _IsInt($d,-31,31)  ||  $d==0);
2342          }
2343        }
2344
2345        @date=();
2346        foreach $y (@y) {
2347          foreach $m (@m) {
2348            my $dim = Date_DaysInMonth($m,$y);
2349            foreach $d (@d) {
2350              my $tmpd = $d;
2351              $tmpd += ($dim+1)  if ($d<0);
2352              next  if (! _IsInt($tmpd,1,$dim));
2353              $date=_Date_Join($y,$m,$tmpd,0,0,0);
2354              push(@date,$date);
2355            }
2356          }
2357        }
2358        last RECUR;
2359
2360      } elsif ($m eq "0") {
2361
2362        # * Y-0-WOY-DOW-H-MN-S
2363        # * Y-0-WOY-0-H-MN-S
2364
2365        @w=_ReturnList($w);
2366        return ()  if (! @w);
2367        foreach $w (@w) {
2368          return ()  if (! _IsInt($w,-53,53)  ||  $w==0);
2369        }
2370
2371        if ($d eq "0") {
2372          @d=(1);
2373        } else {
2374          @d=_ReturnList($d);
2375          return ()  if (! @d);
2376          foreach $d (@d) {
2377            $d += 8  if ($d<0);
2378            return ()  if (! _IsInt($d,1,7));
2379          }
2380        }
2381
2382        @date=();
2383        foreach $y (@y) {
2384          foreach $w (@w) {
2385            foreach $d (@d) {
2386              my($tmpw,$del);
2387              if ($w<0) {
2388                $date="$y-12-31-00:00:00";
2389                $tmpw = (-$w)-1;
2390                $del="-0:0:$tmpw:0:0:0:0";
2391                $date=Date_GetPrev($date,$d,1);
2392              } else {
2393                $date="$y-01-01-00:00:00";
2394                $tmpw = ($w)-1;
2395                $del="0:0:$tmpw:0:0:0:0";
2396                $date=Date_GetNext($date,$d,1);
2397              }
2398              $date=_DateCalc_DateDelta($date,$del);
2399              push(@date,$date)  if ( (_Date_Split($date))[0] == $y);
2400            }
2401          }
2402        }
2403        last RECUR;
2404
2405      } else {
2406
2407        # * Y-M-WOM-DOW-H-MN-S
2408        # * Y-M-WOM-0-H-MN-S
2409
2410        @m=_ReturnList($m);
2411        return ()  if (! @m);
2412        @w=_ReturnList($w);
2413        return ()  if (! @w);
2414        if ($d eq "0") {
2415          @d=(1);
2416        } else {
2417          @d=_ReturnList($d);
2418        }
2419
2420        @date=_Date_Recur_WoM(\@y,\@m,\@w,\@d);
2421        last RECUR;
2422      }
2423    }
2424
2425    if ($#recur0==0) {
2426
2427      # Y * M-W-D-H-MN-S
2428      $n=$y;
2429      $n=1  if ($n==0);
2430
2431      if ($m eq "0") {
2432
2433        # Y * 0-W-D-H-MN-S    => Y-0 * W-D-H-MN-S
2434        push(@recur0,0);
2435        shift(@recur1);
2436
2437      } elsif ($w eq "0") {
2438
2439        # Y * M-0-DOM-H-MN-S
2440        return ()  if (! $dateb  &&  $y != 1);
2441
2442        @m=_ReturnList($m);
2443        return ()  if (! @m);
2444        foreach $m (@m) {
2445          return ()  if (! _IsInt($m,1,12));
2446        }
2447
2448        if ($d eq "0") {
2449          @d = (1);
2450        } else {
2451          @d=_ReturnList($d);
2452          return ()  if (! @d);
2453          foreach $d (@d) {
2454            return ()  if (! _IsInt($d,-31,31)  ||  $d==0);
2455          }
2456        }
2457
2458        # We need to find years that are a multiple of $n from $y(base)
2459        ($y0)=( _Date_Split($date0, 1) )[0];
2460        ($y1)=( _Date_Split($date1, 1) )[0];
2461        if ($dateb) {
2462          ($yb)=( _Date_Split($dateb, 1) )[0];
2463        } else {
2464          # If $y=1, there is no base year
2465          $yb=0;
2466        }
2467
2468        @date=();
2469        for ($yy=$y0; $yy<=$y1; $yy++) {
2470          if (($yy-$yb)%$n == 0) {
2471            foreach $m (@m) {
2472              foreach $d (@d) {
2473                my $dim  = Date_DaysInMonth($m,$yy);
2474                my $tmpd = $d;
2475                if ($tmpd < 0) {
2476                  $tmpd += ($dim+1);
2477                }
2478                next  if (! _IsInt($tmpd,1,$dim));
2479                $date=_Date_Join($yy,$m,$tmpd,0,0,0);
2480                push(@date,$date);
2481              }
2482            }
2483          }
2484        }
2485        last RECUR;
2486
2487      } else {
2488
2489        # Y * M-WOM-DOW-H-MN-S
2490        # Y * M-WOM-0-H-MN-S
2491        return ()  if (! $dateb  &&  $y != 1);
2492
2493        @m=_ReturnList($m);
2494        return ()  if (! @m);
2495        @w=_ReturnList($w);
2496        return ()  if (! @w);
2497
2498        if ($d eq "0") {
2499          @d=(1);
2500        } else {
2501          @d=_ReturnList($d);
2502        }
2503
2504        ($y0)=( _Date_Split($date0, 1) )[0];
2505        ($y1)=( _Date_Split($date1, 1) )[0];
2506        if ($dateb) {
2507          ($yb)=( _Date_Split($dateb, 1) )[0];
2508        } else {
2509          # If $y=1, there is no base year
2510          $yb=0;
2511        }
2512        @y=();
2513        for ($yy=$y0; $yy<=$y1; $yy++) {
2514          if (($yy-$yb)%$n == 0) {
2515            push(@y,$yy);
2516          }
2517        }
2518
2519        @date=_Date_Recur_WoM(\@y,\@m,\@w,\@d);
2520        last RECUR;
2521      }
2522    }
2523
2524    if ($#recur0==1) {
2525
2526      # Y-M * W-D-H-MN-S
2527
2528      if ($w eq "0") {
2529        # Y-M * 0-D-H-MN-S   => Y-M-0 * D-H-MN-S
2530        push(@recur0,0);
2531        shift(@recur1);
2532
2533      } elsif ($m==0) {
2534
2535        # Y-0 * WOY-0-H-MN-S
2536        # Y-0 * WOY-DOW-H-MN-S
2537        return ()  if (! $dateb  &&  $y != 1);
2538        $n=$y;
2539        $n=1  if ($n==0);
2540
2541        @w=_ReturnList($w);
2542        return ()  if (! @w);
2543        foreach $w (@w) {
2544          return ()  if ($w==0  ||  ! _IsInt($w,-53,53));
2545        }
2546
2547        if ($d eq "0") {
2548          @d=(1);
2549        } else {
2550          @d=_ReturnList($d);
2551          return ()  if (! @d);
2552          foreach $d (@d) {
2553            $d += 8  if ($d<0);
2554            return ()  if (! _IsInt($d,1,7));
2555          }
2556        }
2557
2558        # We need to find years that are a multiple of $n from $y(base)
2559        ($y0)=( _Date_Split($date0, 1) )[0];
2560        ($y1)=( _Date_Split($date1, 1) )[0];
2561        if ($dateb) {
2562          ($yb)=( _Date_Split($dateb, 1) )[0];
2563        } else {
2564          # If $y=1, there is no base year
2565          $yb=0;
2566        }
2567
2568        @date=();
2569        for ($yy=$y0; $yy<=$y1; $yy++) {
2570          if (($yy-$yb)%$n == 0) {
2571            foreach $w (@w) {
2572              foreach $d (@d) {
2573                my($tmpw,$del);
2574                if ($w<0) {
2575                  $date="$yy-12-31-00:00:00";
2576                  $tmpw = (-$w)-1;
2577                  $del="-0:0:$tmpw:0:0:0:0";
2578                  $date=Date_GetPrev($date,$d,1);
2579                } else {
2580                  $date="$yy-01-01-00:00:00";
2581                  $tmpw = ($w)-1;
2582                  $del="0:0:$tmpw:0:0:0:0";
2583                  $date=Date_GetNext($date,$d,1);
2584                }
2585                $date=DateCalc($date,$del);
2586                next  if ((_Date_Split($date))[0] != $yy);
2587                push(@date,$date);
2588              }
2589            }
2590          }
2591        }
2592        last RECUR;
2593
2594      } else {
2595
2596        # Y-M * WOM-0-H-MN-S
2597        # Y-M * WOM-DOW-H-MN-S
2598        return ()  if (! $dateb  &&  ($y != 0  ||  $m != 1));
2599        @tmp=(@recur0);
2600        push(@tmp,0)  while ($#tmp<6);
2601        $delta=join(":",@tmp);
2602        $dateb=$date0  if (! $dateb);
2603        @tmp=_Date_Recur($date0,$date1,$dateb,$delta);
2604
2605        @w=_ReturnList($w);
2606        @m=();
2607        if ($d eq "0") {
2608          @d=(1);
2609        } else {
2610          @d=_ReturnList($d);
2611        }
2612
2613        @date=_Date_Recur_WoM(\@tmp,\@m,\@w,\@d);
2614        last RECUR;
2615      }
2616    }
2617
2618    if ($#recur0==2) {
2619      # Y-M-W * D-H-MN-S
2620
2621      if ($d eq "0") {
2622
2623        # Y-M-W * 0-H-MN-S
2624        return ()  if (! $dateb);
2625        $y=1  if ($y==0 && $m==0 && $w==0);
2626        $delta="$y:$m:$w:0:0:0:0";
2627        @date=_Date_Recur($date0,$date1,$dateb,$delta);
2628        last RECUR;
2629
2630      } elsif ($m==0 && $w==0) {
2631
2632        # Y-0-0 * DOY-H-MN-S
2633        $y=1  if ($y==0);
2634        $n=$y;
2635        return ()  if (! $dateb  &&  $y!=1);
2636
2637        @d=_ReturnList($d);
2638        return ()  if (! @d);
2639        foreach $d (@d) {
2640          return ()  if (! _IsInt($d,-366,366)  ||  $d==0);
2641        }
2642
2643        # We need to find years that are a multiple of $n from $y(base)
2644        ($y0)=( _Date_Split($date0, 1) )[0];
2645        ($y1)=( _Date_Split($date1, 1) )[0];
2646        if ($dateb) {
2647          ($yb)=( _Date_Split($dateb, 1) )[0];
2648        } else {
2649          # If $y=1, there is no base year
2650          $yb=0;
2651        }
2652        @date=();
2653        for ($yy=$y0; $yy<=$y1; $yy++) {
2654          my $diy = Date_DaysInYear($yy);
2655          if (($yy-$yb)%$n == 0) {
2656            foreach $d (@d) {
2657              my $tmpd = $d;
2658              $tmpd += ($diy+1)  if ($tmpd<0);
2659              next  if (! _IsInt($tmpd,1,$diy));
2660              ($y,$m,$dd)=Date_NthDayOfYear($yy,$tmpd);
2661              push(@date, _Date_Join($y,$m,$dd,0,0,0));
2662            }
2663          }
2664        }
2665        last RECUR;
2666
2667      } elsif ($w>0) {
2668
2669        # Y-M-W * DOW-H-MN-S
2670        return ()  if (! $dateb  &&  ($y != 0  &&  $m != 0  &&  $w != 1));
2671        @tmp=(@recur0);
2672        push(@tmp,0)  while ($#tmp<6);
2673        $delta=join(":",@tmp);
2674
2675        @d=_ReturnList($d);
2676        return ()  if (! @d);
2677        foreach $d (@d) {
2678          $d += 8  if ($d<0);
2679          return ()  if (! _IsInt($d,1,7));
2680        }
2681
2682        # Find out what DofW the basedate is.
2683        $dateb = $date0  if (! $dateb);
2684        @tmp2=_Date_Split($dateb, 1);
2685        $tmp=Date_DayOfWeek($tmp2[1],$tmp2[2],$tmp2[0]);
2686
2687        @date=();
2688        foreach $d (@d) {
2689          $date_b=$dateb;
2690          # Move basedate to DOW in the same week
2691          if ($d != $tmp) {
2692            if (($tmp>=$Cnf{"FirstDay"} && $d<$Cnf{"FirstDay"}) ||
2693                ($tmp>=$Cnf{"FirstDay"} && $d>$tmp) ||
2694                ($tmp<$d && $d<$Cnf{"FirstDay"})) {
2695              $date_b=Date_GetNext($date_b,$d);
2696            } else {
2697              $date_b=Date_GetPrev($date_b,$d);
2698            }
2699          }
2700          push(@date,_Date_Recur($date0,$date1,$date_b,$delta));
2701        }
2702        last RECUR;
2703
2704      } elsif ($m>0) {
2705
2706        # Y-M-0 * DOM-H-MN-S
2707        return ()  if (! $dateb  &&  ($y != 0  &&  $m != 1));
2708        @tmp=(@recur0);
2709        push(@tmp,0)  while ($#tmp<6);
2710        $delta=join(":",@tmp);
2711
2712        @d=_ReturnList($d);
2713        return ()  if (! @d);
2714        foreach $d (@d) {
2715          return ()  if ($d==0  ||  ! _IsInt($d,-31,31));
2716        }
2717        $dateb = $date0  if (! $dateb);
2718
2719        @tmp2=_Date_Recur($date0,$date1,$dateb,$delta);
2720        @date=();
2721        foreach $date (@tmp2) {
2722          ($y,$m)=( _Date_Split($date, 1) )[0..1];
2723          my $dim=Date_DaysInMonth($m,$y);
2724          foreach $d (@d) {
2725            my $tmpd = $d;
2726            $tmpd += ($dim+1)  if ($tmpd<0);
2727            next  if (! _IsInt($tmpd,1,$dim));
2728            push(@date,_Date_Join($y,$m,$tmpd,0,0,0));
2729          }
2730        }
2731        last RECUR;
2732
2733      } else {
2734        return ();
2735      }
2736    }
2737
2738    if ($#recur0>2) {
2739
2740      # Y-M-W-D * H-MN-S
2741      # Y-M-W-D-H * MN-S
2742      # Y-M-W-D-H-MN * S
2743      # Y-M-W-D-H-S
2744      if (($#recur0 == 3  &&
2745           ($y == 0  &&  $m == 0  &&  $w == 0  &&  $d == 1)) ||
2746          ($#recur0 == 4  &&
2747           ($y == 0  &&  $m == 0  &&  $w == 0  &&  $d == 0  &&  $h == 1)) ||
2748          ($#recur0 == 5  &&
2749           ($y == 0  &&  $m == 0  &&  $w == 0  &&  $d == 0  &&  $h == 0  &&
2750            $mn == 1))) {
2751         $dateb = $date0;
2752      }
2753      return ()  if (! $dateb);
2754      @tmp=(@recur0);
2755      push(@tmp,0)  while ($#tmp<6);
2756      $delta=join(":",@tmp);
2757      return ()  if ($delta !~ /[1-9]/); # return if "0:0:0:0:0:0:0"
2758      @date=_Date_Recur($date0,$date1,$dateb,$delta);
2759      if (@recur1) {
2760        unshift(@recur1,-1)  while ($#recur1<2);
2761        @time=@recur1;
2762      } else {
2763        shift(@date);
2764        pop(@date);
2765        @time=();
2766      }
2767    }
2768
2769    last RECUR;
2770  }
2771  @date=_Date_RecurSetTime($date0,$date1,\@date,@time)  if (@time);
2772
2773  #
2774  # We've got a list of dates.  Operate on them with the flags.
2775  #
2776
2777  my($sign,$forw,$today,$df,$db,$work,$i);
2778  if (@flags) {
2779  FLAG: foreach $f (@flags) {
2780      $f = uc($f);
2781
2782      if ($f =~ /^(P|N)(D|T)([1-7])$/) {
2783        @tmp=($1,$2,$3);
2784        $forw =($tmp[0] eq "P" ? 0 : 1);
2785        $today=($tmp[1] eq "D" ? 0 : 1);
2786        $d=$tmp[2];
2787        @tmp=();
2788        foreach $date (@date) {
2789          if ($forw) {
2790            push(@tmp, Date_GetNext($date,$d,$today));
2791          } else {
2792            push(@tmp, Date_GetPrev($date,$d,$today));
2793          }
2794        }
2795        @date=@tmp;
2796        next FLAG;
2797      }
2798
2799      # We want to go forward exact amounts of time instead of
2800      # business mode calculations so that we don't change the time
2801      # (which may have been set in the recur).
2802      if ($f =~ /^(F|B)(D|W)(\d+)$/) {
2803        @tmp=($1,$2,$3);
2804        $sign="+";
2805        $sign="-"  if ($tmp[0] eq "B");
2806        $work=0;
2807        $work=1    if ($tmp[1] eq "W");
2808        $n=$tmp[2];
2809        @tmp=();
2810        foreach $date (@date) {
2811          for ($i=1; $i<=$n; $i++) {
2812            while (1) {
2813              $date=DateCalc($date,"${sign}0:0:0:1:0:0:0");
2814              last if (! $work  ||  Date_IsWorkDay($date,0));
2815            }
2816          }
2817          push(@tmp,$date);
2818        }
2819        @date=@tmp;
2820        next FLAG;
2821      }
2822
2823      if ($f =~ /^CW(N|P|D)$/ || $f =~ /^(N|P|D)W(D)$/) {
2824        $tmp=$1;
2825        my $noalt = $2 ? 1 : 0;
2826        if ($tmp eq "N"  ||  ($tmp eq "D" && $Cnf{"TomorrowFirst"})) {
2827          $forw=1;
2828        } else {
2829          $forw=0;
2830        }
2831
2832        @tmp=();
2833      DATE: foreach $date (@date) {
2834          $df=$db=$date;
2835          if (Date_IsWorkDay($date)) {
2836            push(@tmp,$date);
2837            next DATE;
2838          }
2839          while (1) {
2840            if ($forw) {
2841              $d=$df=DateCalc($df,"+0:0:0:1:0:0:0");
2842            } else {
2843              $d=$db=DateCalc($db,"-0:0:0:1:0:0:0");
2844            }
2845            if (Date_IsWorkDay($d)) {
2846              push(@tmp,$d);
2847              next DATE;
2848            }
2849            $forw=1-$forw  if (! $noalt);
2850          }
2851        }
2852        @date=@tmp;
2853        next FLAG;
2854      }
2855
2856      if ($f eq "EASTER") {
2857        @tmp=();
2858        foreach $date (@date) {
2859          ($y,$m,$d,$h,$mn,$s)=_Date_Split($date, 1);
2860          ($m,$d)=_Date_Easter($y);
2861          $date=_Date_Join($y,$m,$d,$h,$mn,$s);
2862          next  if (Date_Cmp($date,$date0)<0  ||
2863                    Date_Cmp($date,$date1)>0);
2864          push(@tmp,$date);
2865        }
2866        @date=@tmp;
2867      }
2868    }
2869  }
2870
2871  @date = sort { Date_Cmp($a,$b) } @date;
2872  return @date;
2873}
2874
2875sub Date_GetPrev {
2876  print "DEBUG: Date_GetPrev\n"  if ($Curr{"Debug"} =~ /trace/);
2877  my($date,$dow,$today,$hr,$min,$sec)=@_;
2878  Date_Init()  if (! $Curr{"InitDone"});
2879  my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts,
2880     $adjust,$curr)=();
2881  $hr="00"   if (defined $hr   &&  $hr eq "0");
2882  $min="00"  if (defined $min  &&  $min eq "0");
2883  $sec="00"  if (defined $sec  &&  $sec eq "0");
2884
2885  if (! _Date_Split($date)) {
2886    $date=ParseDateString($date);
2887    return ""  if (! $date);
2888  }
2889  $curr=$date;
2890  ($y,$m,$d)=( _Date_Split($date, 1) )[0..2];
2891
2892  if ($dow) {
2893    $curr_dow=Date_DayOfWeek($m,$d,$y);
2894    %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} };
2895    if (_IsInt($dow)) {
2896      return ""  if ($dow<1  ||  $dow>7);
2897    } else {
2898      return ""  if (! exists $dow{lc($dow)});
2899      $dow=$dow{lc($dow)};
2900    }
2901    if ($dow == $curr_dow) {
2902      $date=_DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0)  if (! $today);
2903      $adjust=1  if ($today==2);
2904    } else {
2905      $dow -= 7  if ($dow>$curr_dow); # make sure previous day is less
2906      $num = $curr_dow - $dow;
2907      $date=_DateCalc_DateDelta($date,"-0:0:0:$num:0:0:0",\$err,0);
2908    }
2909    $date=Date_SetTime($date,$hr,$min,$sec)  if (defined $hr);
2910    $date=_DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0)
2911      if ($adjust  &&  Date_Cmp($date,$curr)>0);
2912
2913  } else {
2914    ($h,$mn,$s)=( _Date_Split($date, 1) )[3..5];
2915    ($th,$tm,$ts)=_Date_ParseTime($hr,$min,$sec);
2916    if ($hr) {
2917      ($hr,$min,$sec)=($th,$tm,$ts);
2918      $delta="-0:0:0:1:0:0:0";
2919    } elsif ($min) {
2920      ($hr,$min,$sec)=($h,$tm,$ts);
2921      $delta="-0:0:0:0:1:0:0";
2922    } elsif ($sec) {
2923      ($hr,$min,$sec)=($h,$mn,$ts);
2924      $delta="-0:0:0:0:0:1:0";
2925    } else {
2926      confess "ERROR: invalid arguments in Date_GetPrev.\n";
2927    }
2928
2929    $d=Date_SetTime($date,$hr,$min,$sec);
2930    if ($today) {
2931      $d=_DateCalc_DateDelta($d,$delta,\$err,0)  if (Date_Cmp($d,$date)>0);
2932    } else {
2933      $d=_DateCalc_DateDelta($d,$delta,\$err,0)  if (Date_Cmp($d,$date)>=0);
2934    }
2935    $date=$d;
2936  }
2937  return $date;
2938}
2939
2940sub Date_GetNext {
2941  print "DEBUG: Date_GetNext\n"  if ($Curr{"Debug"} =~ /trace/);
2942  my($date,$dow,$today,$hr,$min,$sec)=@_;
2943  Date_Init()  if (! $Curr{"InitDone"});
2944  my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts,
2945     $adjust,$curr)=();
2946  $hr="00"   if (defined $hr   &&  $hr eq "0");
2947  $min="00"  if (defined $min  &&  $min eq "0");
2948  $sec="00"  if (defined $sec  &&  $sec eq "0");
2949
2950  if (! _Date_Split($date)) {
2951    $date=ParseDateString($date);
2952    return ""  if (! $date);
2953  }
2954  $curr=$date;
2955  ($y,$m,$d)=( _Date_Split($date, 1) )[0..2];
2956
2957  if ($dow) {
2958    $curr_dow=Date_DayOfWeek($m,$d,$y);
2959    %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} };
2960    if (_IsInt($dow)) {
2961      return ""  if ($dow<1  ||  $dow>7);
2962    } else {
2963      return ""  if (! exists $dow{lc($dow)});
2964      $dow=$dow{lc($dow)};
2965    }
2966    if ($dow == $curr_dow) {
2967      $date=_DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0)  if (! $today);
2968      $adjust=1  if ($today==2);
2969    } else {
2970      $curr_dow -= 7  if ($curr_dow>$dow); # make sure next date is greater
2971      $num = $dow - $curr_dow;
2972      $date=_DateCalc_DateDelta($date,"+0:0:0:$num:0:0:0",\$err,0);
2973    }
2974    $date=Date_SetTime($date,$hr,$min,$sec)  if (defined $hr);
2975    $date=_DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0)
2976      if ($adjust  &&  Date_Cmp($date,$curr)<0);
2977
2978  } else {
2979    ($h,$mn,$s)=( _Date_Split($date, 1) )[3..5];
2980    ($th,$tm,$ts)=_Date_ParseTime($hr,$min,$sec);
2981    if ($hr) {
2982      ($hr,$min,$sec)=($th,$tm,$ts);
2983      $delta="+0:0:0:1:0:0:0";
2984    } elsif ($min) {
2985      ($hr,$min,$sec)=($h,$tm,$ts);
2986      $delta="+0:0:0:0:1:0:0";
2987    } elsif ($sec) {
2988      ($hr,$min,$sec)=($h,$mn,$ts);
2989      $delta="+0:0:0:0:0:1:0";
2990    } else {
2991      confess "ERROR: invalid arguments in Date_GetNext.\n";
2992    }
2993
2994    $d=Date_SetTime($date,$hr,$min,$sec);
2995    if ($today) {
2996      $d=_DateCalc_DateDelta($d,$delta,\$err,0)  if (Date_Cmp($d,$date)<0);
2997    } else {
2998      $d=_DateCalc_DateDelta($d,$delta,\$err,0)  if (Date_Cmp($d,$date)<1);
2999    }
3000    $date=$d;
3001  }
3002
3003  return $date;
3004}
3005
3006sub Date_IsHoliday {
3007  print "DEBUG: Date_IsHoliday\n"  if ($Curr{"Debug"} =~ /trace/);
3008  my($date)=@_;
3009  Date_Init()  if (! $Curr{"InitDone"});
3010  $date=ParseDateString($date);
3011  return undef  if (! $date);
3012  $date=Date_SetTime($date,0,0,0);
3013  my($y)=(_Date_Split($date, 1))[0];
3014  _Date_UpdateHolidays($y)  if (! exists $Holiday{"dates"}{$y});
3015  return undef  if (! exists $Holiday{"dates"}{$y}{$date});
3016  my($name)=$Holiday{"dates"}{$y}{$date};
3017  return ""   if (! $name);
3018  $name;
3019}
3020
3021sub Events_List {
3022  print "DEBUG: Events_List\n"  if ($Curr{"Debug"} =~ /trace/);
3023  my(@args)=@_;
3024  Date_Init()  if (! $Curr{"InitDone"});
3025  _Events_ParseRaw();
3026
3027  my($tmp,$date0,$date1,$flag);
3028  $date0=ParseDateString($args[0]);
3029  warn "Invalid date $args[0]", return undef  if (! $date0);
3030
3031  if ($#args == 0) {
3032    return _Events_Calc($date0);
3033  }
3034
3035  if ($args[1]) {
3036    $date1=ParseDateString($args[1]);
3037    warn "Invalid date $args[1]\n", return undef  if (! $date1);
3038    if (Date_Cmp($date0,$date1)>0) {
3039      $tmp=$date1;
3040      $date1=$date0;
3041      $date0=$tmp;
3042    }
3043  } else {
3044    $date0=Date_SetTime($date0,"00:00:00");
3045    $date1=_DateCalc_DateDelta($date0,"+0:0:0:1:0:0:0");
3046  }
3047
3048  $tmp=_Events_Calc($date0,$date1);
3049
3050  $flag=$args[2];
3051  return $tmp  if (! $flag);
3052
3053  my(@tmp,%ret,$delta)=();
3054  @tmp=@$tmp;
3055  push(@tmp,$date1);
3056
3057  if ($flag==1) {
3058    while ($#tmp>0) {
3059      ($date0,$tmp)=splice(@tmp,0,2);
3060      $date1=$tmp[0];
3061      $delta=_DateCalc_DateDate($date0,$date1);
3062      foreach $flag (@$tmp) {
3063        if (exists $ret{$flag}) {
3064          $ret{$flag}=_DateCalc_DeltaDelta($ret{$flag},$delta);
3065        } else {
3066          $ret{$flag}=$delta;
3067        }
3068      }
3069    }
3070    return \%ret;
3071
3072  } elsif ($flag==2) {
3073    while ($#tmp>0) {
3074      ($date0,$tmp)=splice(@tmp,0,2);
3075      $date1=$tmp[0];
3076      $delta=_DateCalc_DateDate($date0,$date1);
3077      $flag=join("+",sort { Date_Cmp($a,$b) } @$tmp);
3078      next  if (! $flag);
3079      if (exists $ret{$flag}) {
3080        $ret{$flag}=_DateCalc_DeltaDelta($ret{$flag},$delta);
3081      } else {
3082        $ret{$flag}=$delta;
3083      }
3084    }
3085    return \%ret;
3086  }
3087
3088  warn "Invalid flag $flag\n";
3089  return undef;
3090}
3091
3092###
3093# NOTE: The following routines may be called in the routines below with very
3094#       little time penalty.
3095###
3096sub Date_SetTime {
3097  print "DEBUG: Date_SetTime\n"  if ($Curr{"Debug"} =~ /trace/);
3098  my($date,$h,$mn,$s)=@_;
3099  Date_Init()  if (! $Curr{"InitDone"});
3100  my($y,$m,$d)=();
3101
3102  if (! _Date_Split($date)) {
3103    $date=ParseDateString($date);
3104    return ""  if (! $date);
3105  }
3106
3107  ($y,$m,$d)=( _Date_Split($date, 1) )[0..2];
3108  ($h,$mn,$s)=_Date_ParseTime($h,$mn,$s);
3109
3110  my($ampm,$wk);
3111  return ""  if (_Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk));
3112  _Date_Join($y,$m,$d,$h,$mn,$s);
3113}
3114
3115sub Date_SetDateField {
3116  print "DEBUG: Date_SetDateField\n"  if ($Curr{"Debug"} =~ /trace/);
3117  my($date,$field,$val,$nocheck)=@_;
3118  my($y,$m,$d,$h,$mn,$s)=();
3119  $nocheck=0  if (! defined $nocheck);
3120
3121  ($y,$m,$d,$h,$mn,$s)=_Date_Split($date);
3122
3123  if (! $y) {
3124    $date=ParseDateString($date);
3125    return "" if (! $date);
3126    ($y,$m,$d,$h,$mn,$s)=_Date_Split($date, 1);
3127  }
3128
3129  if      (lc($field) eq "y") {
3130    $y=$val;
3131  } elsif (lc($field) eq "m") {
3132    $m=$val;
3133  } elsif (lc($field) eq "d") {
3134    $d=$val;
3135  } elsif (lc($field) eq "h") {
3136    $h=$val;
3137  } elsif (lc($field) eq "mn") {
3138    $mn=$val;
3139  } elsif (lc($field) eq "s") {
3140    $s=$val;
3141  } else {
3142    confess "ERROR: Date_SetDateField: invalid field: $field\n";
3143  }
3144
3145  $date=_Date_Join($y,$m,$d,$h,$mn,$s);
3146  return $date  if ($nocheck  ||  _Date_Split($date));
3147  return "";
3148}
3149
3150########################################################################
3151# OTHER SUBROUTINES
3152########################################################################
3153# NOTE: These routines should not call any of the routines above as
3154#       there will be a severe time penalty (and the possibility of
3155#       infinite recursion).  The last couple routines above are
3156#       exceptions.
3157# NOTE: Date_Init is a special case.  It should be called (conditionally)
3158#       in every routine that uses any variable from the Date::Manip
3159#       namespace.
3160########################################################################
3161
3162sub Date_DaysInMonth {
3163  print "DEBUG: Date_DaysInMonth\n"  if ($Curr{"Debug"} =~ /trace/);
3164  my($m,$y)=@_;
3165  $y=_Date_FixYear($y)  if (length($y)!=4);
3166  my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31);
3167  $d_in_m[2]=29  if (Date_LeapYear($y));
3168  return $d_in_m[$m];
3169}
3170
3171sub Date_DayOfWeek {
3172  print "DEBUG: Date_DayOfWeek\n"  if ($Curr{"Debug"} =~ /trace/);
3173  my($m,$d,$y)=@_;
3174  $y=_Date_FixYear($y)  if (length($y)!=4);
3175  my($dayofweek,$dec31)=();
3176
3177  $dec31=5;                     # Dec 31, 1BC was Friday
3178  $dayofweek=(Date_DaysSince1BC($m,$d,$y)+$dec31) % 7;
3179  $dayofweek=7  if ($dayofweek==0);
3180  return $dayofweek;
3181}
3182
3183# Can't be in "use integer" because the numbers are too big.
3184no integer;
3185sub Date_SecsSince1970 {
3186  print "DEBUG: Date_SecsSince1970\n"  if ($Curr{"Debug"} =~ /trace/);
3187  my($m,$d,$y,$h,$mn,$s)=@_;
3188  $y=_Date_FixYear($y)  if (length($y)!=4);
3189  my($sec_now,$sec_70)=();
3190  $sec_now=(Date_DaysSince1BC($m,$d,$y)-1)*24*3600 + $h*3600 + $mn*60 + $s;
3191# $sec_70 =(Date_DaysSince1BC(1,1,1970)-1)*24*3600;
3192  $sec_70 =62167219200;
3193  return ($sec_now-$sec_70);
3194}
3195
3196sub Date_SecsSince1970GMT {
3197  print "DEBUG: Date_SecsSince1970GMT\n"  if ($Curr{"Debug"} =~ /trace/);
3198  my($m,$d,$y,$h,$mn,$s)=@_;
3199  Date_Init()  if (! $Curr{"InitDone"});
3200  $y=_Date_FixYear($y)  if (length($y)!=4);
3201
3202  my($sec)=Date_SecsSince1970($m,$d,$y,$h,$mn,$s);
3203  return $sec   if ($Cnf{"ConvTZ"} eq "IGNORE");
3204
3205  my($tz)=$Cnf{"ConvTZ"};
3206  $tz=$Cnf{"TZ"}  if (! $tz);
3207  $tz=$Zone{"n2o"}{lc($tz)}  if ($tz !~ /^[+-]\d{4}$/);
3208
3209  my($tzs)=1;
3210  $tzs=-1 if ($tz<0);
3211  $tz=~/.(..)(..)/;
3212  my($tzh,$tzm)=($1,$2);
3213  $sec - $tzs*($tzh*3600+$tzm*60);
3214}
3215use integer;
3216
3217sub Date_DaysSince1BC {
3218  print "DEBUG: Date_DaysSince1BC\n"  if ($Curr{"Debug"} =~ /trace/);
3219  my($m,$d,$y)=@_;
3220  $y=_Date_FixYear($y)  if (length($y)!=4);
3221  my($Ny,$N4,$N100,$N400,$dayofyear,$days)=();
3222  my($cc,$yy)=();
3223
3224  $y=~ /(\d{2})(\d{2})/;
3225  ($cc,$yy)=($1,$2);
3226
3227  # Number of full years since Dec 31, 1BC (counting the year 0000).
3228  $Ny=$y;
3229
3230  # Number of full 4th years (incl. 0000) since Dec 31, 1BC
3231  $N4=($Ny-1)/4 + 1;
3232  $N4=0         if ($y==0);
3233
3234  # Number of full 100th years (incl. 0000)
3235  $N100=$cc + 1;
3236  $N100--       if ($yy==0);
3237  $N100=0       if ($y==0);
3238
3239  # Number of full 400th years (incl. 0000)
3240  $N400=($N100-1)/4 + 1;
3241  $N400=0       if ($y==0);
3242
3243  $dayofyear=Date_DayOfYear($m,$d,$y);
3244  $days= $Ny*365 + $N4 - $N100 + $N400 + $dayofyear;
3245
3246  return $days;
3247}
3248
3249sub Date_DayOfYear {
3250  print "DEBUG: Date_DayOfYear\n"  if ($Curr{"Debug"} =~ /trace/);
3251  my($m,$d,$y)=@_;
3252  $y=_Date_FixYear($y)  if (length($y)!=4);
3253  # DinM    = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
3254  my(@days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365);
3255  my($ly)=0;
3256  $ly=1  if ($m>2 && Date_LeapYear($y));
3257  return ($days[$m-1]+$d+$ly);
3258}
3259
3260sub Date_DaysInYear {
3261  print "DEBUG: Date_DaysInYear\n"  if ($Curr{"Debug"} =~ /trace/);
3262  my($y)=@_;
3263  $y=_Date_FixYear($y)  if (length($y)!=4);
3264  return 366  if (Date_LeapYear($y));
3265  return 365;
3266}
3267
3268sub Date_WeekOfYear {
3269  print "DEBUG: Date_WeekOfYear\n"  if ($Curr{"Debug"} =~ /trace/);
3270  my($m,$d,$y,$f)=@_;
3271  Date_Init()  if (! $Curr{"InitDone"});
3272  $y=_Date_FixYear($y)  if (length($y)!=4);
3273
3274  my($day,$dow,$doy)=();
3275  $doy=Date_DayOfYear($m,$d,$y);
3276
3277  # The current DayOfYear and DayOfWeek
3278  if ($Cnf{"Jan1Week1"}) {
3279    $day=1;
3280  } else {
3281    $day=4;
3282  }
3283  $dow=Date_DayOfWeek(1,$day,$y);
3284
3285  # Move back to the first day of week 1.
3286  $f-=7  if ($f>$dow);
3287  $day-= ($dow-$f);
3288
3289  return 0  if ($day>$doy);      # Day is in last week of previous year
3290  return (($doy-$day)/7 + 1);
3291}
3292
3293sub Date_LeapYear {
3294  print "DEBUG: Date_LeapYear\n"  if ($Curr{"Debug"} =~ /trace/);
3295  my($y)=@_;
3296  $y=_Date_FixYear($y)  if (length($y)!=4);
3297  return 0 unless $y % 4 == 0;
3298  return 1 unless $y % 100 == 0;
3299  return 0 unless $y % 400 == 0;
3300  return 1;
3301}
3302
3303sub Date_DaySuffix {
3304  print "DEBUG: Date_DaySuffix\n"  if ($Curr{"Debug"} =~ /trace/);
3305  my($d)=@_;
3306  Date_Init()  if (! $Curr{"InitDone"});
3307  return $Lang{$Cnf{"Language"}}{"DoML"}[$d-1];
3308}
3309
3310sub Date_ConvTZ {
3311  print "DEBUG: Date_ConvTZ\n"  if ($Curr{"Debug"} =~ /trace/);
3312  my($date,$from,$to,$level)=@_;
3313  if (not _Date_Split($date)) {
3314    my $err = "date passed in ('$date') is not a Date::Manip object";
3315    if (! $level) {
3316      croak $err;
3317    } elsif ($level==1) {
3318      carp $err;
3319    }
3320    return "";
3321  }
3322
3323  Date_Init()  if (! $Curr{"InitDone"});
3324  my($gmt)=();
3325
3326  if (! $from) {
3327
3328    if (! $to) {
3329      # TZ -> ConvTZ
3330      return $date  if ($Cnf{"ConvTZ"} eq "IGNORE" or ! $Cnf{"ConvTZ"});
3331      $from=$Cnf{"TZ"};
3332      $to=$Cnf{"ConvTZ"};
3333
3334    } else {
3335      # ConvTZ,TZ -> $to
3336      $from=$Cnf{"ConvTZ"};
3337      $from=$Cnf{"TZ"}  if (! $from);
3338    }
3339
3340  } else {
3341
3342    if (! $to) {
3343      # $from -> ConvTZ,TZ
3344      return $date  if ($Cnf{"ConvTZ"} eq "IGNORE");
3345      $to=$Cnf{"ConvTZ"};
3346      $to=$Cnf{"TZ"}  if (! $to);
3347
3348    } else {
3349      # $from -> $to
3350    }
3351  }
3352
3353  $to=$Zone{"n2o"}{lc($to)}
3354    if (exists $Zone{"n2o"}{lc($to)});
3355  $from=$Zone{"n2o"}{lc($from)}
3356    if (exists $Zone{"n2o"}{lc($from)});
3357  $gmt=$Zone{"n2o"}{"gmt"};
3358
3359  return $date  if ($from !~ /^[+-]\d{4}$/ or $to !~ /^[+-]\d{4}$/);
3360  return $date  if ($from eq $to);
3361
3362  my($s1,$h1,$m1,$s2,$h2,$m2,$d,$h,$m,$sign,$delta,$err,$yr,$mon,$sec)=();
3363  # We're going to try to do the calculation without calling DateCalc.
3364  ($yr,$mon,$d,$h,$m,$sec)=_Date_Split($date, 1);
3365
3366  # Convert $date from $from to GMT
3367  $from=~/([+-])(\d{2})(\d{2})/;
3368  ($s1,$h1,$m1)=($1,$2,$3);
3369  $s1= ($s1 eq "-" ? "+" : "-");   # switch sign
3370  $sign=$s1 . "1";     # + or - 1
3371
3372  # and from GMT to $to
3373  $to=~/([+-])(\d{2})(\d{2})/;
3374  ($s2,$h2,$m2)=($1,$2,$3);
3375
3376  if ($s1 eq $s2) {
3377    # Both the same sign
3378    $m+= $sign*($m1+$m2);
3379    $h+= $sign*($h1+$h2);
3380  } else {
3381    $sign=($s2 eq "-" ? +1 : -1)  if ($h1<$h2  ||  ($h1==$h2 && $m1<$m2));
3382    $m+= $sign*($m1-$m2);
3383    $h+= $sign*($h1-$h2);
3384  }
3385
3386  if ($m>59) {
3387    $h+= $m/60;
3388    $m-= ($m/60)*60;
3389  } elsif ($m<0) {
3390    $h+= ($m/60 - 1);
3391    $m-= ($m/60 - 1)*60;
3392  }
3393
3394  if ($h>23) {
3395    $delta=$h/24;
3396    $h -= $delta*24;
3397    if (($d + $delta) > 28) {
3398      $date=_Date_Join($yr,$mon,$d,$h,$m,$sec);
3399      return _DateCalc_DateDelta($date,"+0:0:0:$delta:0:0:0",\$err,0);
3400    }
3401    $d+= $delta;
3402  } elsif ($h<0) {
3403    $delta=-$h/24 + 1;
3404    $h += $delta*24;
3405    if (($d - $delta) < 1) {
3406      $date=_Date_Join($yr,$mon,$d,$h,$m,$sec);
3407      return _DateCalc_DateDelta($date,"-0:0:0:$delta:0:0:0",\$err,0);
3408    }
3409    $d-= $delta;
3410  }
3411  return _Date_Join($yr,$mon,$d,$h,$m,$sec);
3412}
3413
3414sub Date_TimeZone {
3415  print "DEBUG: Date_TimeZone\n"  if ($Curr{"Debug"} =~ /trace/);
3416  my($null,$tz,@tz,$std,$dst,$time,$isdst,$tmp,$in)=();
3417  Date_Init()  if (! $Curr{"InitDone"});
3418
3419  # Get timezones from all of the relevant places
3420
3421  push(@tz,$Cnf{"TZ"})  if (defined $Cnf{"TZ"});  # TZ config var
3422  push(@tz,$ENV{"TZ"})  if (defined $ENV{"TZ"});  # TZ environ var
3423  push(@tz,$ENV{'SYS$TIMEZONE_RULE'})
3424    if defined $ENV{'SYS$TIMEZONE_RULE'};         # VMS TZ environ var
3425  push(@tz,$ENV{'SYS$TIMEZONE_NAME'})
3426    if defined $ENV{'SYS$TIMEZONE_NAME'};         # VMS TZ name environ var
3427  push(@tz,$ENV{'UCX$TZ'})
3428    if defined $ENV{'UCX$TZ'};                    # VMS TZ environ var
3429  push(@tz,$ENV{'TCPIP$TZ'})
3430    if defined $ENV{'TCPIP$TZ'};                  # VMS TZ environ var
3431
3432  # The `date` command... if we're doing taint checking, we need to
3433  # always call it with a full path... otherwise, use the user's path.
3434  #
3435  # Microsoft operating systems don't have a date command built in.  Try
3436  # to trap all the various ways of knowing we are on one of these systems.
3437  #
3438  # We'll try `date +%Z` first, and if that fails, we'll take just the
3439  # `date` program and assume the output is of the format:
3440  # Thu Aug 31 14:57:46 EDT 2000
3441
3442  unless (($^O ne 'cygwin' && $^X =~ /perl\.exe$/i) or
3443          ($OS eq "Windows") or
3444          ($OS eq "Netware") or
3445          ($OS eq "VMS")) {
3446    if ($Date::Manip::NoTaint) {
3447      if ($OS eq "VMS") {
3448        $tz=$ENV{'SYS$TIMEZONE_NAME'};
3449        if (! $tz) {
3450          $tz=$ENV{'MULTINET_TIMEZONE'};
3451          if (! $tz) {
3452            $tz=$ENV{'SYS$TIMEZONE_DIFFERENTIAL'}/3600.; # e.g. '-4' for EDT
3453          }
3454        }
3455      } else {
3456        $tz=`date +%Z 2> /dev/null`;
3457        chomp($tz);
3458        if (! $tz) {
3459          $tz=`date 2> /dev/null`;
3460          chomp($tz);
3461          $tz=(split(/\s+/,$tz))[4];
3462        }
3463      }
3464      push(@tz,$tz)  if (defined $tz);
3465    } else {
3466      # We need to satisfy taint checking, but also look in all the
3467      # directories in @DatePath.
3468      #
3469      local $ENV{PATH} = join(':', @Date::Manip::DatePath);
3470      local $ENV{BASH_ENV} = '';
3471      $tz=`date +%Z 2> /dev/null`;
3472      chomp($tz);
3473      if (! $tz) {
3474        $tz=`date 2> /dev/null`;
3475        chomp($tz);
3476        $tz=(split(/\s+/,$tz))[4];
3477      }
3478      push(@tz,$tz)  if (defined $tz);
3479    }
3480  }
3481
3482  push(@tz,$main::TZ)         if (defined $main::TZ);         # $main::TZ
3483
3484  if (-s "/etc/TIMEZONE") {                                   # /etc/TIMEZONE
3485    $in=new IO::File;
3486    $in->open("/etc/TIMEZONE","r");
3487    while (! eof($in)) {
3488      $tmp=<$in>;
3489      if ($tmp =~ /^TZ\s*=\s*(.*?)\s*$/) {
3490        push(@tz,$1);
3491        last;
3492      }
3493    }
3494    $in->close;
3495  }
3496
3497  if (-s "/etc/timezone") {                                   # /etc/timezone
3498    $in=new IO::File;
3499    $in->open("/etc/timezone","r");
3500    while (! eof($in)) {
3501      $tmp=<$in>;
3502      next  if ($tmp =~ /^\s*\043/);
3503      chomp($tmp);
3504      if ($tmp =~ /^\s*(.*?)\s*$/) {
3505        push(@tz,$1);
3506        last;
3507      }
3508    }
3509    $in->close;
3510  }
3511 
3512  print STDERR "Found time zones: @tz\n";
3513
3514  # Now parse each one to find the first valid one.
3515  foreach $tz (@tz) {
3516    $tz =~ s/\s*$//;
3517    $tz =~ s/^\s*//;
3518    $tz =~ s/^://;
3519    next  if ($tz eq "");
3520
3521    return uc($tz)
3522      if (defined $Zone{"n2o"}{lc($tz)});
3523
3524    if ($tz =~ /^[+-]\d{4}$/) {
3525      return $tz;
3526    } elsif ($tz =~ /^([+-]\d{2})(?::(\d{2}))?$/) {
3527      my($h,$m)=($1,$2);
3528      $m="00"  if (! $m);
3529      return "$h$m";
3530    }
3531
3532    # Handle US/Eastern format
3533    if ($tz =~ /^$Zone{"tzones"}$/i) {
3534      $tmp=lc $1;
3535      $tz=$Zone{"tz2z"}{$tmp};
3536    }
3537
3538    # Handle STD#DST# format (and STD-#DST-# formats)
3539    if ($tz =~ /^([a-z]+)-?\d([a-z]+)-?\d?$/i) {
3540      ($std,$dst)=($1,$2);
3541      next  if (! defined $Zone{"n2o"}{lc($std)} or
3542                ! defined $Zone{"n2o"}{lc($dst)});
3543      $time = time();
3544      ($null,$null,$null,$null,$null,$null,$null,$null,$isdst) =
3545        localtime($time);
3546      return uc($dst)  if ($isdst);
3547      return uc($std);
3548    }
3549  }
3550
3551  confess "ERROR: Date::Manip unable to determine Time Zone.\n";
3552}
3553
3554# Returns 1 if $date is a work day.  If $time is non-zero, the time is
3555# also checked to see if it falls within work hours.  Returns "" if
3556# an invalid date is passed in.
3557sub Date_IsWorkDay {
3558  print "DEBUG: Date_IsWorkDay\n"  if ($Curr{"Debug"} =~ /trace/);
3559  my($date,$time)=@_;
3560  Date_Init()  if (! $Curr{"InitDone"});
3561  $date=ParseDateString($date);
3562  return ""  if (! $date);
3563  my($d)=$date;
3564  $d=Date_SetTime($date,$Cnf{"WorkDayBeg"})  if (! $time);
3565
3566  my($y,$mon,$day,$h,$m,$s,$dow)=();
3567  ($y,$mon,$day,$h,$m,$s)=_Date_Split($d, 1);
3568  $dow=Date_DayOfWeek($mon,$day,$y);
3569
3570  return 0  if ($dow<$Cnf{"WorkWeekBeg"} or
3571                $dow>$Cnf{"WorkWeekEnd"} or
3572                "$h:$m" lt $Cnf{"WorkDayBeg"} or
3573                "$h:$m" ge $Cnf{"WorkDayEnd"});
3574
3575  if (! exists $Holiday{"dates"}{$y}) {
3576    # There will be recursion problems if we ever end up here twice.
3577    $Holiday{"dates"}{$y}={};
3578    _Date_UpdateHolidays($y)
3579  }
3580  $d=Date_SetTime($date,"00:00:00");
3581  return 0  if (exists $Holiday{"dates"}{$y}{$d});
3582  1;
3583}
3584
3585# Finds the day $off work days from now.  If $time is passed in, we must
3586# also take into account the time of day.
3587#
3588# If $time is not passed in, day 0 is today (if today is a workday) or the
3589# next work day if it isn't.  In any case, the time of day is unaffected.
3590#
3591# If $time is passed in, day 0 is now (if now is part of a workday) or the
3592# start of the very next work day.
3593sub Date_NextWorkDay {
3594  print "DEBUG: Date_NextWorkDay\n"  if ($Curr{"Debug"} =~ /trace/);
3595  my($date,$off,$time)=@_;
3596  Date_Init()  if (! $Curr{"InitDone"});
3597  $date=ParseDateString($date);
3598  my($err)=();
3599
3600  if (! Date_IsWorkDay($date,$time)) {
3601    if ($time) {
3602      while (1) {
3603        $date=Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"});
3604        last  if (Date_IsWorkDay($date,$time));
3605      }
3606    } else {
3607      while (1) {
3608        $date=_DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0);
3609        last  if (Date_IsWorkDay($date,$time));
3610      }
3611    }
3612  }
3613
3614  while ($off>0) {
3615    while (1) {
3616      $date=_DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0);
3617      last  if (Date_IsWorkDay($date,$time));
3618    }
3619    $off--;
3620  }
3621
3622  return $date;
3623}
3624
3625# Finds the day $off work days before now.  If $time is passed in, we must
3626# also take into account the time of day.
3627#
3628# If $time is not passed in, day 0 is today (if today is a workday) or the
3629# previous work day if it isn't.  In any case, the time of day is unaffected.
3630#
3631# If $time is passed in, day 0 is now (if now is part of a workday) or the
3632# end of the previous work period.  Note that since the end of a work day
3633# will automatically be turned into the start of the next one, this time
3634# may actually be treated as AFTER the current time.
3635sub Date_PrevWorkDay {
3636  print "DEBUG: Date_PrevWorkDay\n"  if ($Curr{"Debug"} =~ /trace/);
3637  my($date,$off,$time)=@_;
3638  Date_Init()  if (! $Curr{"InitDone"});
3639  $date=ParseDateString($date);
3640  my($err)=();
3641
3642  if (! Date_IsWorkDay($date,$time)) {
3643    if ($time) {
3644      while (1) {
3645        $date=Date_GetPrev($date,undef,0,$Cnf{"WorkDayEnd"});
3646        last  if (Date_IsWorkDay($date,$time));
3647      }
3648      while (1) {
3649        $date=Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"});
3650        last  if (Date_IsWorkDay($date,$time));
3651      }
3652    } else {
3653      while (1) {
3654        $date=_DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0);
3655        last  if (Date_IsWorkDay($date,$time));
3656      }
3657    }
3658  }
3659
3660  while ($off>0) {
3661    while (1) {
3662      $date=_DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0);
3663      last  if (Date_IsWorkDay($date,$time));
3664    }
3665    $off--;
3666  }
3667
3668  return $date;
3669}
3670
3671# This finds the nearest workday to $date.  If $date is a workday, it
3672# is returned.
3673sub Date_NearestWorkDay {
3674  print "DEBUG: Date_NearestWorkDay\n"  if ($Curr{"Debug"} =~ /trace/);
3675  my($date,$tomorrow)=@_;
3676  Date_Init()  if (! $Curr{"InitDone"});
3677  $date=ParseDateString($date);
3678  my($a,$b,$dela,$delb,$err)=();
3679  $tomorrow=$Cnf{"TomorrowFirst"}  if (! defined $tomorrow);
3680
3681  return $date  if (Date_IsWorkDay($date));
3682
3683  # Find the nearest one.
3684  if ($tomorrow) {
3685    $dela="+0:0:0:1:0:0:0";
3686    $delb="-0:0:0:1:0:0:0";
3687  } else {
3688    $dela="-0:0:0:1:0:0:0";
3689    $delb="+0:0:0:1:0:0:0";
3690  }
3691  $a=$b=$date;
3692
3693  while (1) {
3694    $a=_DateCalc_DateDelta($a,$dela,\$err);
3695    return $a  if (Date_IsWorkDay($a));
3696    $b=_DateCalc_DateDelta($b,$delb,\$err);
3697    return $b  if (Date_IsWorkDay($b));
3698  }
3699}
3700
3701# Date_NthDayOfYear($y,$n);
3702#   Returns a list of (YYYY,MM,DD,HH,MM,SS) for the Nth day of the year.
3703sub Date_NthDayOfYear {
3704  no integer;
3705  print "DEBUG: Date_NthDayOfYear\n"  if ($Curr{"Debug"} =~ /trace/);
3706  my($y,$n)=@_;
3707  $y=$Curr{"Y"}  if (! $y);
3708  $n=1       if (! defined $n  or  $n eq "");
3709  $n+=0;     # to turn 023 into 23
3710  $y=_Date_FixYear($y)  if (length($y)<4);
3711  my $leap=Date_LeapYear($y);
3712  return ()  if ($n<1);
3713  return ()  if ($n >= ($leap ? 367 : 366));
3714
3715  my(@d_in_m)=(31,28,31,30,31,30,31,31,30,31,30,31);
3716  $d_in_m[1]=29  if ($leap);
3717
3718  # Calculate the hours, minutes, and seconds into the day.
3719  my $remain=($n - int($n))*24;
3720  my $h=int($remain);
3721  $remain=($remain - $h)*60;
3722  my $mn=int($remain);
3723  $remain=($remain - $mn)*60;
3724  my $s=$remain;
3725
3726  # Calculate the month and the day.
3727  my($m,$d)=(0,0);
3728  $n=int($n);
3729  while ($n>0) {
3730    $m++;
3731    if ($n<=$d_in_m[0]) {
3732      $d=int($n);
3733      $n=0;
3734    } else {
3735      $n-= $d_in_m[0];
3736      shift(@d_in_m);
3737    }
3738  }
3739
3740  ($y,$m,$d,$h,$mn,$s);
3741}
3742
3743########################################################################
3744# NOT FOR EXPORT
3745########################################################################
3746
3747# This is used in Date_Init to fill in a hash based on international
3748# data.  It takes a list of keys and values and returns both a hash
3749# with these values and a regular expression of keys.
3750#
3751# IN:
3752#   $data   = [ key1 val1 key2 val2 ... ]
3753#   $opts   = lc     : lowercase the keys in the regexp
3754#             sort   : sort (by length) the keys in the regexp
3755#             back   : create a regexp with a back reference
3756#             escape : escape all strings in the regexp
3757#
3758# OUT:
3759#   $regexp = '(?:key1|key2|...)'
3760#   $hash   = { key1=>val1 key2=>val2 ... }
3761
3762sub _Date_InitHash {
3763  print "DEBUG: _Date_InitHash\n"  if ($Curr{"Debug"} =~ /trace/);
3764  my($data,$regexp,$opts,$hash)=@_;
3765  my(@data)=@$data;
3766  my($key,$val,@list)=();
3767
3768  # Parse the options
3769  my($lc,$sort,$back,$escape)=(0,0,0,0);
3770  $lc=1     if ($opts =~ /lc/i);
3771  $sort=1   if ($opts =~ /sort/i);
3772  $back=1   if ($opts =~ /back/i);
3773  $escape=1 if ($opts =~ /escape/i);
3774
3775  # Create the hash
3776  while (@data) {
3777    ($key,$val,@data)=@data;
3778    $key=lc($key)  if ($lc);
3779    $$hash{$key}=$val;
3780  }
3781
3782  # Create the regular expression
3783  if ($regexp) {
3784    @list=keys(%$hash);
3785    @list=sort _sortByLength(@list)  if ($sort);
3786    if ($escape) {
3787      foreach $val (@list) {
3788        $val="\Q$val\E";
3789      }
3790    }
3791    if ($back) {
3792      $$regexp="(" . join("|",@list) . ")";
3793    } else {
3794      $$regexp="(?:" . join("|",@list) . ")";
3795    }
3796  }
3797}
3798
3799# This is used in Date_Init to fill in regular expressions, lists, and
3800# hashes based on international data.  It takes a list of lists which have
3801# to be stored as regular expressions (to find any element in the list),
3802# lists, and hashes (indicating the location in the lists).
3803#
3804# IN:
3805#   $data   = [ [ [ valA1 valA2 ... ][ valA1' valA2' ... ] ... ]
3806#               [ [ valB1 valB2 ... ][ valB1' valB2' ... ] ... ]
3807#               ...
3808#               [ [ valZ1 valZ2 ... ] [valZ1' valZ1' ... ] ... ] ]
3809#   $lists  = [ \@listA \@listB ... \@listZ ]
3810#   $opts   = lc     : lowercase the values in the regexp
3811#             sort   : sort (by length) the values in the regexp
3812#             back   : create a regexp with a back reference
3813#             escape : escape all strings in the regexp
3814#   $hash   = [ \%hash, TYPE ]
3815#             TYPE 0 : $hash{ valBn=>n-1 }
3816#             TYPE 1 : $hash{ valBn=>n }
3817#
3818# OUT:
3819#   $regexp = '(?:valA1|valA2|...|valB1|...)'
3820#   $lists  = [ [ valA1 valA2 ... ]         # only the 1st list (or
3821#               [ valB1 valB2 ... ] ... ]   # 2nd for int. characters)
3822#   $hash
3823
3824sub _Date_InitLists {
3825  print "DEBUG: _Date_InitLists\n"  if ($Curr{"Debug"} =~ /trace/);
3826  my($data,$regexp,$opts,$lists,$hash)=@_;
3827  my(@data)=@$data;
3828  my(@lists)=@$lists;
3829  my($i,@ele,$ele,@list,$j,$tmp)=();
3830
3831  # Parse the options
3832  my($lc,$sort,$back,$escape)=(0,0,0,0);
3833  $lc=1     if ($opts =~ /lc/i);
3834  $sort=1   if ($opts =~ /sort/i);
3835  $back=1   if ($opts =~ /back/i);
3836  $escape=1 if ($opts =~ /escape/i);
3837
3838  # Set each of the lists
3839  if (@lists) {
3840    confess "ERROR: _Date_InitLists: lists must be 1 per data\n"
3841      if ($#lists != $#data);
3842    for ($i=0; $i<=$#data; $i++) {
3843      @ele=@{ $data[$i] };
3844      if ($Cnf{"IntCharSet"} && $#ele>0) {
3845        @{ $lists[$i] } = @{ $ele[1] };
3846      } else {
3847        @{ $lists[$i] } = @{ $ele[0] };
3848      }
3849    }
3850  }
3851
3852  # Create the hash
3853  my($hashtype,$hashsave,%hash)=();
3854  if (@$hash) {
3855    ($hash,$hashtype)=@$hash;
3856    $hashsave=1;
3857  } else {
3858    $hashtype=0;
3859    $hashsave=0;
3860  }
3861  for ($i=0; $i<=$#data; $i++) {
3862    @ele=@{ $data[$i] };
3863    foreach $ele (@ele) {
3864      @list = @{ $ele };
3865      for ($j=0; $j<=$#list; $j++) {
3866        $tmp=$list[$j];
3867        next  if (! $tmp);
3868        $tmp=lc($tmp)  if ($lc);
3869        $hash{$tmp}= $j+$hashtype;
3870      }
3871    }
3872  }
3873  %$hash = %hash  if ($hashsave);
3874
3875  # Create the regular expression
3876  if ($regexp) {
3877    @list=keys(%hash);
3878    @list=sort _sortByLength(@list)  if ($sort);
3879    if ($escape) {
3880      foreach $ele (@list) {
3881        $ele="\Q$ele\E";
3882      }
3883    }
3884    if ($back) {
3885      $$regexp="(" . join("|",@list) . ")";
3886    } else {
3887      $$regexp="(?:" . join("|",@list) . ")";
3888    }
3889  }
3890}
3891
3892# This is used in Date_Init to fill in regular expressions and lists based
3893# on international data.  This takes a list of strings and returns a regular
3894# expression (to find any one of them).
3895#
3896# IN:
3897#   $data   = [ string1 string2 ... ]
3898#   $opts   = lc     : lowercase the values in the regexp
3899#             sort   : sort (by length) the values in the regexp
3900#             back   : create a regexp with a back reference
3901#             escape : escape all strings in the regexp
3902#
3903# OUT:
3904#   $regexp = '(string1|string2|...)'
3905
3906sub _Date_InitStrings {
3907  print "DEBUG: _Date_InitStrings\n"  if ($Curr{"Debug"} =~ /trace/);
3908  my($data,$regexp,$opts)=@_;
3909  my(@list)=@{ $data };
3910
3911  # Parse the options
3912  my($lc,$sort,$back,$escape)=(0,0,0,0);
3913  $lc=1     if ($opts =~ /lc/i);
3914  $sort=1   if ($opts =~ /sort/i);
3915  $back=1   if ($opts =~ /back/i);
3916  $escape=1 if ($opts =~ /escape/i);
3917
3918  # Create the regular expression
3919  my($ele)=();
3920  @list=sort _sortByLength(@list)  if ($sort);
3921  if ($escape) {
3922    foreach $ele (@list) {
3923      $ele="\Q$ele\E";
3924    }
3925  }
3926  if ($back) {
3927    $$regexp="(" . join("|",@list) . ")";
3928  } else {
3929    $$regexp="(?:" . join("|",@list) . ")";
3930  }
3931  $$regexp=lc($$regexp)  if ($lc);
3932}
3933
3934# items is passed in (either as a space separated string, or a reference to
3935# a list) and a regular expression which matches any one of the items is
3936# prepared.  The regular expression will be of one of the forms:
3937#   "(a|b)"       @list not empty, back option included
3938#   "(?:a|b)"     @list not empty
3939#   "()"          @list empty,     back option included
3940#   ""            @list empty
3941# $options is a string which contains any of the following strings:
3942#   back     : the regular expression has a backreference
3943#   opt      : the regular expression is optional and a "?" is appended in
3944#              the first two forms
3945#   optws    : the regular expression is optional and may be replaced by
3946#              whitespace
3947#   optWs    : the regular expression is optional, but if not present, must
3948#              be replaced by whitespace
3949#   sort     : the items in the list are sorted by length (longest first)
3950#   lc       : the string is lowercased
3951#   under    : any underscores are converted to spaces
3952#   pre      : it may be preceded by whitespace
3953#   Pre      : it must be preceded by whitespace
3954#   PRE      : it must be preceded by whitespace or the start
3955#   post     : it may be followed by whitespace
3956#   Post     : it must be followed by whitespace
3957#   POST     : it must be followed by whitespace or the end
3958# Spaces due to pre/post options will not be included in the back reference.
3959#
3960# If $array is included, then the elements will also be returned as a list.
3961# $array is a string which may contain any of the following:
3962#   keys     : treat the list as a hash and only the keys go into the regexp
3963#   key0     : treat the list as the values of a hash with keys 0 .. N-1
3964#   key1     : treat the list as the values of a hash with keys 1 .. N
3965#   val0     : treat the list as the keys of a hash with values 0 .. N-1
3966#   val1     : treat the list as the keys of a hash with values 1 .. N
3967
3968#    _Date_InitLists([$lang{"month_name"},$lang{"month_abb"}],
3969#             [\$Month,"lc,sort,back"],
3970#             [\@Month,\@Mon],
3971#             [\%Month,1]);
3972
3973# This is used in Date_Init to prepare regular expressions.  A list of
3974# items is passed in (either as a space separated string, or a reference to
3975# a list) and a regular expression which matches any one of the items is
3976# prepared.  The regular expression will be of one of the forms:
3977#   "(a|b)"       @list not empty, back option included
3978#   "(?:a|b)"     @list not empty
3979#   "()"          @list empty,     back option included
3980#   ""            @list empty
3981# $options is a string which contains any of the following strings:
3982#   back     : the regular expression has a backreference
3983#   opt      : the regular expression is optional and a "?" is appended in
3984#              the first two forms
3985#   optws    : the regular expression is optional and may be replaced by
3986#              whitespace
3987#   optWs    : the regular expression is optional, but if not present, must
3988#              be replaced by whitespace
3989#   sort     : the items in the list are sorted by length (longest first)
3990#   lc       : the string is lowercased
3991#   under    : any underscores are converted to spaces
3992#   pre      : it may be preceded by whitespace
3993#   Pre      : it must be preceded by whitespace
3994#   PRE      : it must be preceded by whitespace or the start
3995#   post     : it may be followed by whitespace
3996#   Post     : it must be followed by whitespace
3997#   POST     : it must be followed by whitespace or the end
3998# Spaces due to pre/post options will not be included in the back reference.
3999#
4000# If $array is included, then the elements will also be returned as a list.
4001# $array is a string which may contain any of the following:
4002#   keys     : treat the list as a hash and only the keys go into the regexp
4003#   key0     : treat the list as the values of a hash with keys 0 .. N-1
4004#   key1     : treat the list as the values of a hash with keys 1 .. N
4005#   val0     : treat the list as the keys of a hash with values 0 .. N-1
4006#   val1     : treat the list as the keys of a hash with values 1 .. N
4007sub _Date_Regexp {
4008  print "DEBUG: _Date_Regexp\n"  if ($Curr{"Debug"} =~ /trace/);
4009  my($list,$options,$array)=@_;
4010  my(@list,$ret,%hash,$i)=();
4011  local($_)=();
4012  $options=""  if (! defined $options);
4013  $array=""    if (! defined $array);
4014
4015  my($sort,$lc,$under)=(0,0,0);
4016  $sort =1  if ($options =~ /sort/i);
4017  $lc   =1  if ($options =~ /lc/i);
4018  $under=1  if ($options =~ /under/i);
4019  my($back,$opt,$pre,$post,$ws)=("?:","","","","");
4020  $back =""          if ($options =~ /back/i);
4021  $opt  ="?"         if ($options =~ /opt/i);
4022  $pre  ='\s*'       if ($options =~ /pre/);
4023  $pre  ='\s+'       if ($options =~ /Pre/);
4024  $pre  ='(?:\s+|^)' if ($options =~ /PRE/);
4025  $post ='\s*'       if ($options =~ /post/);
4026  $post ='\s+'       if ($options =~ /Post/);
4027  $post ='(?:$|\s+)' if ($options =~ /POST/);
4028  $ws   ='\s*'       if ($options =~ /optws/);
4029  $ws   ='\s+'       if ($options =~ /optws/);
4030
4031  my($hash,$keys,$key0,$key1,$val0,$val1)=(0,0,0,0,0,0);
4032  $keys =1     if ($array =~ /keys/i);
4033  $key0 =1     if ($array =~ /key0/i);
4034  $key1 =1     if ($array =~ /key1/i);
4035  $val0 =1     if ($array =~ /val0/i);
4036  $val1 =1     if ($array =~ /val1/i);
4037  $hash =1     if ($keys or $key0 or $key1 or $val0 or $val1);
4038
4039  my($ref)=ref $list;
4040  if (! $ref) {
4041    $list =~ s/\s*$//;
4042    $list =~ s/^\s*//;
4043    $list =~ s/\s+/&&&/g;
4044  } elsif ($ref eq "ARRAY") {
4045    $list = join("&&&",@$list);
4046  } else {
4047    confess "ERROR: _Date_Regexp.\n";
4048  }
4049
4050  if (! $list) {
4051    if ($back eq "") {
4052      return "()";
4053    } else {
4054      return "";
4055    }
4056  }
4057
4058  $list=lc($list)  if ($lc);
4059  $list=~ s/_/ /g  if ($under);
4060  @list=split(/&&&/,$list);
4061  if ($keys) {
4062    %hash=@list;
4063    @list=keys %hash;
4064  } elsif ($key0 or $key1 or $val0 or $val1) {
4065    $i=0;
4066    $i=1  if ($key1 or $val1);
4067    if ($key0 or $key1) {
4068      %hash= map { $_,$i++ } @list;
4069    } else {
4070      %hash= map { $i++,$_ } @list;
4071    }
4072  }
4073  @list=sort _sortByLength(@list)  if ($sort);
4074
4075  $ret="($back" . join("|",@list) . ")";
4076  $ret="(?:$pre$ret$post)"  if ($pre or $post);
4077  $ret.=$opt;
4078  $ret="(?:$ret|$ws)"  if ($ws);
4079
4080  if ($array and $hash) {
4081    return ($ret,%hash);
4082  } elsif ($array) {
4083    return ($ret,@list);
4084  } else {
4085    return $ret;
4086  }
4087}
4088
4089# This will produce a delta with the correct number of signs.  At most two
4090# signs will be in it normally (one before the year, and one in front of
4091# the day), but if appropriate, signs will be in front of all elements.
4092# Also, as many of the signs will be equivalent as possible.
4093sub _Delta_Normalize {
4094  print "DEBUG: _Delta_Normalize\n"  if ($Curr{"Debug"} =~ /trace/);
4095  my($delta,$mode)=@_;
4096  return "" if (! $delta);
4097  return "+0:+0:+0:+0:+0:+0:+0"
4098    if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/ and $Cnf{"DeltaSigns"});
4099  return "+0:0:0:0:0:0:0" if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/);
4100
4101  my($tmp,$sign1,$sign2,$len)=();
4102
4103  # Calculate the length of the day in minutes
4104  $len=24*60;
4105  $len=$Curr{"WDlen"}  if ($mode==2 || $mode==3);
4106
4107  # We have to get the sign of every component explicitely so that a "-0"
4108  # or "+0" doesn't get lost by treating it numerically (i.e. "-0:0:2" must
4109  # be a negative delta).
4110
4111  my($y,$mon,$w,$d,$h,$m,$s)=_Delta_Split($delta);
4112
4113  # We need to make sure that the signs of all parts of a delta are the
4114  # same.  The easiest way to do this is to convert all of the large
4115  # components to the smallest ones, then convert the smaller components
4116  # back to the larger ones.
4117
4118  # Do the year/month part
4119
4120  $mon += $y*12;                         # convert y to m
4121  $sign1="+";
4122  if ($mon<0) {
4123    $mon *= -1;
4124    $sign1="-";
4125  }
4126
4127  $y    = $mon/12;                       # convert m to y
4128  $mon -= $y*12;
4129
4130  $y=0    if ($y eq "-0");               # get around silly -0 problem
4131  $mon=0  if ($mon eq "-0");
4132
4133  # Do the wk/day/hour/min/sec part
4134
4135  {
4136    # Unfortunately, $s is overflowing for dates more than ~70 years
4137    # apart.
4138    no integer;
4139
4140    if ($mode==3 || $mode==2) {
4141      $s += $d*$len*60 + $h*3600 + $m*60;        # convert d/h/m to s
4142    } else {
4143      $s += ($d+7*$w)*$len*60 + $h*3600 + $m*60; # convert w/d/h/m to s
4144    }
4145    $sign2="+";
4146    if ($s<0) {
4147      $s*=-1;
4148      $sign2="-";
4149    }
4150
4151    $m  = int($s/60);                    # convert s to m
4152    $s -= $m*60;
4153    $d  = int($m/$len);                  # convert m to d
4154    $m -= $d*$len;
4155
4156    # The rest should be fine.
4157  }
4158  $h  = $m/60;                           # convert m to h
4159  $m -= $h*60;
4160  if ($mode == 3 || $mode == 2) {
4161    $w  = $w*1;                          # get around +0 problem
4162  } else {
4163    $w  = $d/7;                          # convert d to w
4164    $d -= $w*7;
4165  }
4166
4167  $w=0    if ($w eq "-0");               # get around silly -0 problem
4168  $d=0    if ($d eq "-0");
4169  $h=0    if ($h eq "-0");
4170  $m=0    if ($m eq "-0");
4171  $s=0    if ($s eq "-0");
4172
4173  # Only include two signs if necessary
4174  $sign1=$sign2  if ($y==0 and $mon==0);
4175  $sign2=$sign1  if ($w==0 and $d==0 and $h==0 and $m==0 and $s==0);
4176  $sign2=""  if ($sign1 eq $sign2  and  ! $Cnf{"DeltaSigns"});
4177
4178  if ($Cnf{"DeltaSigns"}) {
4179    return "$sign1$y:$sign1$mon:$sign2$w:$sign2$d:$sign2$h:$sign2$m:$sign2$s";
4180  } else {
4181    return "$sign1$y:$mon:$sign2$w:$d:$h:$m:$s";
4182  }
4183}
4184
4185# This checks a delta to make sure it is valid.  If it is, it splits
4186# it and returns the elements with a sign on each.  The 2nd argument
4187# specifies the default sign.  Blank elements are set to 0.  If the
4188# third element is non-nil, exactly 7 elements must be included.
4189sub _Delta_Split {
4190  print "DEBUG: _Delta_Split\n"  if ($Curr{"Debug"} =~ /trace/);
4191  my($delta,$sign,$exact)=@_;
4192  my(@delta)=split(/:/,$delta);
4193  return ()  if ($exact  and $#delta != 6);
4194  my($i)=();
4195  $sign="+"  if (! defined $sign);
4196  for ($i=0; $i<=$#delta; $i++) {
4197    $delta[$i]="0"  if (! $delta[$i]);
4198    return ()  if ($delta[$i] !~ /^[+-]?\d+$/);
4199    $sign = ($delta[$i] =~ s/^([+-])// ? $1 : $sign);
4200    $delta[$i] = $sign.$delta[$i];
4201  }
4202  @delta;
4203}
4204
4205# Reads up to 3 arguments.  $h may contain the time in any international
4206# format.  Any empty elements are set to 0.
4207sub _Date_ParseTime {
4208  print "DEBUG: _Date_ParseTime\n"  if ($Curr{"Debug"} =~ /trace/);
4209  my($h,$m,$s)=@_;
4210  my($t)=_CheckTime("one");
4211
4212  if (defined $h  and  $h =~ /$t/) {
4213    $h=$1;
4214    $m=$2;
4215    $s=$3   if (defined $3);
4216  }
4217  $h="00"  if (! defined $h);
4218  $m="00"  if (! defined $m);
4219  $s="00"  if (! defined $s);
4220
4221  ($h,$m,$s);
4222}
4223
4224# Forms a date with the 6 elements passed in (all of which must be defined).
4225# No check as to validity is made.
4226sub _Date_Join {
4227  print "DEBUG: _Date_Join\n"  if ($Curr{"Debug"} =~ /trace/);
4228  foreach (0 .. $#_) {
4229      croak "undefined arg $_ to _Date_Join()" if not defined $_[$_];
4230  }
4231  my($y,$m,$d,$h,$mn,$s)=@_;
4232  my($ym,$md,$dh,$hmn,$mns)=();
4233
4234  if      ($Cnf{"Internal"} == 0) {
4235    $ym=$md=$dh="";
4236    $hmn=$mns=":";
4237
4238  } elsif ($Cnf{"Internal"} == 1) {
4239    $ym=$md=$dh=$hmn=$mns="";
4240
4241  } elsif ($Cnf{"Internal"} == 2) {
4242    $ym=$md="-";
4243    $dh=" ";
4244    $hmn=$mns=":";
4245
4246  } else {
4247    confess "ERROR: Invalid internal format in _Date_Join.\n";
4248  }
4249  $m="0$m"    if (length($m)==1);
4250  $d="0$d"    if (length($d)==1);
4251  $h="0$h"    if (length($h)==1);
4252  $mn="0$mn"  if (length($mn)==1);
4253  $s="0$s"    if (length($s)==1);
4254  "$y$ym$m$md$d$dh$h$hmn$mn$mns$s";
4255}
4256
4257# This checks a time.  If it is valid, it splits it and returns 3 elements.
4258# If "one" or "two" is passed in, a regexp with 1/2 or 2 digit hours is
4259# returned.
4260sub _CheckTime {
4261  print "DEBUG: _CheckTime\n"  if ($Curr{"Debug"} =~ /trace/);
4262  my($time)=@_;
4263  my($h)='(?:0?[0-9]|1[0-9]|2[0-3])';
4264  my($h2)='(?:0[0-9]|1[0-9]|2[0-3])';
4265  my($m)='[0-5][0-9]';
4266  my($s)=$m;
4267  my($hm)="(?:". $Lang{$Cnf{"Language"}}{"SepHM"} ."|:)";
4268  my($ms)="(?:". $Lang{$Cnf{"Language"}}{"SepMS"} ."|:)";
4269  my($ss)=$Lang{$Cnf{"Language"}}{"SepSS"};
4270  my($t)="^($h)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$";
4271  if ($time eq "one") {
4272    return $t;
4273  } elsif ($time eq "two") {
4274    $t="^($h2)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$";
4275    return $t;
4276  }
4277
4278  if ($time =~ /$t/i) {
4279    ($h,$m,$s)=($1,$2,$3);
4280    $h="0$h" if (length($h)<2);
4281    $m="0$m" if (length($m)<2);
4282    $s="00"  if (! defined $s);
4283    return ($h,$m,$s);
4284  } else {
4285    return ();
4286  }
4287}
4288
4289# This checks a recurrence.  If it is valid, it splits it and returns the
4290# elements.  Otherwise, it returns an empty list.
4291#    ($recur0,$recur1,$flags,$dateb,$date0,$date1)=_Recur_Split($recur);
4292sub _Recur_Split {
4293  print "DEBUG: _Recur_Split\n"  if ($Curr{"Debug"} =~ /trace/);
4294  my($recur)=@_;
4295  my(@ret,@tmp);
4296
4297  my($R)  = '(\*?(?:[-,0-9]+[:\*]){6}[-,0-9]+)';
4298  my($F)  = '(?:\*([^*]*))';
4299  my($DB,$D0,$D1);
4300  $DB=$D0=$D1=$F;
4301
4302  if ($recur =~ /^$R$F?$DB?$D0?$D1?$/) {
4303    @ret=($1,$2,$3,$4,$5);
4304    @tmp=split(/\*/,shift(@ret));
4305    return ()  if ($#tmp>1);
4306    return (@tmp,"",@ret)  if ($#tmp==0);
4307    return (@tmp,@ret);
4308  }
4309  return ();
4310}
4311
4312# This checks a date.  If it is valid, it splits it and returns the elements.
4313#
4314# The optional second argument says 'I really expect this to be a
4315# valid Date::Manip object, please throw an exception if it is not'.
4316# Otherwise, if the date passed in is undef or '', a regular
4317# expression for the date is returned; if the string is nonempty but
4318# still not valid, () is returned.
4319#
4320sub _Date_Split {
4321  print "DEBUG: _Date_Split\n"  if ($Curr{"Debug"} =~ /trace/);
4322  my($date, $definitely_valid)=@_;
4323  $definitely_valid = 0 if not defined $definitely_valid;
4324  my($ym,$md,$dh,$hmn,$mns)=();
4325  my($y)='(\d{4})';
4326  my($m)='(0[1-9]|1[0-2])';
4327  my($d)='(0[1-9]|[1-2][0-9]|3[0-1])';
4328  my($h)='([0-1][0-9]|2[0-3])';
4329  my($mn)='([0-5][0-9])';
4330  my($s)=$mn;
4331
4332  if      ($Cnf{"Internal"} == 0) {
4333    $ym=$md=$dh="";
4334    $hmn=$mns=":";
4335
4336  } elsif ($Cnf{"Internal"} == 1) {
4337    $ym=$md=$dh=$hmn=$mns="";
4338
4339  } elsif ($Cnf{"Internal"} == 2) {
4340    $ym=$md="-";
4341    $dh=" ";
4342    $hmn=$mns=":";
4343
4344  } else {
4345    confess "ERROR: Invalid internal format in _Date_Split.\n";
4346  }
4347
4348  my($t)="^$y$ym$m$md$d$dh$h$hmn$mn$mns$s\$";
4349
4350  if (not defined $date or $date eq '') {
4351      if ($definitely_valid) {
4352          die "bad date '$date'";
4353      } else {
4354          return $t;
4355      }
4356  }
4357
4358  if ($date =~ /$t/) {
4359    ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6);
4360    my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31);
4361    $d_in_m[2]=29  if (Date_LeapYear($y));
4362    if ($d>$d_in_m[$m]) {
4363        my $msg = "invalid date $date: day $d of month $m, but only $d_in_m[$m] days in that month";
4364        if ($definitely_valid) {
4365            die $msg;
4366        }
4367        else {
4368            warn $msg;
4369            return ();
4370        }
4371    }
4372    return ($y,$m,$d,$h,$mn,$s);
4373  }
4374
4375  if ($definitely_valid) {
4376      die "invalid date $date: doesn't match regexp $t";
4377  }
4378  return ();
4379}
4380
4381# This returns the date easter occurs on for a given year as ($month,$day).
4382# This is from the Calendar FAQ.
4383sub _Date_Easter {
4384  my($y)=@_;
4385  $y=_Date_FixYear($y)  if (length($y)==2);
4386
4387  my($c) = $y/100;
4388  my($g) = $y % 19;
4389  my($k) = ($c-17)/25;
4390  my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
4391  $i     = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
4392  my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
4393  my($l) = $i-$j;
4394  my($m) = 3 + ($l+40)/44;
4395  my($d) = $l + 28 - 31*($m/4);
4396  return ($m,$d);
4397}
4398
4399# This takes a list of years, months, WeekOfMonth's, and DayOfWeek's, and
4400# returns a list of dates.  Optionally, a list of dates can be passed in as
4401# the 1st argument (with the 2nd argument the null list) and the year/month
4402# of these will be used.
4403sub _Date_Recur_WoM {
4404  my($y,$m,$w,$d)=@_;
4405  my(@y)=@$y;
4406  my(@m)=@$m;
4407  my(@w)=@$w;
4408  my(@d)=@$d;
4409  my($date0,$date1,@tmp,@date,$d0,$d1,@tmp2)=();
4410
4411  if (@m) {
4412    foreach $m (@m) {
4413      return ()  if (! _IsInt($m,1,12));
4414    }
4415
4416    @tmp=@tmp2=();
4417    foreach $y (@y) {
4418      foreach $m (@m) {
4419        push(@tmp,$y);
4420        push(@tmp2,$m);
4421      }
4422    }
4423
4424    @y=@tmp;
4425    @m=@tmp2;
4426
4427  } else {
4428    foreach $d0 (@y) {
4429      @tmp=_Date_Split($d0);
4430      return ()  if (! @tmp);
4431      push(@tmp2,$tmp[0]);
4432      push(@m,$tmp[1]);
4433    }
4434    @y=@tmp2;
4435  }
4436
4437  return ()  if (! @w);
4438  foreach $w (@w) {
4439    return ()  if ($w==0  ||  ! _IsInt($w,-5,5));
4440  }
4441
4442  if (@d) {
4443    foreach $d (@d) {
4444      return ()  if ($d==0  ||  ! _IsInt($d,-7,7));
4445      $d += 8  if ($d < 0);
4446    }
4447  }
4448
4449  @date=();
4450  foreach $y (@y) {
4451    $m=shift(@m);
4452
4453    # Find 1st day of this month and next month
4454    $date0=_Date_Join($y,$m,1,0,0,0);
4455    $date1=_DateCalc_DateDelta($date0,"+0:1:0:0:0:0:0");
4456
4457    foreach $d (@d) {
4458      # Find 1st occurence of DOW (in both months)
4459      $d0=Date_GetNext($date0,$d,1);
4460      $d1=Date_GetNext($date1,$d,1);
4461
4462      @tmp=();
4463      while (Date_Cmp($d0,$d1)<0) {
4464        push(@tmp,$d0);
4465        $d0=_DateCalc_DateDelta($d0,"+0:0:1:0:0:0:0");
4466      }
4467
4468      @tmp2=();
4469      foreach $w (@w) {
4470        if ($w>0) {
4471          next  if ($w > $#tmp+1);
4472          push(@tmp2,$tmp[$w-1]);
4473        } else {
4474          next  if (-$w > $#tmp+1);
4475          push(@tmp2,$tmp[$#tmp+1+$w]);
4476        }
4477      }
4478      @tmp2=sort { Date_Cmp($a,$b) } @tmp2;
4479      push(@date,@tmp2);
4480    }
4481  }
4482
4483  @date;
4484}
4485
4486# This returns a sorted list of dates formed by adding/subtracting
4487# $delta to $dateb in the range $date0<=$d<$dateb.  The first date in
4488# the list is actually the first date<$date0 and the last date in the
4489# list is the first date>=$date1 (because sometimes the set part will
4490# move the date back into the range).
4491sub _Date_Recur {
4492  my($date0,$date1,$dateb,$delta)=@_;
4493  my(@ret,$d)=();
4494
4495  while (Date_Cmp($dateb,$date0)<0) {
4496    $dateb=_DateCalc_DateDelta($dateb,$delta);
4497  }
4498  while (Date_Cmp($dateb,$date1)>=0) {
4499    $dateb=_DateCalc_DateDelta($dateb,"-$delta");
4500  }
4501
4502  # Add the dates $date0..$dateb
4503  $d=$dateb;
4504  while (Date_Cmp($d,$date0)>=0) {
4505    unshift(@ret,$d);
4506    $d=_DateCalc_DateDelta($d,"-$delta");
4507  }
4508  # Add the first date earler than the range
4509  unshift(@ret,$d);
4510
4511  # Add the dates $dateb..$date1
4512  $d=_DateCalc_DateDelta($dateb,$delta);
4513  while (Date_Cmp($d,$date1)<0) {
4514    push(@ret,$d);
4515    $d=_DateCalc_DateDelta($d,$delta);
4516  }
4517  # Add the first date later than the range
4518  push(@ret,$d);
4519
4520  @ret;
4521}
4522
4523# This sets the values in each date of a recurrence.
4524#
4525# $h,$m,$s can each be values or lists "1-2,4".  If any are equal to "-1",
4526# they are not set (and none of the larger elements are set).
4527sub _Date_RecurSetTime {
4528  my($date0,$date1,$dates,$h,$m,$s)=@_;
4529  my(@dates)=@$dates;
4530  my(@h,@m,@s,$date,@tmp)=();
4531
4532  $m="-1"  if ($s eq "-1");
4533  $h="-1"  if ($m eq "-1");
4534
4535  if ($h ne "-1") {
4536    @h=_ReturnList($h);
4537    return ()  if ! (@h);
4538    @h=sort { $a<=>$b } (@h);
4539
4540    @tmp=();
4541    foreach $date (@dates) {
4542      foreach $h (@h) {
4543        push(@tmp,Date_SetDateField($date,"h",$h,1));
4544      }
4545    }
4546    @dates=@tmp;
4547  }
4548
4549  if ($m ne "-1") {
4550    @m=_ReturnList($m);
4551    return ()  if ! (@m);
4552    @m=sort { $a<=>$b } (@m);
4553
4554    @tmp=();
4555    foreach $date (@dates) {
4556      foreach $m (@m) {
4557        push(@tmp,Date_SetDateField($date,"mn",$m,1));
4558      }
4559    }
4560    @dates=@tmp;
4561  }
4562
4563  if ($s ne "-1") {
4564    @s=_ReturnList($s);
4565    return ()  if ! (@s);
4566    @s=sort { $a<=>$b } (@s);
4567
4568    @tmp=();
4569    foreach $date (@dates) {
4570      foreach $s (@s) {
4571        push(@tmp,Date_SetDateField($date,"s",$s,1));
4572      }
4573    }
4574    @dates=@tmp;
4575  }
4576
4577  @tmp=();
4578  foreach $date (@dates) {
4579    push(@tmp,$date)  if (Date_Cmp($date,$date0)>=0  &&
4580                          Date_Cmp($date,$date1)<0  &&
4581                          _Date_Split($date));
4582  }
4583
4584  @tmp;
4585}
4586
4587sub _DateCalc_DateDate {
4588  print "DEBUG: _DateCalc_DateDate\n"  if ($Curr{"Debug"} =~ /trace/);
4589  my($D1,$D2,$mode)=@_;
4590  my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31);
4591  $mode=0  if (! defined $mode);
4592
4593  # Exact mode
4594  if ($mode==0) {
4595    my($y1,$m1,$d1,$h1,$mn1,$s1)=_Date_Split($D1, 1);
4596    my($y2,$m2,$d2,$h2,$mn2,$s2)=_Date_Split($D2, 1);
4597    my($i,@delta,$d,$delta,$y)=();
4598
4599    # form the delta for hour/min/sec
4600    $delta[4]=$h2-$h1;
4601    $delta[5]=$mn2-$mn1;
4602    $delta[6]=$s2-$s1;
4603
4604    # form the delta for yr/mon/day
4605    $delta[0]=$delta[1]=0;
4606    $d=0;
4607    if ($y2>$y1) {
4608      $d=Date_DaysInYear($y1) - Date_DayOfYear($m1,$d1,$y1);
4609      $d+=Date_DayOfYear($m2,$d2,$y2);
4610      for ($y=$y1+1; $y<$y2; $y++) {
4611        $d+= Date_DaysInYear($y);
4612      }
4613    } elsif ($y2<$y1) {
4614      $d=Date_DaysInYear($y2) - Date_DayOfYear($m2,$d2,$y2);
4615      $d+=Date_DayOfYear($m1,$d1,$y1);
4616      for ($y=$y2+1; $y<$y1; $y++) {
4617        $d+= Date_DaysInYear($y);
4618      }
4619      $d *= -1;
4620    } else {
4621      $d=Date_DayOfYear($m2,$d2,$y2) - Date_DayOfYear($m1,$d1,$y1);
4622    }
4623    $delta[2]=0;
4624    $delta[3]=$d;
4625
4626    for ($i=0; $i<7; $i++) {
4627      $delta[$i]="+".$delta[$i]  if ($delta[$i]>=0);
4628    }
4629
4630    $delta=join(":",@delta);
4631    $delta=_Delta_Normalize($delta,0);
4632    return $delta;
4633  }
4634
4635  my($date1,$date2)=($D1,$D2);
4636  my($tmp,$sign,$err,@tmp)=();
4637
4638  # make sure both are work days
4639  if ($mode==2 || $mode==3) {
4640    $date1=Date_NextWorkDay($date1,0,1);
4641    $date2=Date_NextWorkDay($date2,0,1);
4642  }
4643
4644  # make sure date1 comes before date2
4645  if (Date_Cmp($date1,$date2)>0) {
4646    $sign="-";
4647    $tmp=$date1;
4648    $date1=$date2;
4649    $date2=$tmp;
4650  } else {
4651    $sign="+";
4652  }
4653  if (Date_Cmp($date1,$date2)==0) {
4654    return "+0:+0:+0:+0:+0:+0:+0"  if ($Cnf{"DeltaSigns"});
4655    return "+0:0:0:0:0:0:0";
4656  }
4657
4658  my($y1,$m1,$d1,$h1,$mn1,$s1)=_Date_Split($date1, 1);
4659  my($y2,$m2,$d2,$h2,$mn2,$s2)=_Date_Split($date2, 1);
4660  my($dy,$dm,$dw,$dd,$dh,$dmn,$ds,$ddd)=(0,0,0,0,0,0,0,0);
4661
4662  if ($mode != 3) {
4663
4664    # Do years
4665    $dy=$y2-$y1;
4666    $dm=0;
4667    if ($dy>0) {
4668      $tmp=_DateCalc_DateDelta($date1,"+$dy:0:0:0:0:0:0",\$err,0);
4669      if (Date_Cmp($tmp,$date2)>0) {
4670        $dy--;
4671        $tmp=$date1;
4672        $tmp=_DateCalc_DateDelta($date1,"+$dy:0:0:0:0:0:0",\$err,0)
4673          if ($dy>0);
4674        $dm=12;
4675      }
4676      $date1=$tmp;
4677    }
4678
4679    # Do months
4680    $dm+=$m2-$m1;
4681    if ($dm>0) {
4682      $tmp=_DateCalc_DateDelta($date1,"+0:$dm:0:0:0:0:0",\$err,0);
4683      if (Date_Cmp($tmp,$date2)>0) {
4684        $dm--;
4685        $tmp=$date1;
4686        $tmp=_DateCalc_DateDelta($date1,"+0:$dm:0:0:0:0:0",\$err,0)
4687          if ($dm>0);
4688      }
4689      $date1=$tmp;
4690    }
4691
4692    # At this point, check to see that we're on a business day again so that
4693    # Aug 3 (Monday) -> Sep 3 (Sunday) -> Sep 4 (Monday)  = 1 month
4694    if ($mode==2) {
4695      if (! Date_IsWorkDay($date1,0)) {
4696        $date1=Date_NextWorkDay($date1,0,1);
4697      }
4698    }
4699  }
4700
4701  # Do days
4702  if ($mode==2 || $mode==3) {
4703    $dd=0;
4704    while (1) {
4705      $tmp=Date_NextWorkDay($date1,1,1);
4706      if (Date_Cmp($tmp,$date2)<=0) {
4707        $dd++;
4708        $date1=$tmp;
4709      } else {
4710        last;
4711      }
4712    }
4713
4714  } else {
4715    ($y1,$m1,$d1)=( _Date_Split($date1, 1) )[0..2];
4716    $dd=0;
4717    # If we're jumping across months, set $d1 to the first of the next month
4718    # (or possibly the 0th of next month which is equivalent to the last day
4719    # of this month)
4720    if ($m1!=$m2) {
4721      $d_in_m[2]=29  if (Date_LeapYear($y1));
4722      $dd=$d_in_m[$m1]-$d1+1;
4723      $d1=1;
4724      $tmp=_DateCalc_DateDelta($date1,"+0:0:0:$dd:0:0:0",\$err,0);
4725      if (Date_Cmp($tmp,$date2)>0) {
4726        $dd--;
4727        $d1--;
4728        $tmp=_DateCalc_DateDelta($date1,"+0:0:0:$dd:0:0:0",\$err,0);
4729      }
4730      $date1=$tmp;
4731    }
4732
4733    $ddd=0;
4734    if ($d1<$d2) {
4735      $ddd=$d2-$d1;
4736      $tmp=_DateCalc_DateDelta($date1,"+0:0:0:$ddd:0:0:0",\$err,0);
4737      if (Date_Cmp($tmp,$date2)>0) {
4738        $ddd--;
4739        $tmp=_DateCalc_DateDelta($date1,"+0:0:0:$ddd:0:0:0",\$err,0);
4740      }
4741      $date1=$tmp;
4742    }
4743    $dd+=$ddd;
4744  }
4745
4746  # in business mode, make sure h1 comes before h2 (if not find delta between
4747  # now and end of day and move to start of next business day)
4748  $d1=( _Date_Split($date1, 1) )[2];
4749  $dh=$dmn=$ds=0;
4750  if ($mode==2 || $mode==3  and  $d1 != $d2) {