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

Last change on this file since 360 was 360, checked in by Nicholas Riley, 12 years ago

Pester.xcodeproj: Add Perl embedding bits; remove SoundFileManager?.h.

DynaLoader?.a: i386/ppc version from Tiger; Leopard's version causes
Tiger to crash.

Info-Pester.plist: Updated copyright date.

Read Me.rtfd: Remove .typeAttributes.dict, no longer used; update a
bit.

PSTimeDateEditor.m: Switch to NJRDateFormatters again.

NJRDateFormatter.[hm]: Removed old-style date formatter workarounds;
added code for using Date::Manip and trying multiple ICU-based date
formatters.

English.lproj/InfoPlist.strings: Updated copyright date.

English.lproj/MainMenu.nib: Modified date completion menu for items
Date::Manip can parse.

Manip.pm: Date::Manip 5.47, converted to UTF-8.

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