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

Last change on this file since 617 was 617, checked in by Nicholas Riley, 9 years ago

Don't die if Date::Manip fails to parse a date.

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