package Date::Manip; # Copyright (c) 1995-2001 Sullivan Beck. All rights reserved. # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. ########################################################################### ########################################################################### use vars qw($OS %Lang %Holiday %Events %Curr %Cnf %Zone); # Determine the type of OS... $OS="Unix"; $OS="Windows" if ((defined $^O and $^O =~ /MSWin32/i || $^O =~ /Windows_95/i || $^O =~ /Windows_NT/i) || (defined $ENV{OS} and $ENV{OS} =~ /MSWin32/i || $ENV{OS} =~ /Windows_95/i || $ENV{OS} =~ /Windows_NT/i)); $OS="Mac" if ((defined $^O and $^O =~ /MacOS/i) || (defined $ENV{OS} and $ENV{OS} =~ /MacOS/i)); $OS="MPE" if (defined $^O and $^O =~ /MPE/i); $OS="OS2" if (defined $^O and $^O =~ /os2/i); $OS="VMS" if (defined $^O and $^O =~ /VMS/i); # Determine if we're doing taint checking $NoTaint = eval { local $^W; unlink "$^X$^T"; 1 }; ########################################################################### # CUSTOMIZATION ########################################################################### # # See the section of the POD documentation section CUSTOMIZING DATE::MANIP # below for a complete description of each of these variables. # Location of a the global config file. Tilde (~) expansions are allowed. # This should be set in Date_Init arguments. $Cnf{"GlobalCnf"}=""; $Cnf{"IgnoreGlobalCnf"}=""; # Name of a personal config file and the path to search for it. Tilde (~) # expansions are allowed. This should be set in Date_Init arguments or in # the global config file. @DatePath=(); if ($OS eq "Windows") { $Cnf{"PathSep"} = ";"; $Cnf{"PersonalCnf"} = "Manip.cnf"; $Cnf{"PersonalCnfPath"} = "."; } elsif ($OS eq "MPE") { $Cnf{"PathSep"} = ":"; $Cnf{"PersonalCnf"} = "Manip.cnf"; $Cnf{"PersonalCnfPath"} = "."; } elsif ($OS eq "OS2") { $Cnf{"PathSep"} = ":"; $Cnf{"PersonalCnf"} = "Manip.cnf"; $Cnf{"PersonalCnfPath"} = "."; } elsif ($OS eq "Mac") { $Cnf{"PathSep"} = ":"; $Cnf{"PersonalCnf"} = "Manip.cnf"; $Cnf{"PersonalCnfPath"} = "."; } elsif ($OS eq "VMS") { # VMS doesn't like files starting with "." $Cnf{"PathSep"} = ":"; $Cnf{"PersonalCnf"} = "Manip.cnf"; $Cnf{"PersonalCnfPath"} = ".:~"; } else { # Unix $Cnf{"PathSep"} = ":"; $Cnf{"PersonalCnf"} = ".DateManip.cnf"; $Cnf{"PersonalCnfPath"} = ".:~"; @DatePath=qw(/bin /usr/bin /usr/local/bin); } ### Date::Manip variables set in the global or personal config file # Which language to use when parsing dates. $Cnf{"Language"}="English"; # 12/10 = Dec 10 (US) or Oct 12 (anything else) $Cnf{"DateFormat"}="US"; # Local timezone $Cnf{"TZ"}=""; # Timezone to work in (""=local, "IGNORE", or a timezone) $Cnf{"ConvTZ"}=""; # Date::Manip internal format (0=YYYYMMDDHH:MN:SS, 1=YYYYHHMMDDHHMNSS) $Cnf{"Internal"}=0; # First day of the week (1=monday, 7=sunday). ISO 8601 says monday. $Cnf{"FirstDay"}=1; # First and last day of the work week (1=monday, 7=sunday) $Cnf{"WorkWeekBeg"}=1; $Cnf{"WorkWeekEnd"}=5; # If non-nil, a work day is treated as 24 hours long (WorkDayBeg/WorkDayEnd # ignored) $Cnf{"WorkDay24Hr"}=0; # Start and end time of the work day (any time format allowed, seconds # ignored) $Cnf{"WorkDayBeg"}="08:00"; $Cnf{"WorkDayEnd"}="17:00"; # If "today" is a holiday, we look either to "tomorrow" or "yesterday" for # the nearest business day. By default, we'll always look "tomorrow" # first. $Cnf{"TomorrowFirst"}=1; # Erase the old holidays $Cnf{"EraseHolidays"}=""; # Set this to non-zero to be produce completely backwards compatible deltas $Cnf{"DeltaSigns"}=0; # If this is 0, use the ISO 8601 standard that Jan 4 is in week 1. If 1, # make week 1 contain Jan 1. $Cnf{"Jan1Week1"}=0; # 2 digit years fall into the 100 year period given by [ CURR-N, # CURR+(99-N) ] where N is 0-99. Default behavior is 89, but other useful # numbers might be 0 (forced to be this year or later) and 99 (forced to be # this year or earlier). It can also be set to "c" (current century) or # "cNN" (i.e. c18 forces the year to bet 1800-1899). Also accepts the # form cNNNN to give the 100 year period NNNN to NNNN+99. $Cnf{"YYtoYYYY"}=89; # Set this to 1 if you want a long-running script to always update the # timezone. This will slow Date::Manip down. Read the POD documentation. $Cnf{"UpdateCurrTZ"}=0; # Use an international character set. $Cnf{"IntCharSet"}=0; # Use this to force the current date to be set to this: $Cnf{"ForceDate"}=""; ########################################################################### require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw( DateManipVersion Date_Init ParseDateString ParseDate ParseRecur Date_Cmp DateCalc ParseDateDelta UnixDate Delta_Format Date_GetPrev Date_GetNext Date_SetTime Date_SetDateField Date_IsHoliday Events_List Date_DaysInMonth Date_DayOfWeek Date_SecsSince1970 Date_SecsSince1970GMT Date_DaysSince1BC Date_DayOfYear Date_DaysInYear Date_WeekOfYear Date_LeapYear Date_DaySuffix Date_ConvTZ Date_TimeZone Date_IsWorkDay Date_NextWorkDay Date_PrevWorkDay Date_NearestWorkDay Date_NthDayOfYear ); use strict; use integer; use Carp; use IO::File; use vars qw($VERSION); $VERSION="5.40"; ######################################################################## ######################################################################## $Curr{"InitLang"} = 1; # Whether a language is being init'ed $Curr{"InitDone"} = 0; # Whether Init_Date has been called $Curr{"InitFilesRead"} = 0; $Curr{"ResetWorkDay"} = 1; $Curr{"Debug"} = ""; $Curr{"DebugVal"} = ""; $Holiday{"year"} = 0; $Holiday{"dates"} = {}; $Holiday{"desc"} = {}; $Events{"raw"} = []; $Events{"parsed"} = 0; $Events{"dates"} = []; $Events{"recur"} = []; ######################################################################## ######################################################################## # THESE ARE THE MAIN ROUTINES ######################################################################## ######################################################################## # Get rid of a problem with old versions of perl no strict "vars"; # This sorts from longest to shortest element sub sortByLength { return (length $b <=> length $a); } use strict "vars"; sub DateManipVersion { print "DEBUG: DateManipVersion\n" if ($Curr{"Debug"} =~ /trace/); return $VERSION; } sub Date_Init { print "DEBUG: Date_Init\n" if ($Curr{"Debug"} =~ /trace/); $Curr{"Debug"}=""; my(@args)=@_; $Curr{"InitDone"}=1; local($_)=(); my($internal,$firstday)=(); my($var,$val,$file,@tmp)=(); # InitFilesRead = 0 : no conf files read yet # 1 : global read, no personal read # 2 : personal read $Cnf{"EraseHolidays"}=0; foreach (@args) { s/\s*$//; s/^\s*//; /^(\S+) \s* = \s* (.+)$/x; ($var,$val)=($1,$2); if ($var =~ /^GlobalCnf$/i) { $Cnf{"GlobalCnf"}=$val; if ($val) { $Curr{"InitFilesRead"}=0; &EraseHolidays(); } } elsif ($var =~ /^PathSep$/i) { $Cnf{"PathSep"}=$val; } elsif ($var =~ /^PersonalCnf$/i) { $Cnf{"PersonalCnf"}=$val; $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==2); } elsif ($var =~ /^PersonalCnfPath$/i) { $Cnf{"PersonalCnfPath"}=$val; $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==2); } elsif ($var =~ /^IgnoreGlobalCnf$/i) { $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==0); $Cnf{"IgnoreGlobalCnf"}=1; } elsif ($var =~ /^EraseHolidays$/i) { &EraseHolidays(); } else { push(@tmp,$_); } } @args=@tmp; # Read global config file if ($Curr{"InitFilesRead"}<1 && ! $Cnf{"IgnoreGlobalCnf"}) { $Curr{"InitFilesRead"}=1; if ($Cnf{"GlobalCnf"}) { $file=&ExpandTilde($Cnf{"GlobalCnf"}); &Date_InitFile($file) if ($file); } } # Read personal config file if ($Curr{"InitFilesRead"}<2) { $Curr{"InitFilesRead"}=2; if ($Cnf{"PersonalCnf"} and $Cnf{"PersonalCnfPath"}) { $file=&SearchPath($Cnf{"PersonalCnf"},$Cnf{"PersonalCnfPath"},"r"); &Date_InitFile($file) if ($file); } } foreach (@args) { s/\s*$//; s/^\s*//; /^(\S+) \s* = \s* (.*)$/x; ($var,$val)=($1,$2); $val="" if (! defined $val); &Date_SetConfigVariable($var,$val); } confess "ERROR: Unknown FirstDay in Date::Manip.\n" if (! &IsInt($Cnf{"FirstDay"},1,7)); confess "ERROR: Unknown WorkWeekBeg in Date::Manip.\n" if (! &IsInt($Cnf{"WorkWeekBeg"},1,7)); confess "ERROR: Unknown WorkWeekEnd in Date::Manip.\n" if (! &IsInt($Cnf{"WorkWeekEnd"},1,7)); confess "ERROR: Invalid WorkWeek in Date::Manip.\n" if ($Cnf{"WorkWeekEnd"} <= $Cnf{"WorkWeekBeg"}); my(%lang, $tmp,%tmp,$tmp2,@tmp2, $i,$j,@tmp3, $zonesrfc,@zones)=(); my($L)=$Cnf{"Language"}; if ($Curr{"InitLang"}) { $Curr{"InitLang"}=0; if ($L eq "English") { &Date_Init_English(\%lang); } elsif ($L eq "French") { &Date_Init_French(\%lang); } elsif ($L eq "Swedish") { &Date_Init_Swedish(\%lang); } elsif ($L eq "German") { &Date_Init_German(\%lang); } elsif ($L eq "Polish") { &Date_Init_Polish(\%lang); } elsif ($L eq "Dutch" || $L eq "Nederlands") { &Date_Init_Dutch(\%lang); } elsif ($L eq "Spanish") { &Date_Init_Spanish(\%lang); } elsif ($L eq "Portuguese") { &Date_Init_Portuguese(\%lang); } elsif ($L eq "Romanian") { &Date_Init_Romanian(\%lang); } elsif ($L eq "Italian") { &Date_Init_Italian(\%lang); } else { confess "ERROR: Unknown language in Date::Manip.\n"; } # variables for months # Month = "(jan|january|feb|february ... )" # MonL = [ "Jan","Feb",... ] # MonthL = [ "January","February", ... ] # MonthH = { "january"=>1, "jan"=>1, ... } $Lang{$L}{"MonthH"}={}; $Lang{$L}{"MonthL"}=[]; $Lang{$L}{"MonL"}=[]; &Date_InitLists([$lang{"month_name"}, $lang{"month_abb"}], \$Lang{$L}{"Month"},"lc,sort,back", [$Lang{$L}{"MonthL"}, $Lang{$L}{"MonL"}], [$Lang{$L}{"MonthH"},1]); # variables for day of week # Week = "(mon|monday|tue|tuesday ... )" # WL = [ "M","T",... ] # WkL = [ "Mon","Tue",... ] # WeekL = [ "Monday","Tudesday",... ] # WeekH = { "monday"=>1,"mon"=>1,"m"=>1,... } $Lang{$L}{"WeekH"}={}; $Lang{$L}{"WeekL"}=[]; $Lang{$L}{"WkL"}=[]; $Lang{$L}{"WL"}=[]; &Date_InitLists([$lang{"day_name"}, $lang{"day_abb"}], \$Lang{$L}{"Week"},"lc,sort,back", [$Lang{$L}{"WeekL"}, $Lang{$L}{"WkL"}], [$Lang{$L}{"WeekH"},1]); &Date_InitLists([$lang{"day_char"}], "","lc", [$Lang{$L}{"WL"}], [\%tmp,1]); %{ $Lang{$L}{"WeekH"} } = (%{ $Lang{$L}{"WeekH"} },%tmp); # variables for last # Last = "(last)" # LastL = [ "last" ] # Each = "(each)" # EachL = [ "each" ] # variables for day of month # DoM = "(1st|first ... 31st)" # DoML = [ "1st","2nd",... "31st" ] # DoMH = { "1st"=>1,"first"=>1, ... "31st"=>31 } # variables for week of month # WoM = "(1st|first| ... 5th|last)" # WoMH = { "1st"=>1, ... "5th"=>5,"last"=>-1 } $Lang{$L}{"LastL"}=$lang{"last"}; &Date_InitStrings($lang{"last"}, \$Lang{$L}{"Last"},"lc,sort"); $Lang{$L}{"EachL"}=$lang{"each"}; &Date_InitStrings($lang{"each"}, \$Lang{$L}{"Each"},"lc,sort"); $Lang{$L}{"DoMH"}={}; $Lang{$L}{"DoML"}=[]; &Date_InitLists([$lang{"num_suff"}, $lang{"num_word"}], \$Lang{$L}{"DoM"},"lc,sort,back,escape", [$Lang{$L}{"DoML"}, \@tmp], [$Lang{$L}{"DoMH"},1]); @tmp=(); foreach $tmp (keys %{ $Lang{$L}{"DoMH"} }) { $tmp2=$Lang{$L}{"DoMH"}{$tmp}; if ($tmp2<6) { $Lang{$L}{"WoMH"}{$tmp} = $tmp2; push(@tmp,$tmp); } } foreach $tmp (@{ $Lang{$L}{"LastL"} }) { $Lang{$L}{"WoMH"}{$tmp} = -1; push(@tmp,$tmp); } &Date_InitStrings(\@tmp,\$Lang{$L}{"WoM"}, "lc,sort,back,escape"); # variables for AM or PM # AM = "(am)" # PM = "(pm)" # AmPm = "(am|pm)" # AMstr = "AM" # PMstr = "PM" &Date_InitStrings($lang{"am"},\$Lang{$L}{"AM"},"lc,sort,escape"); &Date_InitStrings($lang{"pm"},\$Lang{$L}{"PM"},"lc,sort,escape"); &Date_InitStrings([ @{$lang{"am"}},@{$lang{"pm"}} ],\$Lang{$L}{"AmPm"}, "lc,back,sort,escape"); $Lang{$L}{"AMstr"}=$lang{"am"}[0]; $Lang{$L}{"PMstr"}=$lang{"pm"}[0]; # variables for expressions used in parsing deltas # Yabb = "(?:y|yr|year|years)" # Mabb = similar for months # Wabb = similar for weeks # Dabb = similar for days # Habb = similar for hours # MNabb = similar for minutes # Sabb = similar for seconds # Repl = { "abb"=>"replacement" } # Whenever an abbreviation could potentially refer to two different # strings (M standing for Minutes or Months), the abbreviation must # be listed in Repl instead of in the appropriate Xabb values. This # only applies to abbreviations which are substrings of other values # (so there is no confusion between Mn and Month). &Date_InitStrings($lang{"years"} ,\$Lang{$L}{"Yabb"}, "lc,sort"); &Date_InitStrings($lang{"months"} ,\$Lang{$L}{"Mabb"}, "lc,sort"); &Date_InitStrings($lang{"weeks"} ,\$Lang{$L}{"Wabb"}, "lc,sort"); &Date_InitStrings($lang{"days"} ,\$Lang{$L}{"Dabb"}, "lc,sort"); &Date_InitStrings($lang{"hours"} ,\$Lang{$L}{"Habb"}, "lc,sort"); &Date_InitStrings($lang{"minutes"},\$Lang{$L}{"MNabb"},"lc,sort"); &Date_InitStrings($lang{"seconds"},\$Lang{$L}{"Sabb"}, "lc,sort"); $Lang{$L}{"Repl"}={}; &Date_InitHash($lang{"replace"},undef,"lc",$Lang{$L}{"Repl"}); # variables for special dates that are offsets from now # Now = "(now|today)" # Offset = "(yesterday|tomorrow)" # OffsetH = { "yesterday"=>"-0:0:0:1:0:0:0",... ] # Times = "(noon|midnight)" # TimesH = { "noon"=>"12:00:00","midnight"=>"00:00:00" } # SepHM = hour/minute separator # SepMS = minute/second separator # SepSS = second/fraction separator $Lang{$L}{"TimesH"}={}; &Date_InitHash($lang{"times"}, \$Lang{$L}{"Times"},"lc,sort,back", $Lang{$L}{"TimesH"}); &Date_InitStrings($lang{"now"},\$Lang{$L}{"Now"},"lc,sort"); $Lang{$L}{"OffsetH"}={}; &Date_InitHash($lang{"offset"}, \$Lang{$L}{"Offset"},"lc,sort,back", $Lang{$L}{"OffsetH"}); $Lang{$L}{"SepHM"}=$lang{"sephm"}; $Lang{$L}{"SepMS"}=$lang{"sepms"}; $Lang{$L}{"SepSS"}=$lang{"sepss"}; # variables for time zones # zones = regular expression with all zone names (EST) # n2o = a hash of all parsable zone names with their offsets # tzones = reguar expression with all tzdata timezones (US/Eastern) # tz2z = hash of all tzdata timezones to full timezone (EST#EDT) $zonesrfc= "idlw -1200 ". # International Date Line West "nt -1100 ". # Nome "hst -1000 ". # Hawaii Standard "cat -1000 ". # Central Alaska "ahst -1000 ". # Alaska-Hawaii Standard "akst -0900 ". # Alaska Standard "yst -0900 ". # Yukon Standard "hdt -0900 ". # Hawaii Daylight "akdt -0800 ". # Alaska Daylight "ydt -0800 ". # Yukon Daylight "pst -0800 ". # Pacific Standard "pdt -0700 ". # Pacific Daylight "mst -0700 ". # Mountain Standard "mdt -0600 ". # Mountain Daylight "cst -0600 ". # Central Standard "cdt -0500 ". # Central Daylight "est -0500 ". # Eastern Standard "sat -0400 ". # Chile "edt -0400 ". # Eastern Daylight "ast -0400 ". # Atlantic Standard #"nst -0330 ". # Newfoundland Standard nst=North Sumatra +0630 "nft -0330 ". # Newfoundland #"gst -0300 ". # Greenland Standard gst=Guam Standard +1000 #"bst -0300 ". # Brazil Standard bst=British Summer +0100 "adt -0300 ". # Atlantic Daylight "ndt -0230 ". # Newfoundland Daylight "at -0200 ". # Azores "wat -0100 ". # West Africa "gmt +0000 ". # Greenwich Mean "ut +0000 ". # Universal "utc +0000 ". # Universal (Coordinated) "wet +0000 ". # Western European "west +0000 ". # Alias for Western European "cet +0100 ". # Central European "fwt +0100 ". # French Winter "met +0100 ". # Middle European "mez +0100 ". # Middle European "mewt +0100 ". # Middle European Winter "swt +0100 ". # Swedish Winter "bst +0100 ". # British Summer bst=Brazil standard -0300 "gb +0100 ". # GMT with daylight savings "eet +0200 ". # Eastern Europe, USSR Zone 1 "cest +0200 ". # Central European Summer "fst +0200 ". # French Summer "ist +0200 ". # Israel standard "mest +0200 ". # Middle European Summer "mesz +0200 ". # Middle European Summer "metdst +0200 ". # An alias for mest used by HP-UX "sast +0200 ". # South African Standard "sst +0200 ". # Swedish Summer sst=South Sumatra +0700 "bt +0300 ". # Baghdad, USSR Zone 2 "eest +0300 ". # Eastern Europe Summer "eetedt +0300 ". # Eastern Europe, USSR Zone 1 "idt +0300 ". # Israel Daylight "msk +0300 ". # Moscow "it +0330 ". # Iran "zp4 +0400 ". # USSR Zone 3 "msd +0400 ". # Moscow Daylight "zp5 +0500 ". # USSR Zone 4 "ist +0530 ". # Indian Standard "zp6 +0600 ". # USSR Zone 5 "nst +0630 ". # North Sumatra nst=Newfoundland Std -0330 #"sst +0700 ". # South Sumatra, USSR Zone 6 sst=Swedish Summer +0200 "hkt +0800 ". # Hong Kong "sgt +0800 ". # Singapore "cct +0800 ". # China Coast, USSR Zone 7 "awst +0800 ". # West Australian Standard "wst +0800 ". # West Australian Standard "pht +0800 ". # Asia Manila "kst +0900 ". # Republic of Korea "jst +0900 ". # Japan Standard, USSR Zone 8 "rok +0900 ". # Republic of Korea "cast +0930 ". # Central Australian Standard "east +1000 ". # Eastern Australian Standard "gst +1000 ". # Guam Standard, USSR Zone 9 gst=Greenland Std -0300 "cadt +1030 ". # Central Australian Daylight "eadt +1100 ". # Eastern Australian Daylight "idle +1200 ". # International Date Line East "nzst +1200 ". # New Zealand Standard "nzt +1200 ". # New Zealand "nzdt +1300 ". # New Zealand Daylight "z +0000 ". "a +0100 b +0200 c +0300 d +0400 e +0500 f +0600 g +0700 h +0800 ". "i +0900 k +1000 l +1100 m +1200 ". "n -0100 o -0200 p -0300 q -0400 r -0500 s -0600 t -0700 u -0800 ". "v -0900 w -1000 x -1100 y -1200"; $Zone{"n2o"} = {}; ($Zone{"zones"},%{ $Zone{"n2o"} })= &Date_Regexp($zonesrfc,"sort,lc,under,back", "keys"); $tmp= "US/Pacific PST8PDT ". "US/Mountain MST7MDT ". "US/Central CST6CDT ". "US/Eastern EST5EDT ". "Canada/Pacific PST8PDT ". "Canada/Mountain MST7MDT ". "Canada/Central CST6CDT ". "Canada/Eastern EST5EDT"; $Zone{"tz2z"} = {}; ($Zone{"tzones"},%{ $Zone{"tz2z"} })= &Date_Regexp($tmp,"lc,under,back","keys"); $Cnf{"TZ"}=&Date_TimeZone; # misc. variables # At = "(?:at)" # Of = "(?:in|of)" # On = "(?:on)" # Future = "(?:in)" # Later = "(?:later)" # Past = "(?:ago)" # Next = "(?:next)" # Prev = "(?:last|previous)" &Date_InitStrings($lang{"at"}, \$Lang{$L}{"At"}, "lc,sort"); &Date_InitStrings($lang{"on"}, \$Lang{$L}{"On"}, "lc,sort"); &Date_InitStrings($lang{"future"},\$Lang{$L}{"Future"}, "lc,sort"); &Date_InitStrings($lang{"later"}, \$Lang{$L}{"Later"}, "lc,sort"); &Date_InitStrings($lang{"past"}, \$Lang{$L}{"Past"}, "lc,sort"); &Date_InitStrings($lang{"next"}, \$Lang{$L}{"Next"}, "lc,sort"); &Date_InitStrings($lang{"prev"}, \$Lang{$L}{"Prev"}, "lc,sort"); &Date_InitStrings($lang{"of"}, \$Lang{$L}{"Of"}, "lc,sort"); # calc mode variables # Approx = "(?:approximately)" # Exact = "(?:exactly)" # Business = "(?:business)" &Date_InitStrings($lang{"exact"}, \$Lang{$L}{"Exact"}, "lc,sort"); &Date_InitStrings($lang{"approx"}, \$Lang{$L}{"Approx"}, "lc,sort"); &Date_InitStrings($lang{"business"},\$Lang{$L}{"Business"},"lc,sort"); ############### END OF LANGUAGE INITIALIZATION } if ($Curr{"ResetWorkDay"}) { my($h1,$m1,$h2,$m2)=(); if ($Cnf{"WorkDay24Hr"}) { ($Curr{"WDBh"},$Curr{"WDBm"})=(0,0); ($Curr{"WDEh"},$Curr{"WDEm"})=(24,0); $Curr{"WDlen"}=24*60; $Cnf{"WorkDayBeg"}="00:00"; $Cnf{"WorkDayEnd"}="23:59"; } else { confess "ERROR: Invalid WorkDayBeg in Date::Manip.\n" if (! (($h1,$m1)=&CheckTime($Cnf{"WorkDayBeg"}))); $Cnf{"WorkDayBeg"}="$h1:$m1"; confess "ERROR: Invalid WorkDayEnd in Date::Manip.\n" if (! (($h2,$m2)=&CheckTime($Cnf{"WorkDayEnd"}))); $Cnf{"WorkDayEnd"}="$h2:$m2"; ($Curr{"WDBh"},$Curr{"WDBm"})=($h1,$m1); ($Curr{"WDEh"},$Curr{"WDEm"})=($h2,$m2); # Work day length = h1:m1 or 0:len (len minutes) $h1=$h2-$h1; $m1=$m2-$m1; if ($m1<0) { $h1--; $m1+=60; } $Curr{"WDlen"}=$h1*60+$m1; } $Curr{"ResetWorkDay"}=0; } # current time my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst,$ampm,$wk)=(); if ($Cnf{"ForceDate"}=~ /^(\d{4})-(\d{2})-(\d{2})-(\d{2}):(\d{2}):(\d{2})$/) { ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6); } else { ($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst)=localtime(time); $y+=1900; $m++; } &Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk); $Curr{"Y"}=$y; $Curr{"M"}=$m; $Curr{"D"}=$d; $Curr{"H"}=$h; $Curr{"Mn"}=$mn; $Curr{"S"}=$s; $Curr{"AmPm"}=$ampm; $Curr{"Now"}=&Date_Join($y,$m,$d,$h,$mn,$s); $Curr{"Debug"}=$Curr{"DebugVal"}; # If we're in array context, let's return a list of config variables # that could be passed to Date_Init to get the same state as we're # currently in. if (wantarray) { # Some special variables that have to be in a specific order my(@special)=qw(IgnoreGlobalCnf GlobalCnf PersonalCnf PersonalCnfPath); my(%tmp)=map { $_,1 } @special; my(@tmp,$key,$val); foreach $key (@special) { $val=$Cnf{$key}; push(@tmp,"$key=$val"); } foreach $key (keys %Cnf) { next if (exists $tmp{$key}); $val=$Cnf{$key}; push(@tmp,"$key=$val"); } return @tmp; } return (); } sub ParseDateString { print "DEBUG: ParseDateString\n" if ($Curr{"Debug"} =~ /trace/); local($_)=@_; return "" if (! $_); my($y,$m,$d,$h,$mn,$s,$i,$wofm,$dofw,$wk,$tmp,$z,$num,$err,$iso,$ampm)=(); my($date,$z2,$delta,$from,$falsefrom,$to,$which,$midnight)=(); # We only need to reinitialize if we have to determine what NOW is. &Date_Init() if (! $Curr{"InitDone"} or $Cnf{"UpdateCurrTZ"}); my($L)=$Cnf{"Language"}; my($type)=$Cnf{"DateFormat"}; # Mode is set in DateCalc. ParseDate only overrides it if the string # contains a mode. if ($Lang{$L}{"Exact"} && s/$Lang{$L}{"Exact"}//) { $Curr{"Mode"}=0; } elsif ($Lang{$L}{"Approx"} && s/$Lang{$L}{"Approx"}//) { $Curr{"Mode"}=1; } elsif ($Lang{$L}{"Business"} && s/$Lang{$L}{"Business"}//) { $Curr{"Mode"}=2; } elsif (! exists $Curr{"Mode"}) { $Curr{"Mode"}=0; } # Unfortunately, some deltas can be parsed as dates. An example is # 1 second == 1 2nd == 1 2 # But, some dates can be parsed as deltas. The most important being: # 1998010101:00:00 # We'll check to see if a "date" can be parsed as a delta. If so, we'll # assume that it is a delta (since they are much simpler, it is much # less likely that we'll mistake a delta for a date than vice versa) # unless it is an ISO-8601 date. # # This is important because we are using DateCalc to test whether a # string is a date or a delta. Dates are tested first, so we need to # be able to pass a delta into this routine and have it correctly NOT # interpreted as a date. # # We will insist that the string contain something other than digits and # colons so that the following will get correctly interpreted as a date # rather than a delta: # 12:30 # 19980101 $delta=""; $delta=&ParseDateDelta($_) if (/[^:0-9]/); # Put parse in a simple loop for an easy exit. PARSE: { my(@tmp)=&Date_Split($_); if (@tmp) { ($y,$m,$d,$h,$mn,$s)=@tmp; last PARSE; } # Fundamental regular expressions my($month)=$Lang{$L}{"Month"}; # (jan|january|...) my(%month)=%{ $Lang{$L}{"MonthH"} }; # { jan=>1, ... } my($week)=$Lang{$L}{"Week"}; # (mon|monday|...) my(%week)=%{ $Lang{$L}{"WeekH"} }; # { mon=>1, monday=>1, ... } my($wom)=$Lang{$L}{"WoM"}; # (1st|...|fifth|last) my(%wom)=%{ $Lang{$L}{"WoMH"} }; # { 1st=>1,... fifth=>5,last=>-1 } my($dom)=$Lang{$L}{"DoM"}; # (1st|first|...31st) my(%dom)=%{ $Lang{$L}{"DoMH"} }; # { 1st=>1, first=>1, ... } my($ampmexp)=$Lang{$L}{"AmPm"}; # (am|pm) my($timeexp)=$Lang{$L}{"Times"}; # (noon|midnight) my($now)=$Lang{$L}{"Now"}; # (now|today) my($offset)=$Lang{$L}{"Offset"}; # (yesterday|tomorrow) my($zone)=$Zone{"zones"} . '(?:\s+|$)'; # (edt|est|...)\s+ my($day)='\s*'.$Lang{$L}{"Dabb"}; # \s*(?:d|day|days) my($mabb)='\s*'.$Lang{$L}{"Mabb"}; # \s*(?:mon|month|months) my($wkabb)='\s*'.$Lang{$L}{"Wabb"}; # \s*(?:w|wk|week|weeks) my($next)='\s*'.$Lang{$L}{"Next"}; # \s*(?:next) my($prev)='\s*'.$Lang{$L}{"Prev"}; # \s*(?:last|previous) my($past)='\s*'.$Lang{$L}{"Past"}; # \s*(?:ago) my($future)='\s*'.$Lang{$L}{"Future"}; # \s*(?:in) my($later)='\s*'.$Lang{$L}{"Later"}; # \s*(?:later) my($at)=$Lang{$L}{"At"}; # (?:at) my($of)='\s*'.$Lang{$L}{"Of"}; # \s*(?:in|of) my($on)='(?:\s*'.$Lang{$L}{"On"}.'\s*|\s+)'; # \s*(?:on)\s* or \s+ my($last)='\s*'.$Lang{$L}{"Last"}; # \s*(?:last) my($hm)=$Lang{$L}{"SepHM"}; # : my($ms)=$Lang{$L}{"SepMS"}; # : my($ss)=$Lang{$L}{"SepSS"}; # . # Other regular expressions my($D4)='(\d{4})'; # 4 digits (yr) my($YY)='(\d{4}|\d{2})'; # 2 or 4 digits (yr) my($DD)='(\d{2})'; # 2 digits (mon/day/hr/min/sec) my($D) ='(\d{1,2})'; # 1 or 2 digit (mon/day/hr) my($FS)="(?:$ss\\d+)?"; # fractional secs my($sep)='[\/.-]'; # non-ISO8601 m/d/yy separators # absolute time zone +0700 (GMT) my($hzone)='(?:[0-1][0-9]|2[0-3])'; # 00 - 23 my($mzone)='(?:[0-5][0-9])'; # 00 - 59 my($zone2)='(?:\s*([+-](?:'."$hzone$mzone|$hzone:$mzone|$hzone))". # +0700 +07:00 -07 '(?:\s*\([^)]+\))?)'; # (GMT) # A regular expression for the time EXCEPT for the hour part my($mnsec)="$hm$DD(?:$ms$DD$FS)?(?:\\s*$ampmexp)?"; # A special regular expression for /YYYY:HH:MN:SS used by Apache my($apachetime)='(/\d{4}):' . "$DD$hm$DD$ms$DD"; my($time)=""; $ampm=""; $date=""; # Substitute all special time expressions. if (/(^|[^a-z])$timeexp($|[^a-z])/i) { $tmp=$2; $tmp=$Lang{$L}{"TimesH"}{lc($tmp)}; s/(^|[^a-z])$timeexp($|[^a-z])/$1 $tmp $3/i; } # Remove some punctuation s/[,]/ /g; # Make sure that ...7EST works (i.e. a timezone immediately following # a digit. s/(\d)$zone(\s+|$|[0-9])/$1 $2$3/i; $zone = '\s+'.$zone; # Remove the time $iso=1; $midnight=0; $from="24${hm}00(?:${ms}00)?"; $falsefrom="${hm}24${ms}00"; # Don't trap XX:24:00 $to="00${hm}00${ms}00"; $midnight=1 if (!/$falsefrom/ && s/$from/$to/); $h=$mn=$s=0; if (/$D$mnsec/i || /$ampmexp/i) { $iso=0; $tmp=0; $tmp=1 if (/$mnsec$zone2?\s*$/i); # or /$mnsec$zone/ ?? $tmp=0 if (/$ampmexp/i); if (s/$apachetime$zone()/$1 /i || s/$apachetime$zone2?/$1 /i || s/(^|[^a-z])$at\s*$D$mnsec$zone()/$1 /i || s/(^|[^a-z])$at\s*$D$mnsec$zone2?/$1 /i || s/(^|[^0-9])(\d)$mnsec$zone()/$1 /i || s/(^|[^0-9])(\d)$mnsec$zone2?/$1 /i || (s/(t)$D$mnsec$zone()/$1 /i and (($iso=-$tmp) || 1)) || (s/(t)$D$mnsec$zone2?/$1 /i and (($iso=-$tmp) || 1)) || (s/()$DD$mnsec$zone()/ /i and (($iso=$tmp) || 1)) || (s/()$DD$mnsec$zone2?/ /i and (($iso=$tmp) || 1)) || s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone()/ /i || s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone2?/ /i || 0 ) { ($h,$mn,$s,$ampm,$z,$z2)=($2,$3,$4,$5,$6,$7); if (defined ($z)) { if ($z =~ /^[+-]\d{2}:\d{2}$/) { $z=~ s/://; } elsif ($z =~ /^[+-]\d{2}$/) { $z .= "00"; } } $time=1; &Date_TimeCheck(\$h,\$mn,\$s,\$ampm); $y=$m=$d=""; # We're going to be calling TimeCheck again below (when we check the # final date), so get rid of $ampm so that we don't have an error # due to "15:30:00 PM". It'll get reset below. $ampm=""; if (/^\s*$/) { &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); last PARSE; } } } $time=0 if ($time ne "1"); s/\s+$//; s/^\s+//; # dateTtime ISO 8601 formats my($orig)=$_; s/t$//i if ($iso<0); # Parse ISO 8601 dates now (which may still have a zone stuck to it). if ( ($iso && /^[0-9-]+(W[0-9-]+)?$zone?$/i) || ($iso && /^[0-9-]+(W[0-9-]+)?$zone2?$/i) || ($iso && /^[0-9-]+(T[0-9-]+)?$zone?$/i) || ($iso && /^[0-9-]+(T[0-9-]+)?$zone2?$/i) || 0) { # ISO 8601 dates s,-, ,g; # Change all ISO8601 seps to spaces s/^\s+//; s/\s+$//; if (/^$D4\s*$DD\s*$DD\s*t?$DD(?:$DD(?:$DD\d*)?)?$zone2?$/i || /^$D4\s*$DD\s*$DD\s*t?$DD(?:$DD(?:$DD\d*)?)?$zone?()$/i || /^$DD\s+$DD\s*$DD\s*t?$DD(?:$DD(?:$DD\d*)?)?$zone2?$/i || /^$DD\s+$DD\s*$DD\s*t?$DD(?:$DD(?:$DD\d*)?)?$zone?()$/i || 0 ) { # ISO 8601 Dates with times # YYYYMMDDHHMNSSFFFF # YYYYMMDDHHMNSS # YYYYMMDDHHMN # YYYYMMDDHH # YY MMDDHHMNSSFFFF # YY MMDDHHMNSS # YY MMDDHHMN # YY MMDDHH ($y,$m,$d,$h,$mn,$s,$tmp,$z2)=($1,$2,$3,$4,$5,$6,$7,$8); if ($h==24 && (! defined $mn || $mn==0) && (! defined $s || $s==0)) { $h=0; $midnight=1; } $z="" if (! $h); return "" if ($tmp and $z); $z=$tmp if ($tmp and $tmp); return "" if ($time); last PARSE; } elsif (/^$D4(?:\s*$DD(?:\s*$DD)?)?$/ || /^$DD(?:\s+$DD(?:\s*$DD)?)?$/) { # ISO 8601 Dates # YYYYMMDD # YYYYMM # YYYY # YY MMDD # YY MM # YY ($y,$m,$d)=($1,$2,$3); last PARSE; } elsif (/^$YY\s+$D\s+$D/) { # YY-M-D ($y,$m,$d)=($1,$2,$3); last PARSE; } elsif (/^$YY\s*W$DD\s*(\d)?$/i) { # YY-W##-D ($y,$wofm,$dofw)=($1,$2,$3); ($y,$m,$d)=&Date_NthWeekOfYear($y,$wofm,$dofw); last PARSE; } elsif (/^$D4\s*(\d{3})$/ || /^$DD\s*(\d{3})$/) { # YYDOY ($y,$which)=($1,$2); ($y,$m,$d)=&Date_NthDayOfYear($y,$which); last PARSE; } elsif ($iso<0) { # We confused something like 1999/August12:00:00 # with a dateTtime format $_=$orig; } else { return ""; } } # All deltas that are not ISO-8601 dates are NOT dates. return "" if ($Curr{"InCalc"} && $delta); if ($delta) { &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); return &DateCalc_DateDelta($Curr{"Now"},$delta); } # Check for some special types of dates (next, prev) foreach $from (keys %{ $Lang{$L}{"Repl"} }) { $to=$Lang{$L}{"Repl"}{$from}; s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i; } if (/$wom/i || /$future/i || /$later/i || /$past/i || /$next/i || /$prev/i || /^$week$/i || /$wkabb/i) { $tmp=0; if (/^$wom\s*$week$of\s*$month\s*$YY?$/i) { # last friday in October 95 ($wofm,$dofw,$m,$y)=($1,$2,$3,$4); # fix $m, $y return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); $dofw=$week{lc($dofw)}; $wofm=$wom{lc($wofm)}; # Get the first day of the month $date=&Date_Join($y,$m,1,$h,$mn,$s); if ($wofm==-1) { $date=&DateCalc_DateDelta($date,"+0:1:0:0:0:0:0",\$err,0); $date=&Date_GetPrev($date,$dofw,0); } else { for ($i=0; $i<$wofm; $i++) { if ($i==0) { $date=&Date_GetNext($date,$dofw,1); } else { $date=&Date_GetNext($date,$dofw,0); } } } last PARSE; } elsif (/^$last$day$of\s*$month(?:$of?\s*$YY)?/i) { # last day in month ($m,$y)=($1,$2); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $y=&Date_FixYear($y) if (! defined $y or length($y)<4); $m=$month{lc($m)}; $d=&Date_DaysInMonth($m,$y); last PARSE; } elsif (/^$week$/i) { # friday ($dofw)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&Date_GetPrev($Curr{"Now"},$Cnf{"FirstDay"},1); $date=&Date_GetNext($date,$dofw,1,$h,$mn,$s); last PARSE; } elsif (/^$next\s*$week$/i) { # next friday ($dofw)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&Date_GetNext($Curr{"Now"},$dofw,0,$h,$mn,$s); last PARSE; } elsif (/^$prev\s*$week$/i) { # last friday ($dofw)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&Date_GetPrev($Curr{"Now"},$dofw,0,$h,$mn,$s); last PARSE; } elsif (/^$next$wkabb$/i) { # next week &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:1:0:0:0:0",\$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$prev$wkabb$/i) { # last week &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:1:0:0:0:0",\$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$next$mabb$/i) { # next month &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:1:0:0:0:0:0",\$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$prev$mabb$/i) { # last month &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"-0:1:0:0:0:0:0",\$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$future\s*(\d+)$day$/i || /^(\d+)$day$later$/i) { # in 2 days # 2 days later ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:0:$num:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^(\d+)$day$past$/i) { # 2 days ago ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:0:$num:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$future\s*(\d+)$wkabb$/i || /^(\d+)$wkabb$later$/i) { # in 2 weeks # 2 weeks later ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:$num:0:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^(\d+)$wkabb$past$/i) { # 2 weeks ago ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:$num:0:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$future\s*(\d+)$mabb$/i || /^(\d+)$mabb$later$/i) { # in 2 months # 2 months later ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:$num:0:0:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^(\d+)$mabb$past$/i) { # 2 months ago ($num)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"-0:$num:0:0:0:0:0", \$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$week$future\s*(\d+)$wkabb$/i || /^$week\s*(\d+)$wkabb$later$/i) { # friday in 2 weeks # friday 2 weeks later ($dofw,$num)=($1,$2); $tmp="+"; } elsif (/^$week\s*(\d+)$wkabb$past$/i) { # friday 2 weeks ago ($dofw,$num)=($1,$2); $tmp="-"; } elsif (/^$future\s*(\d+)$wkabb$on$week$/i || /^(\d+)$wkabb$later$on$week$/i) { # in 2 weeks on friday # 2 weeks later on friday ($num,$dofw)=($1,$2); $tmp="+" } elsif (/^(\d+)$wkabb$past$on$week$/i) { # 2 weeks ago on friday ($num,$dofw)=($1,$2); $tmp="-"; } elsif (/^$week\s*$wkabb$/i) { # monday week (British date: in 1 week on monday) $dofw=$1; $num=1; $tmp="+"; } elsif (/^$now\s*$wkabb$/i) { # today week (British date: 1 week from today) &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:1:0:0:0:0",\$err,0); $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); last PARSE; } elsif (/^$offset\s*$wkabb$/i) { # tomorrow week (British date: 1 week from tomorrow) ($offset)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $offset=$Lang{$L}{"OffsetH"}{lc($offset)}; $date=&DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0); $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0); if ($time) { return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); $date=&Date_SetTime($date,$h,$mn,$s); } last PARSE; } if ($tmp) { &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=&DateCalc_DateDelta($Curr{"Now"}, $tmp . "0:0:$num:0:0:0:0",\$err,0); $date=&Date_GetPrev($date,$Cnf{"FirstDay"},1); $date=&Date_GetNext($date,$dofw,1,$h,$mn,$s); last PARSE; } } # Change (2nd, second) to 2 $tmp=0; if (/(^|[^a-z0-9])$dom($|[^a-z0-9])/i) { if (/^\s*$dom\s*$/) { ($d)=($1); $d=$dom{lc($d)}; $m=$Curr{"M"}; last PARSE; } $tmp=lc($2); $tmp=$dom{"$tmp"}; s/(^|[^a-z])$dom($|[^a-z])/$1 $tmp $3/i; s/^\s+//; s/\s+$//; } # Another set of special dates (Nth week) if (/^$D\s*$week(?:$of?\s*$YY)?$/i) { # 22nd sunday in 1996 ($which,$dofw,$y)=($1,$2,$3); $y=$Curr{"Y"} if (! $y); $tmp=&Date_GetNext("$y-01-01",$dofw,0); if ($which>1) { $tmp=&DateCalc_DateDelta($tmp,"+0:0:".($which-1).":0:0:0:0",\$err,0); } ($y,$m,$d)=(&Date_Split($tmp))[0..2]; last PARSE; } elsif (/^$week$wkabb\s*$D(?:$of?\s*$YY)?$/i || /^$week\s*$D$wkabb(?:$of?\s*$YY)?$/i) { # sunday week 22 in 1996 # sunday 22nd week in 1996 ($dofw,$which,$y)=($1,$2,$3); ($y,$m,$d)=&Date_NthWeekOfYear($y,$which,$dofw); last PARSE; } # Get rid of day of week if (/(^|[^a-z])$week($|[^a-z])/i) { $wk=$2; (s/(^|[^a-z])$week,/$1 /i) || s/(^|[^a-z])$week($|[^a-z])/$1 $3/i; s/^\s+//; s/\s+$//; } { # So that we can handle negative epoch times, let's convert # things like "epoch -" to "epochNEGATIVE " before we strip out # the $sep chars, which include '-'. s,epoch\s*-,epochNEGATIVE ,g; # Non-ISO8601 dates s,\s*$sep\s*, ,g; # change all non-ISO8601 seps to spaces s,^\s*,,; # remove leading/trailing space s,\s*$,,; if (/^$D\s+$D(?:\s+$YY)?$/) { # MM DD YY (DD MM YY non-US) ($m,$d,$y)=($1,$2,$3); ($m,$d)=($d,$m) if ($type ne "US"); last PARSE; } elsif (/^$D4\s*$D\s*$D$/) { # YYYY MM DD ($y,$m,$d)=($1,$2,$3); last PARSE; } elsif (s/(^|[^a-z])$month($|[^a-z])/$1 $3/i) { ($m)=($2); if (/^\s*$D(?:\s+$YY)?\s*$/) { # mmm DD YY # DD mmm YY # DD YY mmm ($d,$y)=($1,$2); last PARSE; } elsif (/^\s*$D$D4\s*$/) { # mmm DD YYYY # DD mmm YYYY # DD YYYY mmm ($d,$y)=($1,$2); last PARSE; } elsif (/^\s*$D4\s*$D\s*$/) { # mmm YYYY DD # YYYY mmm DD # YYYY DD mmm ($y,$d)=($1,$2); last PARSE; } elsif (/^\s*$D4\s*$/) { # mmm YYYY # YYYY mmm ($y,$d)=($1,1); last PARSE; } else { return ""; } } elsif (/^epochNEGATIVE (\d+)$/) { $s=$1; $date=&DateCalc("1970-01-01 00:00 GMT","-0:0:$s"); } elsif (/^epoch\s*(\d+)$/i) { $s=$1; $date=&DateCalc("1970-01-01 00:00 GMT","+0:0:$s"); } elsif (/^$now$/i) { # now, today &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $date=$Curr{"Now"}; if ($time) { return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); $date=&Date_SetTime($date,$h,$mn,$s); } last PARSE; } elsif (/^$offset$/i) { # yesterday, tomorrow ($offset)=($1); &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); $offset=$Lang{$L}{"OffsetH"}{lc($offset)}; $date=&DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0); if ($time) { return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); $date=&Date_SetTime($date,$h,$mn,$s); } last PARSE; } else { return ""; } } } if (! $date) { return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); $date=&Date_Join($y,$m,$d,$h,$mn,$s); } $date=&Date_ConvTZ($date,$z); if ($midnight) { $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0"); } return $date; } sub ParseDate { print "DEBUG: ParseDate\n" if ($Curr{"Debug"} =~ /trace/); &Date_Init() if (! $Curr{"InitDone"}); my($args,@args,@a,$ref,$date)=(); @a=@_; # @a : is the list of args to ParseDate. Currently, only one argument # is allowed and it must be a scalar (or a reference to a scalar) # or a reference to an array. if ($#a!=0) { print "ERROR: Invalid number of arguments to ParseDate.\n"; return ""; } $args=$a[0]; $ref=ref $args; if (! $ref) { return $args if (&Date_Split($args)); @args=($args); } elsif ($ref eq "ARRAY") { @args=@$args; } elsif ($ref eq "SCALAR") { return $$args if (&Date_Split($$args)); @args=($$args); } else { print "ERROR: Invalid arguments to ParseDate.\n"; return ""; } @a=@args; # @args : a list containing all the arguments (dereferenced if appropriate) # @a : a list containing all the arguments currently being examined # $ref : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a # reference to a scalar, or a reference to an array was passed in # $args : the scalar or refererence passed in PARSE: while($#a>=0) { $date=join(" ",@a); $date=&ParseDateString($date); last if ($date); pop(@a); } # PARSE splice(@args,0,$#a + 1); @$args= @args if (defined $ref and $ref eq "ARRAY"); $date; } sub Date_Cmp { my($D1,$D2)=@_; my($date1)=&ParseDateString($D1); my($date2)=&ParseDateString($D2); return $date1 cmp $date2; } # **NOTE** # The calc routines all call parse routines, so it is never necessary to # call Date_Init in the calc routines. sub DateCalc { print "DEBUG: DateCalc\n" if ($Curr{"Debug"} =~ /trace/); my($D1,$D2,@arg)=@_; my($ref,$err,$errref,$mode)=(); $errref=shift(@arg); $ref=0; if (defined $errref) { if (ref $errref) { $mode=shift(@arg); $ref=1; } else { $mode=$errref; $errref=""; } } my(@date,@delta,$ret,$tmp,$old)=(); if (defined $mode and $mode>=0 and $mode<=3) { $Curr{"Mode"}=$mode; } else { $Curr{"Mode"}=0; } $old=$Curr{"InCalc"}; $Curr{"InCalc"}=1; if ($tmp=&ParseDateString($D1)) { # If we've already parsed the date, we don't want to do it a second # time (so we don't convert timezones twice). if (&Date_Split($D1)) { push(@date,$D1); } else { push(@date,$tmp); } } elsif ($tmp=&ParseDateDelta($D1)) { push(@delta,$tmp); } else { $$errref=1 if ($ref); return; } if ($tmp=&ParseDateString($D2)) { if (&Date_Split($D2)) { push(@date,$D2); } else { push(@date,$tmp); } } elsif ($tmp=&ParseDateDelta($D2)) { push(@delta,$tmp); } else { $$errref=2 if ($ref); return; } $mode=$Curr{"Mode"}; $Curr{"InCalc"}=$old; if ($#date==1) { $ret=&DateCalc_DateDate(@date,$mode); } elsif ($#date==0) { $ret=&DateCalc_DateDelta(@date,@delta,\$err,$mode); $$errref=$err if ($ref); } else { $ret=&DateCalc_DeltaDelta(@delta,$mode); } $ret; } sub ParseDateDelta { print "DEBUG: ParseDateDelta\n" if ($Curr{"Debug"} =~ /trace/); my($args,@args,@a,$ref)=(); local($_)=(); @a=@_; # @a : is the list of args to ParseDateDelta. Currently, only one argument # is allowed and it must be a scalar (or a reference to a scalar) # or a reference to an array. if ($#a!=0) { print "ERROR: Invalid number of arguments to ParseDateDelta.\n"; return ""; } $args=$a[0]; $ref=ref $args; if (! $ref) { @args=($args); } elsif ($ref eq "ARRAY") { @args=@$args; } elsif ($ref eq "SCALAR") { @args=($$args); } else { print "ERROR: Invalid arguments to ParseDateDelta.\n"; return ""; } @a=@args; # @args : a list containing all the arguments (dereferenced if appropriate) # @a : a list containing all the arguments currently being examined # $ref : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a # reference to a scalar, or a reference to an array was passed in # $args : the scalar or refererence passed in my(@colon,@delta,$delta,$dir,$colon,$sign,$val)=(); my($len,$tmp,$tmp2,$tmpl)=(); my($from,$to)=(); my($workweek)=$Cnf{"WorkWeekEnd"}-$Cnf{"WorkWeekBeg"}+1; &Date_Init() if (! $Curr{"InitDone"}); my($signexp)='([+-]?)'; my($numexp)='(\d+)'; my($exp1)="(?: \\s* $signexp \\s* $numexp \\s*)"; my($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp,$i)=(); $yexp=$mexp=$wexp=$dexp=$hexp=$mnexp=$sexp="()()"; $yexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Yabb"} .")?"; $mexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Mabb"} .")?"; $wexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Wabb"} .")?"; $dexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Dabb"} .")?"; $hexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Habb"} .")?"; $mnexp="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"MNabb"}.")?"; $sexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Sabb"} ."?)?"; my($future)=$Lang{$Cnf{"Language"}}{"Future"}; my($later)=$Lang{$Cnf{"Language"}}{"Later"}; my($past)=$Lang{$Cnf{"Language"}}{"Past"}; $delta=""; PARSE: while (@a) { $_ = join(" ", grep {defined;} @a); s/\s+$//; last if ($_ eq ""); # Mode is set in DateCalc. ParseDateDelta only overrides it if the # string contains a mode. if ($Lang{$Cnf{"Language"}}{"Exact"} && s/$Lang{$Cnf{"Language"}}{"Exact"}//) { $Curr{"Mode"}=0; } elsif ($Lang{$Cnf{"Language"}}{"Approx"} && s/$Lang{$Cnf{"Language"}}{"Approx"}//) { $Curr{"Mode"}=1; } elsif ($Lang{$Cnf{"Language"}}{"Business"} && s/$Lang{$Cnf{"Language"}}{"Business"}//) { $Curr{"Mode"}=2; } elsif (! exists $Curr{"Mode"}) { $Curr{"Mode"}=0; } $workweek=7 if ($Curr{"Mode"} != 2); foreach $from (keys %{ $Lang{$Cnf{"Language"}}{"Repl"} }) { $to=$Lang{$Cnf{"Language"}}{"Repl"}{$from}; s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i; } # in or ago # # We need to make sure that $later, $future, and $past don't contain each # other... Romanian pointed this out where $past is "in urma" and $future # is "in". When they do, we have to take this into account. # $len length of best match (greatest wins) # $tmp string after best match # $dir direction (prior, after) of best match # # $tmp2 string before/after current match # $tmpl length of current match $len=0; $tmp=$_; $dir=1; $tmp2=$_; if ($tmp2 =~ s/(^|[^a-z])($future)($|[^a-z])/$1 $3/i) { $tmpl=length($2); if ($tmpl>$len) { $tmp=$tmp2; $dir=1; $len=$tmpl; } } $tmp2=$_; if ($tmp2 =~ s/(^|[^a-z])($later)($|[^a-z])/$1 $3/i) { $tmpl=length($2); if ($tmpl>$len) { $tmp=$tmp2; $dir=1; $len=$tmpl; } } $tmp2=$_; if ($tmp2 =~ s/(^|[^a-z])($past)($|[^a-z])/$1 $3/i) { $tmpl=length($2); if ($tmpl>$len) { $tmp=$tmp2; $dir=-1; $len=$tmpl; } } $_ = $tmp; s/\s*$//; # the colon part of the delta $colon=""; if (s/($signexp?$numexp?(:($signexp?$numexp)?){1,6})$//) { $colon=$1; s/\s+$//; } @colon=split(/:/,$colon); # the non-colon part of the delta $sign="+"; @delta=(); $i=6; foreach $exp1 ($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp) { last if ($#colon>=$i--); $val=0; if (s/^$exp1//ix) { $val=$2 if ($2); $sign=$1 if ($1); } push(@delta,"$sign$val"); } if (! /^\s*$/) { pop(@a); next PARSE; } # make sure that the colon part has a sign for ($i=0; $i<=$#colon; $i++) { $val=0; if ($colon[$i] =~ /^$signexp$numexp?/) { $val=$2 if ($2); $sign=$1 if ($1); } $colon[$i] = "$sign$val"; } # combine the two push(@delta,@colon); if ($dir<0) { for ($i=0; $i<=$#delta; $i++) { $delta[$i] =~ tr/-+/+-/; } } # form the delta and shift off the valid part $delta=join(":",@delta); splice(@args,0,$#a+1); @$args=@args if (defined $ref and $ref eq "ARRAY"); last PARSE; } $delta=&Delta_Normalize($delta,$Curr{"Mode"}); return $delta; } sub UnixDate { print "DEBUG: UnixDate\n" if ($Curr{"Debug"} =~ /trace/); my($date,@format)=@_; local($_)=(); my($format,%f,$out,@out,$c,$date1,$date2,$tmp)=(); my($scalar)=(); $date=&ParseDateString($date); return if (! $date); my($y,$m,$d,$h,$mn,$s)=($f{"Y"},$f{"m"},$f{"d"},$f{"H"},$f{"M"},$f{"S"})= &Date_Split($date); $f{"y"}=substr $f{"Y"},2; &Date_Init() if (! $Curr{"InitDone"}); if (! wantarray) { $format=join(" ",@format); @format=($format); $scalar=1; } # month, week $_=$m; s/^0//; $f{"b"}=$f{"h"}=$Lang{$Cnf{"Language"}}{"MonL"}[$_-1]; $f{"B"}=$Lang{$Cnf{"Language"}}{"MonthL"}[$_-1]; $_=$m; s/^0/ /; $f{"f"}=$_; $f{"U"}=&Date_WeekOfYear($m,$d,$y,7); $f{"W"}=&Date_WeekOfYear($m,$d,$y,1); # check week 52,53 and 0 $f{"G"}=$f{"L"}=$y; if ($f{"W"}>=52 || $f{"U"}>=52) { my($dd,$mm,$yy)=($d,$m,$y); $dd+=7; if ($dd>31) { $dd-=31; $mm=1; $yy++; if (&Date_WeekOfYear($mm,$dd,$yy,1)==2) { $f{"G"}=$yy; $f{"W"}=1; } if (&Date_WeekOfYear($mm,$dd,$yy,7)==2) { $f{"L"}=$yy; $f{"U"}=1; } } } if ($f{"W"}==0) { my($dd,$mm,$yy)=($d,$m,$y); $dd-=7; $dd+=31 if ($dd<1); $yy--; $mm=12; $f{"G"}=$yy; $f{"W"}=&Date_WeekOfYear($mm,$dd,$yy,1)+1; } if ($f{"U"}==0) { my($dd,$mm,$yy)=($d,$m,$y); $dd-=7; $dd+=31 if ($dd<1); $yy--; $mm=12; $f{"L"}=$yy; $f{"U"}=&Date_WeekOfYear($mm,$dd,$yy,7)+1; } $f{"U"}="0".$f{"U"} if (length $f{"U"} < 2); $f{"W"}="0".$f{"W"} if (length $f{"W"} < 2); # day $f{"j"}=&Date_DayOfYear($m,$d,$y); $f{"j"} = "0" . $f{"j"} while (length($f{"j"})<3); $_=$d; s/^0/ /; $f{"e"}=$_; $f{"w"}=&Date_DayOfWeek($m,$d,$y); $f{"v"}=$Lang{$Cnf{"Language"}}{"WL"}[$f{"w"}-1]; $f{"v"}=" ".$f{"v"} if (length $f{"v"} < 2); $f{"a"}=$Lang{$Cnf{"Language"}}{"WkL"}[$f{"w"}-1]; $f{"A"}=$Lang{$Cnf{"Language"}}{"WeekL"}[$f{"w"}-1]; $f{"E"}=&Date_DaySuffix($f{"e"}); # hour $_=$h; s/^0/ /; $f{"k"}=$_; $f{"i"}=$f{"k"}+1; $f{"i"}=$f{"k"}; $f{"i"}=12 if ($f{"k"}==0); $f{"i"}=$f{"k"}-12 if ($f{"k"}>12); $f{"i"}=$f{"i"}-12 if ($f{"i"}>12); $f{"i"}=" ".$f{"i"} if (length($f{"i"})<2); $f{"I"}=$f{"i"}; $f{"I"}=~ s/^ /0/; $f{"p"}=$Lang{$Cnf{"Language"}}{"AMstr"}; $f{"p"}=$Lang{$Cnf{"Language"}}{"PMstr"} if ($f{"k"}>11); # minute, second, timezone $f{"o"}=&Date_SecsSince1970($m,$d,$y,$h,$mn,$s); $f{"s"}=&Date_SecsSince1970GMT($m,$d,$y,$h,$mn,$s); $f{"Z"}=($Cnf{"ConvTZ"} eq "IGNORE" or $Cnf{"ConvTZ"} eq "") ? $Cnf{"TZ"} : $Cnf{"ConvTZ"}; $f{"z"}=($Zone{"n2o"}{lc $f{"Z"}} || ""); # date, time $f{"c"}=qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $y|; $f{"C"}=$f{"u"}= qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $f{"z"} $y|; $f{"g"}=qq|$f{"a"}, $d $f{"b"} $y $h:$mn:$s $f{"z"}|; $f{"D"}=$f{"x"}=qq|$m/$d/$f{"y"}|; $f{"r"}=qq|$f{"I"}:$mn:$s $f{"p"}|; $f{"R"}=qq|$h:$mn|; $f{"T"}=$f{"X"}=qq|$h:$mn:$s|; $f{"V"}=qq|$m$d$h$mn$f{"y"}|; $f{"Q"}="$y$m$d"; $f{"q"}=qq|$y$m$d$h$mn$s|; $f{"P"}=qq|$y$m$d$h:$mn:$s|; $f{"F"}=qq|$f{"A"}, $f{"B"} $f{"e"}, $f{"Y"}|; if ($f{"W"}==0) { $y--; $tmp=&Date_WeekOfYear(12,31,$y,1); $tmp="0$tmp" if (length($tmp) < 2); $f{"J"}=qq|$y-W$tmp-$f{"w"}|; } else { $f{"J"}=qq|$f{"G"}-W$f{"W"}-$f{"w"}|; } $f{"K"}=qq|$y-$f{"j"}|; # %l is a special case. Since it requires the use of the calculator # which requires this routine, an infinite recursion results. To get # around this, %l is NOT determined every time this is called so the # recursion breaks. # other formats $f{"n"}="\n"; $f{"t"}="\t"; $f{"%"}="%"; $f{"+"}="+"; foreach $format (@format) { $format=reverse($format); $out=""; while ($format ne "") { $c=chop($format); if ($c eq "%") { $c=chop($format); if ($c eq "l") { &Date_Init(); $date1=&DateCalc_DateDelta($Curr{"Now"},"-0:6:0:0:0:0:0"); $date2=&DateCalc_DateDelta($Curr{"Now"},"+0:6:0:0:0:0:0"); if (&Date_Cmp($date,$date1)>=0 && &Date_Cmp($date,$date2)<=0) { $f{"l"}=qq|$f{"b"} $f{"e"} $h:$mn|; } else { $f{"l"}=qq|$f{"b"} $f{"e"} $f{"Y"}|; } $out .= $f{"$c"}; } elsif (exists $f{"$c"}) { $out .= $f{"$c"}; } else { $out .= $c; } } else { $out .= $c; } } push(@out,$out); } if ($scalar) { return $out[0]; } else { return (@out); } } # Can't be in "use integer" because we're doing decimal arithmatic no integer; sub Delta_Format { print "DEBUG: Delta_Format\n" if ($Curr{"Debug"} =~ /trace/); my($delta,$dec,@format)=@_; $delta=&ParseDateDelta($delta); return "" if (! $delta); my(@out,%f,$out,$c1,$c2,$scalar,$format)=(); local($_)=$delta; my($y,$M,$w,$d,$h,$m,$s)=&Delta_Split($delta); # Get rid of positive signs. ($y,$M,$w,$d,$h,$m,$s)=map { 1*$_; }($y,$M,$w,$d,$h,$m,$s); if (defined $dec && $dec>0) { $dec="%." . ($dec*1) . "f"; } else { $dec="%f"; } if (! wantarray) { $format=join(" ",@format); @format=($format); $scalar=1; } # Length of each unit in seconds my($sl,$ml,$hl,$dl,$wl)=(); $sl = 1; $ml = $sl*60; $hl = $ml*60; $dl = $hl*24; $wl = $dl*7; # The decimal amount of each unit contained in all smaller units my($yd,$Md,$sd,$md,$hd,$dd,$wd)=(); $yd = $M/12; $Md = 0; $wd = ($d*$dl + $h*$hl + $m*$ml + $s*$sl)/$wl; $dd = ($h*$hl + $m*$ml + $s*$sl)/$dl; $hd = ($m*$ml + $s*$sl)/$hl; $md = ($s*$sl)/$ml; $sd = 0; # The amount of each unit contained in higher units. my($yh,$Mh,$sh,$mh,$hh,$dh,$wh)=(); $yh = 0; $Mh = ($yh+$y)*12; $wh = 0; $dh = ($wh+$w)*7; $hh = ($dh+$d)*24; $mh = ($hh+$h)*60; $sh = ($mh+$m)*60; # Set up the formats $f{"yv"} = $y; $f{"Mv"} = $M; $f{"wv"} = $w; $f{"dv"} = $d; $f{"hv"} = $h; $f{"mv"} = $m; $f{"sv"} = $s; $f{"yh"} = $y+$yh; $f{"Mh"} = $M+$Mh; $f{"wh"} = $w+$wh; $f{"dh"} = $d+$dh; $f{"hh"} = $h+$hh; $f{"mh"} = $m+$mh; $f{"sh"} = $s+$sh; $f{"yd"} = sprintf($dec,$y+$yd); $f{"Md"} = sprintf($dec,$M+$Md); $f{"wd"} = sprintf($dec,$w+$wd); $f{"dd"} = sprintf($dec,$d+$dd); $f{"hd"} = sprintf($dec,$h+$hd); $f{"md"} = sprintf($dec,$m+$md); $f{"sd"} = sprintf($dec,$s+$sd); $f{"yt"} = sprintf($dec,$yh+$y+$yd); $f{"Mt"} = sprintf($dec,$Mh+$M+$Md); $f{"wt"} = sprintf($dec,$wh+$w+$wd); $f{"dt"} = sprintf($dec,$dh+$d+$dd); $f{"ht"} = sprintf($dec,$hh+$h+$hd); $f{"mt"} = sprintf($dec,$mh+$m+$md); $f{"st"} = sprintf($dec,$sh+$s+$sd); $f{"%"} = "%"; foreach $format (@format) { $format=reverse($format); $out=""; PARSE: while ($format) { $c1=chop($format); if ($c1 eq "%") { $c1=chop($format); if (exists($f{$c1})) { $out .= $f{$c1}; next PARSE; } $c2=chop($format); if (exists($f{"$c1$c2"})) { $out .= $f{"$c1$c2"}; next PARSE; } $out .= $c1; $format .= $c2; } else { $out .= $c1; } } push(@out,$out); } if ($scalar) { return $out[0]; } else { return (@out); } } use integer; sub ParseRecur { print "DEBUG: ParseRecur\n" if ($Curr{"Debug"} =~ /trace/); &Date_Init() if (! $Curr{"InitDone"}); my($recur,$dateb,$date0,$date1,$flag)=@_; local($_)=$recur; my($recur_0,$recur_1,@recur0,@recur1)=(); my(@tmp,$tmp,$each,$num,$y,$m,$d,$w,$h,$mn,$s,$delta,$y0,$y1,$yb)=(); my($yy,$n,$dd,@d,@tmp2,$date,@date,@w,@tmp3,@m,@y,$tmp2,$d2,@flags)=(); # $date0, $date1, $dateb, $flag : passed in (these are always the final say # in determining whether a date matches a # recurrence IF they are present. # $date_b, $date_0, $date_1 : if a value can be determined from the # $flag_t recurrence, they are stored here. # # If values can be determined from the recurrence AND are passed in, the # following are used: # max($date0,$date_0) i.e. the later of the two dates # min($date1,$date_1) i.e. the earlier of the two dates # # The base date that is used is the first one defined from # $dateb $date_b # The base date is only used if necessary (as determined by the recur). # For example, "every other friday" requires a base date, but "2nd # friday of every month" doesn't. my($date_b,$date_0,$date_1,$flag_t); # # Check the arguments passed in. # $date0="" if (! defined $date0); $date1="" if (! defined $date1); $dateb="" if (! defined $dateb); $flag ="" if (! defined $flag); if ($dateb) { $dateb=&ParseDateString($dateb); return "" if (! $dateb); } if ($date0) { $date0=&ParseDateString($date0); return "" if (! $date0); } if ($date1) { $date1=&ParseDateString($date1); return "" if (! $date1); } # # Parse the recur. $date_b, $date_0, and $date_e are values obtained # from the recur. # @tmp=&Recur_Split($_); if (@tmp) { ($recur_0,$recur_1,$flag_t,$date_b,$date_0,$date_1)=@tmp; $recur_0 = "" if (! defined $recur_0); $recur_1 = "" if (! defined $recur_1); $flag_t = "" if (! defined $flag_t); $date_b = "" if (! defined $date_b); $date_0 = "" if (! defined $date_0); $date_1 = "" if (! defined $date_1); @recur0 = split(/:/,$recur_0); @recur1 = split(/:/,$recur_1); return "" if ($#recur0 + $#recur1 + 2 != 7); if ($date_b) { $date_b=&ParseDateString($date_b); return "" if (! $date_b); } if ($date_0) { $date_0=&ParseDateString($date_0); return "" if (! $date_0); } if ($date_1) { $date_1=&ParseDateString($date_1); return "" if (! $date_1); } } else { my($mmm)='\s*'.$Lang{$Cnf{"Language"}}{"Month"}; # \s*(jan|january|...) my(%mmm)=%{ $Lang{$Cnf{"Language"}}{"MonthH"} }; # { jan=>1, ... } my($wkexp)='\s*'.$Lang{$Cnf{"Language"}}{"Week"}; # \s*(mon|monday|...) my(%week)=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; # { monday=>1, ... } my($day)='\s*'.$Lang{$Cnf{"Language"}}{"Dabb"}; # \s*(?:d|day|days) my($month)='\s*'.$Lang{$Cnf{"Language"}}{"Mabb"}; # \s*(?:mon|month|months) my($week)='\s*'.$Lang{$Cnf{"Language"}}{"Wabb"}; # \s*(?:w|wk|week|weeks) my($daysexp)=$Lang{$Cnf{"Language"}}{"DoM"}; # (1st|first|...31st) my(%dayshash)=%{ $Lang{$Cnf{"Language"}}{"DoMH"} }; # { 1st=>1,first=>1,...} my($of)='\s*'.$Lang{$Cnf{"Language"}}{"Of"}; # \s*(?:in|of) my($lastexp)=$Lang{$Cnf{"Language"}}{"Last"}; # (?:last) my($each)=$Lang{$Cnf{"Language"}}{"Each"}; # (?:each|every) my($D)='\s*(\d+)'; my($Y)='\s*(\d{4}|\d{2})'; # Change 1st to 1 if (/(^|[^a-z])$daysexp($|[^a-z])/i) { $tmp=lc($2); $tmp=$dayshash{"$tmp"}; s/(^|[^a-z])$daysexp($|[^a-z])/$1 $tmp $3/i; } s/\s*$//; # Get rid of "each" if (/(^|[^a-z])$each($|[^a-z])/i) { s/(^|[^a-z])$each($|[^a-z])/$1 $2/i; $each=1; } else { $each=0; } if ($each) { if (/^$D?$day(?:$of$mmm?$Y)?$/i || /^$D?$day(?:$of$mmm())?$/i) { # every [2nd] day in [june] 1997 # every [2nd] day [in june] ($num,$m,$y)=($1,$2,$3); $num=1 if (! defined $num); $m="" if (! defined $m); $y="" if (! defined $y); $y=$Curr{"Y"} if (! $y); if ($m) { $m=$mmm{lc($m)}; $date_0=&Date_Join($y,$m,1,0,0,0); $date_1=&DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0); } else { $date_0=&Date_Join($y, 1,1,0,0,0); $date_1=&Date_Join($y+1,1,1,0,0,0); } $date_b=&DateCalc($date_0,"-0:0:0:1:0:0:0",0); @recur0=(0,0,0,$num,0,0,0); @recur1=(); } elsif (/^$D$day?$of$month(?:$of?$Y)?$/) { # 2nd [day] of every month [in 1997] ($num,$y)=($1,$2); $y=$Curr{"Y"} if (! $y); $date_0=&Date_Join($y, 1,1,0,0,0); $date_1=&Date_Join($y+1,1,1,0,0,0); $date_b=$date_0; @recur0=(0,1,0); @recur1=($num,0,0,0); } elsif (/^$D$wkexp$of$month(?:$of?$Y)?$/ || /^($lastexp)$wkexp$of$month(?:$of?$Y)?$/) { # 2nd tuesday of every month [in 1997] # last tuesday of every month [in 1997] ($num,$d,$y)=($1,$2,$3); $y=$Curr{"Y"} if (! $y); $d=$week{lc($d)}; $num=-1 if ($num !~ /^$D$/); $date_0=&Date_Join($y,1,1,0,0,0); $date_1=&Date_Join($y+1,1,1,0,0,0); $date_b=$date_0; @recur0=(0,1); @recur1=($num,$d,0,0,0); } elsif (/^$D$wkexp(?:$of$mmm?$Y)?$/i || /^$D$wkexp(?:$of$mmm())?$/i) { # every 2nd tuesday in june 1997 ($num,$d,$m,$y)=($1,$2,$3,$4); $y=$Curr{"Y"} if (! $y); $num=1 if (! defined $num); $m="" if (! defined $m); $d=$week{lc($d)}; if ($m) { $m=$mmm{lc($m)}; $date_0=&Date_Join($y,$m,1,0,0,0); $date_1=&DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0); } else { $date_0=&Date_Join($y,1,1,0,0,0); $date_1=&Date_Join($y+1,1,1,0,0,0); } $date_b=&DateCalc($date_0,"-0:0:0:1:0:0:0",0); @recur0=(0,0,$num); @recur1=($d,0,0,0); } else { return ""; } $date_0="" if ($date0); $date_1="" if ($date1); } else { return ""; } } # # Override with any values passed in # if ($date0 && $date_0) { $date0=( &Date_Cmp($date0,$date_0) > 1 ? $date0 : $date_0); } elsif ($date_0) { $date0 = $date_0; } if ($date1 && $date_1) { $date1=( &Date_Cmp($date1,$date_1) > 1 ? $date_1 : $date1); } elsif ($date_1) { $date1 = $date_1; } $dateb=$date_b if (! $dateb); if ($flag =~ s/^\+//) { if ($flag_t) { $flag="$flag_t,$flag"; } } $flag =$flag_t if (! $flag && $flag_t); if (! wantarray) { $tmp = join(":",@recur0); $tmp .= "*" . join(":",@recur1) if (@recur1); $tmp .= "*$flag*$dateb*$date0*$date1"; return $tmp; } if (@recur0) { return () if (! $date0 || ! $date1); # dateb is NOT required in all case } # # Some flags affect parsing. # @flags = split(/,/,$flag); my($MDn) = 0; my($MWn) = 7; my($f); foreach $f (@flags) { if ($f =~ /^MW([1-7])$/i) { $MWn=$1; $MDn=0; } elsif ($f =~ /^MD([1-7])$/i) { $MDn=$1; $MWn=0; } elsif ($f =~ /^EASTER$/i) { ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1); # We want something that will return Jan 1 for the given years. if ($#recur0==-1) { @recur1=($y,1,0,1,$h,$mn,$s); } elsif ($#recur0<=3) { @recur0=($y,0,0,0); @recur1=($h,$mn,$s); } elsif ($#recur0==4) { @recur0=($y,0,0,0,0); @recur1=($mn,$s); } elsif ($#recur0==5) { @recur0=($y,0,0,0,0,0); @recur1=($s); } else { @recur0=($y,0,0,0,0,0,0); } } } # # Determine the dates referenced by the recur. Also, fix the base date # as necessary for the recurrences which require it. # ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1); @y=@m=@w=@d=(); my(@time)=($h,$mn,$s); RECUR: while (1) { if ($#recur0==-1) { # * Y-M-W-D-H-MN-S if ($y eq "0") { push(@recur0,0); shift(@recur1); } else { @y=&ReturnList($y); foreach $y (@y) { $y=&Date_FixYear($y) if (length($y)==2); return () if (length($y)!=4 || ! &IsInt($y)); } @y=sort { $a<=>$b } @y; $date0=&ParseDate("0000-01-01") if (! $date0); $date1=&ParseDate("9999-12-31 23:59:59") if (! $date1); if ($m eq "0" and $w eq "0") { # * Y-0-0-0-H-MN-S # * Y-0-0-DOY-H-MN-S if ($d eq "0") { @d=(1); } else { @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,366)); } @d=sort { $a<=>$b } (@d); } @date=(); foreach $yy (@y) { foreach $d (@d) { ($y,$m,$dd)=&Date_NthDayOfYear($yy,$d); push(@date, &Date_Join($y,$m,$dd,0,0,0)); } } last RECUR; } elsif ($w eq "0") { # * Y-M-0-0-H-MN-S # * Y-M-0-DOM-H-MN-S @m=&ReturnList($m); return () if (! @m); foreach $m (@m) { return () if (! &IsInt($m,1,12)); } @m=sort { $a<=>$b } (@m); if ($d eq "0") { @d=(1); } else { @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,31)); } @d=sort { $a<=>$b } (@d); } @date=(); foreach $y (@y) { foreach $m (@m) { foreach $d (@d) { $date=&Date_Join($y,$m,$d,0,0,0); push(@date,$date) if ($d<29 || &Date_Split($date)); } } } last RECUR; } elsif ($m eq "0") { # * Y-0-WOY-DOW-H-MN-S # * Y-0-WOY-0-H-MN-S @w=&ReturnList($w); return () if (! @w); foreach $w (@w) { return () if (! &IsInt($w,1,53)); } if ($d eq "0") { @d=($Cnf{"FirstDay"}); } else { @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,7)); } @d=sort { $a<=>$b } (@d); } @date=(); foreach $y (@y) { foreach $w (@w) { $w="0$w" if (length($w)==1); foreach $d (@d) { $date=&ParseDateString("$y-W$w-$d"); push(@date,$date); } } } last RECUR; } else { # * Y-M-WOM-DOW-H-MN-S # * Y-M-WOM-0-H-MN-S @m=&ReturnList($m); return () if (! @m); foreach $m (@m) { return () if (! &IsInt($m,1,12)); } @m=sort { $a<=>$b } (@m); @w=&ReturnList($w); if ($d eq "0") { @d=(); } else { @d=&ReturnList($d); } @date=&Date_Recur_WoM(\@y,\@m,\@w,\@d,$MWn,$MDn); last RECUR; } } } if ($#recur0==0) { # Y * M-W-D-H-MN-S $n=$y; $n=1 if ($n==0); @m=&ReturnList($m); return () if (! @m); foreach $m (@m) { return () if (! &IsInt($m,1,12)); } @m=sort { $a<=>$b } (@m); if ($m eq "0") { # Y * 0-W-D-H-MN-S (equiv to Y-0 * W-D-H-MN-S) push(@recur0,0); shift(@recur1); } elsif ($w eq "0") { # Y * M-0-DOM-H-MN-S return () if (! $dateb); $d=1 if ($d eq "0"); @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,31)); } @d=sort { $a<=>$b } (@d); # We need to find years that are a multiple of $n from $y(base) ($y0)=( &Date_Split($date0) )[0]; ($y1)=( &Date_Split($date1) )[0]; ($yb)=( &Date_Split($dateb) )[0]; @date=(); for ($yy=$y0; $yy<=$y1; $yy++) { if (($yy-$yb)%$n == 0) { foreach $m (@m) { foreach $d (@d) { $date=&Date_Join($yy,$m,$d,0,0,0); push(@date,$date) if ($d<29 || &Date_Split($date)); } } } } last RECUR; } else { # Y * M-WOM-DOW-H-MN-S # Y * M-WOM-0-H-MN-S return () if (! $dateb); @m=&ReturnList($m); @w=&ReturnList($w); if ($d eq "0") { @d=(); } else { @d=&ReturnList($d); } ($y0)=( &Date_Split($date0) )[0]; ($y1)=( &Date_Split($date1) )[0]; ($yb)=( &Date_Split($dateb) )[0]; @y=(); for ($yy=$y0; $yy<=$y1; $yy++) { if (($yy-$yb)%$n == 0) { push(@y,$yy); } } @date=&Date_Recur_WoM(\@y,\@m,\@w,\@d,$MWn,$MDn); last RECUR; } } if ($#recur0==1) { # Y-M * W-D-H-MN-S if ($w eq "0") { # Y-M * 0-D-H-MN-S (equiv to Y-M-0 * D-H-MN-S) push(@recur0,0); shift(@recur1); } elsif ($m==0) { # Y-0 * WOY-0-H-MN-S # Y-0 * WOY-DOW-H-MN-S return () if (! $dateb); $n=$y; $n=1 if ($n==0); @w=&ReturnList($w); return () if (! @w); foreach $w (@w) { return () if (! &IsInt($w,1,53)); } if ($d eq "0") { @d=($Cnf{"FirstDay"}); } else { @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,7)); } @d=sort { $a<=>$b } (@d); } # We need to find years that are a multiple of $n from $y(base) ($y0)=( &Date_Split($date0) )[0]; ($y1)=( &Date_Split($date1) )[0]; ($yb)=( &Date_Split($dateb) )[0]; @date=(); for ($yy=$y0; $yy<=$y1; $yy++) { if (($yy-$yb)%$n == 0) { foreach $w (@w) { $w="0$w" if (length($w)==1); foreach $tmp (@d) { $date=&ParseDateString("$yy-W$w-$tmp"); push(@date,$date); } } } } last RECUR; } else { # Y-M * WOM-0-H-MN-S # Y-M * WOM-DOW-H-MN-S return () if (! $dateb); @tmp=(@recur0); push(@tmp,0) while ($#tmp<6); $delta=join(":",@tmp); @tmp=&Date_Recur($date0,$date1,$dateb,$delta); @w=&ReturnList($w); @m=(); if ($d eq "0") { @d=(); } else { @d=&ReturnList($d); } @date=&Date_Recur_WoM(\@tmp,\@m,\@w,\@d,$MWn,$MDn); last RECUR; } } if ($#recur0==2) { # Y-M-W * D-H-MN-S if ($d eq "0") { # Y-M-W * 0-H-MN-S return () if (! $dateb); $y=1 if ($y==0 && $m==0 && $w==0); $delta="$y:$m:$w:0:0:0:0"; @date=&Date_Recur($date0,$date1,$dateb,$delta); last RECUR; } elsif ($m==0 && $w==0) { # Y-0-0 * DOY-H-MN-S $y=1 if ($y==0); $n=$y; return () if (! $dateb && $y!=1); @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,366)); } @d=sort { $a<=>$b } (@d); # We need to find years that are a multiple of $n from $y(base) ($y0)=( &Date_Split($date0) )[0]; ($y1)=( &Date_Split($date1) )[0]; ($yb)=( &Date_Split($dateb) )[0]; @date=(); for ($yy=$y0; $yy<=$y1; $yy++) { if (($yy-$yb)%$n == 0) { foreach $d (@d) { ($y,$m,$dd)=&Date_NthDayOfYear($yy,$d); push(@date, &Date_Join($y,$m,$dd,0,0,0)); } } } last RECUR; } elsif ($w>0) { # Y-M-W * DOW-H-MN-S return () if (! $dateb); @tmp=(@recur0); push(@tmp,0) while ($#tmp<6); $delta=join(":",@tmp); @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,1,7)); } # Find out what DofW the basedate is. @tmp2=&Date_Split($dateb); $tmp=&Date_DayOfWeek($tmp2[1],$tmp2[2],$tmp2[0]); @date=(); foreach $d (@d) { $date_b=$dateb; # Move basedate to DOW if ($d != $tmp) { if (($tmp>=$Cnf{"FirstDay"} && $d<$Cnf{"FirstDay"}) || ($tmp>=$Cnf{"FirstDay"} && $d>$tmp) || ($tmp<$d && $d<$Cnf{"FirstDay"})) { $date_b=&Date_GetNext($date_b,$d); } else { $date_b=&Date_GetPrev($date_b,$d); } } push(@date,&Date_Recur($date0,$date1,$date_b,$delta)); } @date=sort(@date); last RECUR; } elsif ($m>0) { # Y-M-0 * DOM-H-MN-S return () if (! $dateb); @tmp=(@recur0); push(@tmp,0) while ($#tmp<6); $delta=join(":",@tmp); @d=&ReturnList($d); return () if (! @d); foreach $d (@d) { return () if (! &IsInt($d,-31,31) || $d==0); } @d=sort { $a<=>$b } (@d); @tmp2=&Date_Recur($date0,$date1,$dateb,$delta); @date=(); foreach $date (@tmp2) { ($y,$m)=( &Date_Split($date) )[0..1]; $tmp2=&Date_DaysInMonth($m,$y); foreach $d (@d) { $d2=$d; $d2=$tmp2+1+$d if ($d<0); push(@date,&Date_Join($y,$m,$d2,0,0,0)) if ($d2<=$tmp2); } } @date=sort (@date); last RECUR; } else { return (); } } if ($#recur0>2) { # Y-M-W-D * H-MN-S # Y-M-W-D-H * MN-S # Y-M-W-D-H-MN * S # Y-M-W-D-H-S return () if (! $dateb); @tmp=(@recur0); push(@tmp,0) while ($#tmp<6); $delta=join(":",@tmp); return () if ($delta !~ /[1-9]/); # return if "0:0:0:0:0:0:0" @date=&Date_Recur($date0,$date1,$dateb,$delta); if (@recur1) { unshift(@recur1,-1) while ($#recur1<2); @time=@recur1; } else { shift(@date); pop(@date); @time=(); } } last RECUR; } @date=&Date_RecurSetTime($date0,$date1,\@date,@time) if (@time); # # We've got a list of dates. Operate on them with the flags. # my($sign,$forw,$today,$df,$db,$work,$i); if (@flags) { FLAG: foreach $f (@flags) { $f = uc($f); if ($f =~ /^(P|N)(D|T)([1-7])$/) { @tmp=($1,$2,$3); $forw =($tmp[0] eq "P" ? 0 : 1); $today=($tmp[1] eq "D" ? 0 : 1); $d=$tmp[2]; @tmp=(); foreach $date (@date) { if ($forw) { push(@tmp, &Date_GetNext($date,$d,$today)); } else { push(@tmp, &Date_GetPrev($date,$d,$today)); } } @date=@tmp; next FLAG; } # We want to go forward exact amounts of time instead of # business mode calculations so that we don't change the time # (which may have been set in the recur). if ($f =~ /^(F|B)(D|W)(\d+)$/) { @tmp=($1,$2,$3); $sign="+"; $sign="-" if ($tmp[0] eq "B"); $work=0; $work=1 if ($tmp[1] eq "W"); $n=$tmp[2]; @tmp=(); foreach $date (@date) { for ($i=1; $i<=$n; $i++) { while (1) { $date=&DateCalc($date,"${sign}0:0:0:1:0:0:0"); last if (! $work || &Date_IsWorkDay($date,0)); } } push(@tmp,$date); } @date=@tmp; next FLAG; } if ($f =~ /^CW(N|P|D)$/ || $f =~ /^(N|P|D)W(D)$/) { $tmp=$1; my $noalt = $2 ? 1 : 0; if ($tmp eq "N" || ($tmp eq "D" && $Cnf{"TomorrowFirst"})) { $forw=1; } else { $forw=0; } @tmp=(); DATE: foreach $date (@date) { $df=$db=$date; if (&Date_IsWorkDay($date)) { push(@tmp,$date); next DATE; } while (1) { if ($forw) { $d=$df=&DateCalc($df,"+0:0:0:1:0:0:0"); } else { $d=$db=&DateCalc($db,"-0:0:0:1:0:0:0"); } if (&Date_IsWorkDay($d)) { push(@tmp,$d); next DATE; } $forw=1-$forw if (! $noalt); } } @date=@tmp; next FLAG; } if ($f eq "EASTER") { @tmp=(); foreach $date (@date) { ($y,$m,$d,$h,$mn,$s)=&Date_Split($date); ($m,$d)=&Date_Easter($y); $date=&Date_Join($y,$m,$d,$h,$mn,$s); next if (&Date_Cmp($date,$date0)<0 || &Date_Cmp($date,$date1)>0); push(@tmp,$date); } @date=@tmp; } } @date = sort(@date); } @date; } sub Date_GetPrev { print "DEBUG: Date_GetPrev\n" if ($Curr{"Debug"} =~ /trace/); my($date,$dow,$today,$hr,$min,$sec)=@_; &Date_Init() if (! $Curr{"InitDone"}); my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts, $adjust,$curr)=(); $hr="00" if (defined $hr && $hr eq "0"); $min="00" if (defined $min && $min eq "0"); $sec="00" if (defined $sec && $sec eq "0"); if (! &Date_Split($date)) { $date=&ParseDateString($date); return "" if (! $date); } $curr=$date; ($y,$m,$d)=( &Date_Split($date) )[0..2]; if ($dow) { $curr_dow=&Date_DayOfWeek($m,$d,$y); %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; if (&IsInt($dow)) { return "" if ($dow<1 || $dow>7); } else { return "" if (! exists $dow{lc($dow)}); $dow=$dow{lc($dow)}; } if ($dow == $curr_dow) { $date=&DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0) if (! $today); $adjust=1 if ($today==2); } else { $dow -= 7 if ($dow>$curr_dow); # make sure previous day is less $num = $curr_dow - $dow; $date=&DateCalc_DateDelta($date,"-0:0:0:$num:0:0:0",\$err,0); } $date=&Date_SetTime($date,$hr,$min,$sec) if (defined $hr); $date=&DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0) if ($adjust && &Date_Cmp($date,$curr)>0); } else { ($h,$mn,$s)=( &Date_Split($date) )[3..5]; ($th,$tm,$ts)=&Date_ParseTime($hr,$min,$sec); if ($hr) { ($hr,$min,$sec)=($th,$tm,$ts); $delta="-0:0:0:1:0:0:0"; } elsif ($min) { ($hr,$min,$sec)=($h,$tm,$ts); $delta="-0:0:0:0:1:0:0"; } elsif ($sec) { ($hr,$min,$sec)=($h,$mn,$ts); $delta="-0:0:0:0:0:1:0"; } else { confess "ERROR: invalid arguments in Date_GetPrev.\n"; } $d=&Date_SetTime($date,$hr,$min,$sec); if ($today) { $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)>0); } else { $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)>=0); } $date=$d; } return $date; } sub Date_GetNext { print "DEBUG: Date_GetNext\n" if ($Curr{"Debug"} =~ /trace/); my($date,$dow,$today,$hr,$min,$sec)=@_; &Date_Init() if (! $Curr{"InitDone"}); my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts, $adjust,$curr)=(); $hr="00" if (defined $hr && $hr eq "0"); $min="00" if (defined $min && $min eq "0"); $sec="00" if (defined $sec && $sec eq "0"); if (! &Date_Split($date)) { $date=&ParseDateString($date); return "" if (! $date); } $curr=$date; ($y,$m,$d)=( &Date_Split($date) )[0..2]; if ($dow) { $curr_dow=&Date_DayOfWeek($m,$d,$y); %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; if (&IsInt($dow)) { return "" if ($dow<1 || $dow>7); } else { return "" if (! exists $dow{lc($dow)}); $dow=$dow{lc($dow)}; } if ($dow == $curr_dow) { $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0) if (! $today); $adjust=1 if ($today==2); } else { $curr_dow -= 7 if ($curr_dow>$dow); # make sure next date is greater $num = $dow - $curr_dow; $date=&DateCalc_DateDelta($date,"+0:0:0:$num:0:0:0",\$err,0); } $date=&Date_SetTime($date,$hr,$min,$sec) if (defined $hr); $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0) if ($adjust && &Date_Cmp($date,$curr)<0); } else { ($h,$mn,$s)=( &Date_Split($date) )[3..5]; ($th,$tm,$ts)=&Date_ParseTime($hr,$min,$sec); if ($hr) { ($hr,$min,$sec)=($th,$tm,$ts); $delta="+0:0:0:1:0:0:0"; } elsif ($min) { ($hr,$min,$sec)=($h,$tm,$ts); $delta="+0:0:0:0:1:0:0"; } elsif ($sec) { ($hr,$min,$sec)=($h,$mn,$ts); $delta="+0:0:0:0:0:1:0"; } else { confess "ERROR: invalid arguments in Date_GetNext.\n"; } $d=&Date_SetTime($date,$hr,$min,$sec); if ($today) { $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)<0); } else { $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)<1); } $date=$d; } return $date; } sub Date_IsHoliday { print "DEBUG: Date_IsHoliday\n" if ($Curr{"Debug"} =~ /trace/); my($date)=@_; &Date_Init() if (! $Curr{"InitDone"}); $date=&ParseDateString($date); return undef if (! $date); $date=&Date_SetTime($date,0,0,0); my($y)=(&Date_Split($date))[0]; &Date_UpdateHolidays($y) if (! exists $Holiday{"dates"}{$y}); return undef if (! exists $Holiday{"dates"}{$y}{$date}); my($name)=$Holiday{"dates"}{$y}{$date}; return "" if (! $name); $name; } sub Events_List { print "DEBUG: Events_List\n" if ($Curr{"Debug"} =~ /trace/); my(@args)=@_; &Date_Init() if (! $Curr{"InitDone"}); &Events_ParseRaw(); my($tmp,$date0,$date1,$flag); $date0=&ParseDateString($args[0]); warn "Invalid date $args[0]", return undef if (! $date0); if ($#args == 0) { return &Events_Calc($date0); } if ($args[1]) { $date1=&ParseDateString($args[1]); warn "Invalid date $args[1]\n", return undef if (! $date1); if (&Date_Cmp($date0,$date1)>0) { $tmp=$date1; $date1=$date0; $date0=$tmp; } } else { $date0=&Date_SetTime($date0,"00:00:00"); $date1=&DateCalc_DateDelta($date0,"+0:0:0:1:0:0:0"); } $tmp=&Events_Calc($date0,$date1); $flag=$args[2]; return $tmp if (! $flag); my(@tmp,%ret,$delta)=(); @tmp=@$tmp; push(@tmp,$date1); if ($flag==1) { while ($#tmp>0) { ($date0,$tmp)=splice(@tmp,0,2); $date1=$tmp[0]; $delta=&DateCalc_DateDate($date0,$date1); foreach $flag (@$tmp) { if (exists $ret{$flag}) { $ret{$flag}=&DateCalc_DeltaDelta($ret{$flag},$delta); } else { $ret{$flag}=$delta; } } } return \%ret; } elsif ($flag==2) { while ($#tmp>0) { ($date0,$tmp)=splice(@tmp,0,2); $date1=$tmp[0]; $delta=&DateCalc_DateDate($date0,$date1); $flag=join("+",sort @$tmp); next if (! $flag); if (exists $ret{$flag}) { $ret{$flag}=&DateCalc_DeltaDelta($ret{$flag},$delta); } else { $ret{$flag}=$delta; } } return \%ret; } warn "Invalid flag $flag\n"; return undef; } ### # NOTE: The following routines may be called in the routines below with very # little time penalty. ### sub Date_SetTime { print "DEBUG: Date_SetTime\n" if ($Curr{"Debug"} =~ /trace/); my($date,$h,$mn,$s)=@_; &Date_Init() if (! $Curr{"InitDone"}); my($y,$m,$d)=(); if (! &Date_Split($date)) { $date=&ParseDateString($date); return "" if (! $date); } ($y,$m,$d)=( &Date_Split($date) )[0..2]; ($h,$mn,$s)=&Date_ParseTime($h,$mn,$s); my($ampm,$wk); return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); &Date_Join($y,$m,$d,$h,$mn,$s); } sub Date_SetDateField { print "DEBUG: Date_SetDateField\n" if ($Curr{"Debug"} =~ /trace/); my($date,$field,$val,$nocheck)=@_; my($y,$m,$d,$h,$mn,$s)=(); $nocheck=0 if (! defined $nocheck); ($y,$m,$d,$h,$mn,$s)=&Date_Split($date); if (! $y) { $date=&ParseDateString($date); return "" if (! $date); ($y,$m,$d,$h,$mn,$s)=&Date_Split($date); } if (lc($field) eq "y") { $y=$val; } elsif (lc($field) eq "m") { $m=$val; } elsif (lc($field) eq "d") { $d=$val; } elsif (lc($field) eq "h") { $h=$val; } elsif (lc($field) eq "mn") { $mn=$val; } elsif (lc($field) eq "s") { $s=$val; } else { confess "ERROR: Date_SetDateField: invalid field: $field\n"; } $date=&Date_Join($y,$m,$d,$h,$mn,$s); return $date if ($nocheck || &Date_Split($date)); return ""; } ######################################################################## # OTHER SUBROUTINES ######################################################################## # NOTE: These routines should not call any of the routines above as # there will be a severe time penalty (and the possibility of # infinite recursion). The last couple routines above are # exceptions. # NOTE: Date_Init is a special case. It should be called (conditionally) # in every routine that uses any variable from the Date::Manip # namespace. ######################################################################## sub Date_DaysInMonth { print "DEBUG: Date_DaysInMonth\n" if ($Curr{"Debug"} =~ /trace/); my($m,$y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); $d_in_m[2]=29 if (&Date_LeapYear($y)); return $d_in_m[$m]; } sub Date_DayOfWeek { print "DEBUG: Date_DayOfWeek\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); my($dayofweek,$dec31)=(); $dec31=5; # Dec 31, 1BC was Friday $dayofweek=(&Date_DaysSince1BC($m,$d,$y)+$dec31) % 7; $dayofweek=7 if ($dayofweek==0); return $dayofweek; } # Can't be in "use integer" because the numbers are too big. no integer; sub Date_SecsSince1970 { print "DEBUG: Date_SecsSince1970\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y,$h,$mn,$s)=@_; $y=&Date_FixYear($y) if (length($y)!=4); my($sec_now,$sec_70)=(); $sec_now=(&Date_DaysSince1BC($m,$d,$y)-1)*24*3600 + $h*3600 + $mn*60 + $s; # $sec_70 =(&Date_DaysSince1BC(1,1,1970)-1)*24*3600; $sec_70 =62167219200; return ($sec_now-$sec_70); } sub Date_SecsSince1970GMT { print "DEBUG: Date_SecsSince1970GMT\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y,$h,$mn,$s)=@_; &Date_Init() if (! $Curr{"InitDone"}); $y=&Date_FixYear($y) if (length($y)!=4); my($sec)=&Date_SecsSince1970($m,$d,$y,$h,$mn,$s); return $sec if ($Cnf{"ConvTZ"} eq "IGNORE"); my($tz)=$Cnf{"ConvTZ"}; $tz=$Cnf{"TZ"} if (! $tz); $tz=$Zone{"n2o"}{lc($tz)} if ($tz !~ /^[+-]\d{4}$/); my($tzs)=1; $tzs=-1 if ($tz<0); $tz=~/.(..)(..)/; my($tzh,$tzm)=($1,$2); $sec - $tzs*($tzh*3600+$tzm*60); } use integer; sub Date_DaysSince1BC { print "DEBUG: Date_DaysSince1BC\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); my($Ny,$N4,$N100,$N400,$dayofyear,$days)=(); my($cc,$yy)=(); $y=~ /(\d{2})(\d{2})/; ($cc,$yy)=($1,$2); # Number of full years since Dec 31, 1BC (counting the year 0000). $Ny=$y; # Number of full 4th years (incl. 0000) since Dec 31, 1BC $N4=($Ny-1)/4 + 1; $N4=0 if ($y==0); # Number of full 100th years (incl. 0000) $N100=$cc + 1; $N100-- if ($yy==0); $N100=0 if ($y==0); # Number of full 400th years (incl. 0000) $N400=($N100-1)/4 + 1; $N400=0 if ($y==0); $dayofyear=&Date_DayOfYear($m,$d,$y); $days= $Ny*365 + $N4 - $N100 + $N400 + $dayofyear; return $days; } sub Date_DayOfYear { print "DEBUG: Date_DayOfYear\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); # DinM = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) my(@days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365); my($ly)=0; $ly=1 if ($m>2 && &Date_LeapYear($y)); return ($days[$m-1]+$d+$ly); } sub Date_DaysInYear { print "DEBUG: Date_DaysInYear\n" if ($Curr{"Debug"} =~ /trace/); my($y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); return 366 if (&Date_LeapYear($y)); return 365; } sub Date_WeekOfYear { print "DEBUG: Date_WeekOfYear\n" if ($Curr{"Debug"} =~ /trace/); my($m,$d,$y,$f)=@_; &Date_Init() if (! $Curr{"InitDone"}); $y=&Date_FixYear($y) if (length($y)!=4); my($day,$dow,$doy)=(); $doy=&Date_DayOfYear($m,$d,$y); # The current DayOfYear and DayOfWeek if ($Cnf{"Jan1Week1"}) { $day=1; } else { $day=4; } $dow=&Date_DayOfWeek(1,$day,$y); # Move back to the first day of week 1. $f-=7 if ($f>$dow); $day-= ($dow-$f); return 0 if ($day>$doy); # Day is in last week of previous year return (($doy-$day)/7 + 1); } sub Date_LeapYear { print "DEBUG: Date_LeapYear\n" if ($Curr{"Debug"} =~ /trace/); my($y)=@_; $y=&Date_FixYear($y) if (length($y)!=4); return 0 unless $y % 4 == 0; return 1 unless $y % 100 == 0; return 0 unless $y % 400 == 0; return 1; } sub Date_DaySuffix { print "DEBUG: Date_DaySuffix\n" if ($Curr{"Debug"} =~ /trace/); my($d)=@_; &Date_Init() if (! $Curr{"InitDone"}); return $Lang{$Cnf{"Language"}}{"DoML"}[$d-1]; } sub Date_ConvTZ { print "DEBUG: Date_ConvTZ\n" if ($Curr{"Debug"} =~ /trace/); my($date,$from,$to)=@_; &Date_Init() if (! $Curr{"InitDone"}); my($gmt)=(); if (! $from) { if (! $to) { # TZ -> ConvTZ return $date if ($Cnf{"ConvTZ"} eq "IGNORE" or ! $Cnf{"ConvTZ"}); $from=$Cnf{"TZ"}; $to=$Cnf{"ConvTZ"}; } else { # ConvTZ,TZ -> $to $from=$Cnf{"ConvTZ"}; $from=$Cnf{"TZ"} if (! $from); } } else { if (! $to) { # $from -> ConvTZ,TZ return $date if ($Cnf{"ConvTZ"} eq "IGNORE"); $to=$Cnf{"ConvTZ"}; $to=$Cnf{"TZ"} if (! $to); } else { # $from -> $to } } $to=$Zone{"n2o"}{lc($to)} if (exists $Zone{"n2o"}{lc($to)}); $from=$Zone{"n2o"}{lc($from)} if (exists $Zone{"n2o"}{lc($from)}); $gmt=$Zone{"n2o"}{"gmt"}; return $date if ($from !~ /^[+-]\d{4}$/ or $to !~ /^[+-]\d{4}$/); return $date if ($from eq $to); my($s1,$h1,$m1,$s2,$h2,$m2,$d,$h,$m,$sign,$delta,$err,$yr,$mon,$sec)=(); # We're going to try to do the calculation without calling DateCalc. ($yr,$mon,$d,$h,$m,$sec)=&Date_Split($date); # Convert $date from $from to GMT $from=~/([+-])(\d{2})(\d{2})/; ($s1,$h1,$m1)=($1,$2,$3); $s1= ($s1 eq "-" ? "+" : "-"); # switch sign $sign=$s1 . "1"; # + or - 1 # and from GMT to $to $to=~/([+-])(\d{2})(\d{2})/; ($s2,$h2,$m2)=($1,$2,$3); if ($s1 eq $s2) { # Both the same sign $m+= $sign*($m1+$m2); $h+= $sign*($h1+$h2); } else { $sign=($s2 eq "-" ? +1 : -1) if ($h1<$h2 || ($h1==$h2 && $m1<$m2)); $m+= $sign*($m1-$m2); $h+= $sign*($h1-$h2); } if ($m>59) { $h+= $m/60; $m-= ($m/60)*60; } elsif ($m<0) { $h+= ($m/60 - 1); $m-= ($m/60 - 1)*60; } if ($h>23) { $delta=$h/24; $h -= $delta*24; if (($d + $delta) > 28) { $date=&Date_Join($yr,$mon,$d,$h,$m,$sec); return &DateCalc_DateDelta($date,"+0:0:0:$delta:0:0:0",\$err,0); } $d+= $delta; } elsif ($h<0) { $delta=-$h/24 + 1; $h += $delta*24; if (($d - $delta) < 1) { $date=&Date_Join($yr,$mon,$d,$h,$m,$sec); return &DateCalc_DateDelta($date,"-0:0:0:$delta:0:0:0",\$err,0); } $d-= $delta; } return &Date_Join($yr,$mon,$d,$h,$m,$sec); } sub Date_TimeZone { print "DEBUG: Date_TimeZone\n" if ($Curr{"Debug"} =~ /trace/); my($null,$tz,@tz,$std,$dst,$time,$isdst,$tmp,$in)=(); &Date_Init() if (! $Curr{"InitDone"}); # Get timezones from all of the relevant places push(@tz,$Cnf{"TZ"}) if (defined $Cnf{"TZ"}); # TZ config var push(@tz,$ENV{"TZ"}) if (exists $ENV{"TZ"}); # TZ environ var # The `date` command... if we're doing taint checking, we need to # always call it with a full path... otherwise, use the user's path. # # Microsoft operating systems don't have a date command built in. Try # to trap all the various ways of knowing we are on one of these systems. # # We'll try `date +%Z` first, and if that fails, we'll take just the # `date` program and assume the output is of the format: # Thu Aug 31 14:57:46 EDT 2000 unless (($^X =~ /perl\.exe$/i) or $OS eq "Windows") { if ($Date::Manip::NoTaint) { $tz=`date +%Z 2> /dev/null`; chomp($tz); if (! $tz) { $tz=`date 2> /dev/null`; chomp($tz); $tz=(split(/\s+/,$tz))[4]; } push(@tz,$tz); } else { foreach my $dir (@Date::Manip::DatePath) { next if (! -x "$dir/date"); $tz=`$dir/date +%Z 2> /dev/null`; chomp($tz); if (! $tz) { $tz=`$dir/date 2> /dev/null`; chomp($tz); $tz=(split(/\s+/,$tz))[4]; } push(@tz,$tz); } } } push(@tz,$main::TZ) if (defined $main::TZ); # $main::TZ if (-s "/etc/TIMEZONE") { # /etc/TIMEZONE $in=new IO::File; $in->open("/etc/TIMEZONE","r"); while (! eof($in)) { $tmp=<$in>; if ($tmp =~ /^TZ\s*=\s*(.*?)\s*$/) { push(@tz,$1); last; } } $in->close; } if (-s "/etc/timezone") { # /etc/timezone $in=new IO::File; $in->open("/etc/timezone","r"); while (! eof($in)) { $tmp=<$in>; next if ($tmp =~ /^\s*\043/); chomp($tmp); if ($tz =~ /^\s*(.*?)\s*$/) { push(@tz,$1); last; } } $in->close; } # Now parse each one to find the first valid one. foreach $tz (@tz) { return uc($tz) if (defined $Zone{"n2o"}{lc($tz)} or $tz=~/^[+-]\d{4}/); # Handle US/Eastern format if ($tz =~ /^$Zone{"tzones"}$/i) { $tmp=lc $1; $tz=$Zone{"tz2z"}{$tmp}; } # Handle STD#DST# format (and STD-#DST-# formats) if ($tz =~ /^([a-z]+)-?\d([a-z]+)-?\d?$/i) { ($std,$dst)=($1,$2); next if (! defined $Zone{"n2o"}{lc($std)} or ! defined $Zone{"n2o"}{lc($dst)}); $time = time(); ($null,$null,$null,$null,$null,$null,$null,$null,$isdst) = localtime($time); return uc($dst) if ($isdst); return uc($std); } } confess "ERROR: Date::Manip unable to determine TimeZone.\n"; } # Returns 1 if $date is a work day. If $time is non-zero, the time is # also checked to see if it falls within work hours. Returns "" if # an invalid date is passed in. sub Date_IsWorkDay { print "DEBUG: Date_IsWorkDay\n" if ($Curr{"Debug"} =~ /trace/); my($date,$time)=@_; &Date_Init() if (! $Curr{"InitDone"}); $date=&ParseDateString($date); return "" if (! $date); my($d)=$date; $d=&Date_SetTime($date,$Cnf{"WorkDayBeg"}) if (! $time); my($y,$mon,$day,$tmp,$h,$m,$dow)=(); ($y,$mon,$day,$h,$m,$tmp)=&Date_Split($d); $dow=&Date_DayOfWeek($mon,$day,$y); return 0 if ($dow<$Cnf{"WorkWeekBeg"} or $dow>$Cnf{"WorkWeekEnd"} or "$h:$m" lt $Cnf{"WorkDayBeg"} or "$h:$m" gt $Cnf{"WorkDayEnd"}); if (! exists $Holiday{"dates"}{$y}) { # There will be recursion problems if we ever end up here twice. $Holiday{"dates"}{$y}={}; &Date_UpdateHolidays($y) } $d=&Date_SetTime($date,"00:00:00"); return 0 if (exists $Holiday{"dates"}{$y}{$d}); 1; } # Finds the day $off work days from now. If $time is passed in, we must # also take into account the time of day. # # If $time is not passed in, day 0 is today (if today is a workday) or the # next work day if it isn't. In any case, the time of day is unaffected. # # If $time is passed in, day 0 is now (if now is part of a workday) or the # start of the very next work day. sub Date_NextWorkDay { print "DEBUG: Date_NextWorkDay\n" if ($Curr{"Debug"} =~ /trace/); my($date,$off,$time)=@_; &Date_Init() if (! $Curr{"InitDone"}); $date=&ParseDateString($date); my($err)=(); if (! &Date_IsWorkDay($date,$time)) { if ($time) { while (1) { $date=&Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"}); last if (&Date_IsWorkDay($date,$time)); } } else { while (1) { $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0); last if (&Date_IsWorkDay($date,$time)); } } } while ($off>0) { while (1) { $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0); last if (&Date_IsWorkDay($date,$time)); } $off--; } return $date; } # Finds the day $off work days before now. If $time is passed in, we must # also take into account the time of day. # # If $time is not passed in, day 0 is today (if today is a workday) or the # previous work day if it isn't. In any case, the time of day is unaffected. # # If $time is passed in, day 0 is now (if now is part of a workday) or the # end of the previous work period. Note that since the end of a work day # will automatically be turned into the start of the next one, this time # may actually be treated as AFTER the current time. sub Date_PrevWorkDay { print "DEBUG: Date_PrevWorkDay\n" if ($Curr{"Debug"} =~ /trace/); my($date,$off,$time)=@_; &Date_Init() if (! $Curr{"InitDone"}); $date=&ParseDateString($date); my($err)=(); if (! &Date_IsWorkDay($date,$time)) { if ($time) { while (1) { $date=&Date_GetPrev($date,undef,0,$Cnf{"WorkDayEnd"}); last if (&Date_IsWorkDay($date,$time)); } while (1) { $date=&Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"}); last if (&Date_IsWorkDay($date,$time)); } } else { while (1) { $date=&DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0); last if (&Date_IsWorkDay($date,$time)); } } } while ($off>0) { while (1) { $date=&DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0); last if (&Date_IsWorkDay($date,$time)); } $off--; } return $date; } # This finds the nearest workday to $date. If $date is a workday, it # is returned. sub Date_NearestWorkDay { print "DEBUG: Date_NearestWorkDay\n" if ($Curr{"Debug"} =~ /trace/); my($date,$tomorrow)=@_; &Date_Init() if (! $Curr{"InitDone"}); $date=&ParseDateString($date); my($a,$b,$dela,$delb,$err)=(); $tomorrow=$Cnf{"TomorrowFirst"} if (! defined $tomorrow); return $date if (&Date_IsWorkDay($date)); # Find the nearest one. if ($tomorrow) { $dela="+0:0:0:1:0:0:0"; $delb="-0:0:0:1:0:0:0"; } else { $dela="-0:0:0:1:0:0:0"; $delb="+0:0:0:1:0:0:0"; } $a=$b=$date; while (1) { $a=&DateCalc_DateDelta($a,$dela,\$err); return $a if (&Date_IsWorkDay($a)); $b=&DateCalc_DateDelta($b,$delb,\$err); return $b if (&Date_IsWorkDay($b)); } } # &Date_NthDayOfYear($y,$n); # Returns a list of (YYYY,MM,DD,HH,MM,SS) for the Nth day of the year. sub Date_NthDayOfYear { no integer; print "DEBUG: Date_NthDayOfYear\n" if ($Curr{"Debug"} =~ /trace/); my($y,$n)=@_; $y=$Curr{"Y"} if (! $y); $n=1 if (! defined $n or $n eq ""); $n+=0; # to turn 023 into 23 $y=&Date_FixYear($y) if (length($y)<4); my $leap=&Date_LeapYear($y); return () if ($n<1); return () if ($n >= ($leap ? 367 : 366)); my(@d_in_m)=(31,28,31,30,31,30,31,31,30,31,30,31); $d_in_m[1]=29 if ($leap); # Calculate the hours, minutes, and seconds into the day. my $remain=($n - int($n))*24; my $h=int($remain); $remain=($remain - $h)*60; my $mn=int($remain); $remain=($remain - $mn)*60; my $s=$remain; # Calculate the month and the day. my($m,$d)=(0,0); $n=int($n); while ($n>0) { $m++; if ($n<=$d_in_m[0]) { $d=int($n); $n=0; } else { $n-= $d_in_m[0]; shift(@d_in_m); } } ($y,$m,$d,$h,$mn,$s); } ######################################################################## # NOT FOR EXPORT ######################################################################## # This is used in Date_Init to fill in a hash based on international # data. It takes a list of keys and values and returns both a hash # with these values and a regular expression of keys. # # IN: # $data = [ key1 val1 key2 val2 ... ] # $opts = lc : lowercase the keys in the regexp # sort : sort (by length) the keys in the regexp # back : create a regexp with a back reference # escape : escape all strings in the regexp # # OUT: # $regexp = '(?:key1|key2|...)' # $hash = { key1=>val1 key2=>val2 ... } sub Date_InitHash { print "DEBUG: Date_InitHash\n" if ($Curr{"Debug"} =~ /trace/); my($data,$regexp,$opts,$hash)=@_; my(@data)=@$data; my($key,$val,@list)=(); # Parse the options my($lc,$sort,$back,$escape)=(0,0,0,0); $lc=1 if ($opts =~ /lc/i); $sort=1 if ($opts =~ /sort/i); $back=1 if ($opts =~ /back/i); $escape=1 if ($opts =~ /escape/i); # Create the hash while (@data) { ($key,$val,@data)=@data; $key=lc($key) if ($lc); $$hash{$key}=$val; } # Create the regular expression if ($regexp) { @list=keys(%$hash); @list=sort sortByLength(@list) if ($sort); if ($escape) { foreach $val (@list) { $val="\Q$val\E"; } } if ($back) { $$regexp="(" . join("|",@list) . ")"; } else { $$regexp="(?:" . join("|",@list) . ")"; } } } # This is used in Date_Init to fill in regular expressions, lists, and # hashes based on international data. It takes a list of lists which have # to be stored as regular expressions (to find any element in the list), # lists, and hashes (indicating the location in the lists). # # IN: # $data = [ [ [ valA1 valA2 ... ][ valA1' valA2' ... ] ... ] # [ [ valB1 valB2 ... ][ valB1' valB2' ... ] ... ] # ... # [ [ valZ1 valZ2 ... ] [valZ1' valZ1' ... ] ... ] ] # $lists = [ \@listA \@listB ... \@listZ ] # $opts = lc : lowercase the values in the regexp # sort : sort (by length) the values in the regexp # back : create a regexp with a back reference # escape : escape all strings in the regexp # $hash = [ \%hash, TYPE ] # TYPE 0 : $hash{ valBn=>n-1 } # TYPE 1 : $hash{ valBn=>n } # # OUT: # $regexp = '(?:valA1|valA2|...|valB1|...)' # $lists = [ [ valA1 valA2 ... ] # only the 1st list (or # [ valB1 valB2 ... ] ... ] # 2nd for int. characters) # $hash sub Date_InitLists { print "DEBUG: Date_InitLists\n" if ($Curr{"Debug"} =~ /trace/); my($data,$regexp,$opts,$lists,$hash)=@_; my(@data)=@$data; my(@lists)=@$lists; my($i,@ele,$ele,@list,$j,$tmp)=(); # Parse the options my($lc,$sort,$back,$escape)=(0,0,0,0); $lc=1 if ($opts =~ /lc/i); $sort=1 if ($opts =~ /sort/i); $back=1 if ($opts =~ /back/i); $escape=1 if ($opts =~ /escape/i); # Set each of the lists if (@lists) { confess "ERROR: Date_InitLists: lists must be 1 per data\n" if ($#lists != $#data); for ($i=0; $i<=$#data; $i++) { @ele=@{ $data[$i] }; if ($Cnf{"IntCharSet"} && $#ele>0) { @{ $lists[$i] } = @{ $ele[1] }; } else { @{ $lists[$i] } = @{ $ele[0] }; } } } # Create the hash my($hashtype,$hashsave,%hash)=(); if (@$hash) { ($hash,$hashtype)=@$hash; $hashsave=1; } else { $hashtype=0; $hashsave=0; } for ($i=0; $i<=$#data; $i++) { @ele=@{ $data[$i] }; foreach $ele (@ele) { @list = @{ $ele }; for ($j=0; $j<=$#list; $j++) { $tmp=$list[$j]; next if (! $tmp); $tmp=lc($tmp) if ($lc); $hash{$tmp}= $j+$hashtype; } } } %$hash = %hash if ($hashsave); # Create the regular expression if ($regexp) { @list=keys(%hash); @list=sort sortByLength(@list) if ($sort); if ($escape) { foreach $ele (@list) { $ele="\Q$ele\E"; } } if ($back) { $$regexp="(" . join("|",@list) . ")"; } else { $$regexp="(?:" . join("|",@list) . ")"; } } } # This is used in Date_Init to fill in regular expressions and lists based # on international data. This takes a list of strings and returns a regular # expression (to find any one of them). # # IN: # $data = [ string1 string2 ... ] # $opts = lc : lowercase the values in the regexp # sort : sort (by length) the values in the regexp # back : create a regexp with a back reference # escape : escape all strings in the regexp # # OUT: # $regexp = '(string1|string2|...)' sub Date_InitStrings { print "DEBUG: Date_InitStrings\n" if ($Curr{"Debug"} =~ /trace/); my($data,$regexp,$opts)=@_; my(@list)=@{ $data }; # Parse the options my($lc,$sort,$back,$escape)=(0,0,0,0); $lc=1 if ($opts =~ /lc/i); $sort=1 if ($opts =~ /sort/i); $back=1 if ($opts =~ /back/i); $escape=1 if ($opts =~ /escape/i); # Create the regular expression my($ele)=(); @list=sort sortByLength(@list) if ($sort); if ($escape) { foreach $ele (@list) { $ele="\Q$ele\E"; } } if ($back) { $$regexp="(" . join("|",@list) . ")"; } else { $$regexp="(?:" . join("|",@list) . ")"; } $$regexp=lc($$regexp) if ($lc); } # items is passed in (either as a space separated string, or a reference to # a list) and a regular expression which matches any one of the items is # prepared. The regular expression will be of one of the forms: # "(a|b)" @list not empty, back option included # "(?:a|b)" @list not empty # "()" @list empty, back option included # "" @list empty # $options is a string which contains any of the following strings: # back : the regular expression has a backreference # opt : the regular expression is optional and a "?" is appended in # the first two forms # optws : the regular expression is optional and may be replaced by # whitespace # optWs : the regular expression is optional, but if not present, must # be replaced by whitespace # sort : the items in the list are sorted by length (longest first) # lc : the string is lowercased # under : any underscores are converted to spaces # pre : it may be preceded by whitespace # Pre : it must be preceded by whitespace # PRE : it must be preceded by whitespace or the start # post : it may be followed by whitespace # Post : it must be followed by whitespace # POST : it must be followed by whitespace or the end # Spaces due to pre/post options will not be included in the back reference. # # If $array is included, then the elements will also be returned as a list. # $array is a string which may contain any of the following: # keys : treat the list as a hash and only the keys go into the regexp # key0 : treat the list as the values of a hash with keys 0 .. N-1 # key1 : treat the list as the values of a hash with keys 1 .. N # val0 : treat the list as the keys of a hash with values 0 .. N-1 # val1 : treat the list as the keys of a hash with values 1 .. N # &Date_InitLists([$lang{"month_name"},$lang{"month_abb"}], # [\$Month,"lc,sort,back"], # [\@Month,\@Mon], # [\%Month,1]); # This is used in Date_Init to prepare regular expressions. A list of # items is passed in (either as a space separated string, or a reference to # a list) and a regular expression which matches any one of the items is # prepared. The regular expression will be of one of the forms: # "(a|b)" @list not empty, back option included # "(?:a|b)" @list not empty # "()" @list empty, back option included # "" @list empty # $options is a string which contains any of the following strings: # back : the regular expression has a backreference # opt : the regular expression is optional and a "?" is appended in # the first two forms # optws : the regular expression is optional and may be replaced by # whitespace # optWs : the regular expression is optional, but if not present, must # be replaced by whitespace # sort : the items in the list are sorted by length (longest first) # lc : the string is lowercased # under : any underscores are converted to spaces # pre : it may be preceded by whitespace # Pre : it must be preceded by whitespace # PRE : it must be preceded by whitespace or the start # post : it may be followed by whitespace # Post : it must be followed by whitespace # POST : it must be followed by whitespace or the end # Spaces due to pre/post options will not be included in the back reference. # # If $array is included, then the elements will also be returned as a list. # $array is a string which may contain any of the following: # keys : treat the list as a hash and only the keys go into the regexp # key0 : treat the list as the values of a hash with keys 0 .. N-1 # key1 : treat the list as the values of a hash with keys 1 .. N # val0 : treat the list as the keys of a hash with values 0 .. N-1 # val1 : treat the list as the keys of a hash with values 1 .. N sub Date_Regexp { print "DEBUG: Date_Regexp\n" if ($Curr{"Debug"} =~ /trace/); my($list,$options,$array)=@_; my(@list,$ret,%hash,$i)=(); local($_)=(); $options="" if (! defined $options); $array="" if (! defined $array); my($sort,$lc,$under)=(0,0,0); $sort =1 if ($options =~ /sort/i); $lc =1 if ($options =~ /lc/i); $under=1 if ($options =~ /under/i); my($back,$opt,$pre,$post,$ws)=("?:","","","",""); $back ="" if ($options =~ /back/i); $opt ="?" if ($options =~ /opt/i); $pre ='\s*' if ($options =~ /pre/); $pre ='\s+' if ($options =~ /Pre/); $pre ='(?:\s+|^)' if ($options =~ /PRE/); $post ='\s*' if ($options =~ /post/); $post ='\s+' if ($options =~ /Post/); $post ='(?:$|\s+)' if ($options =~ /POST/); $ws ='\s*' if ($options =~ /optws/); $ws ='\s+' if ($options =~ /optws/); my($hash,$keys,$key0,$key1,$val0,$val1)=(0,0,0,0,0,0); $keys =1 if ($array =~ /keys/i); $key0 =1 if ($array =~ /key0/i); $key1 =1 if ($array =~ /key1/i); $val0 =1 if ($array =~ /val0/i); $val1 =1 if ($array =~ /val1/i); $hash =1 if ($keys or $key0 or $key1 or $val0 or $val1); my($ref)=ref $list; if (! $ref) { $list =~ s/\s*$//; $list =~ s/^\s*//; $list =~ s/\s+/&&&/g; } elsif ($ref eq "ARRAY") { $list = join("&&&",@$list); } else { confess "ERROR: Date_Regexp.\n"; } if (! $list) { if ($back eq "") { return "()"; } else { return ""; } } $list=lc($list) if ($lc); $list=~ s/_/ /g if ($under); @list=split(/&&&/,$list); if ($keys) { %hash=@list; @list=keys %hash; } elsif ($key0 or $key1 or $val0 or $val1) { $i=0; $i=1 if ($key1 or $val1); if ($key0 or $key1) { %hash= map { $_,$i++ } @list; } else { %hash= map { $i++,$_ } @list; } } @list=sort sortByLength(@list) if ($sort); $ret="($back" . join("|",@list) . ")"; $ret="(?:$pre$ret$post)" if ($pre or $post); $ret.=$opt; $ret="(?:$ret|$ws)" if ($ws); if ($array and $hash) { return ($ret,%hash); } elsif ($array) { return ($ret,@list); } else { return $ret; } } # This will produce a delta with the correct number of signs. At most two # signs will be in it normally (one before the year, and one in front of # the day), but if appropriate, signs will be in front of all elements. # Also, as many of the signs will be equivalent as possible. sub Delta_Normalize { print "DEBUG: Delta_Normalize\n" if ($Curr{"Debug"} =~ /trace/); my($delta,$mode)=@_; return "" if (! $delta); return "+0:+0:+0:+0:+0:+0:+0" if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/ and $Cnf{"DeltaSigns"}); return "+0:0:0:0:0:0:0" if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/); my($tmp,$sign1,$sign2,$len)=(); # Calculate the length of the day in minutes $len=24*60; $len=$Curr{"WDlen"} if ($mode==2 || $mode==3); # We have to get the sign of every component explicitely so that a "-0" # or "+0" doesn't get lost by treating it numerically (i.e. "-0:0:2" must # be a negative delta). my($y,$mon,$w,$d,$h,$m,$s)=&Delta_Split($delta); # We need to make sure that the signs of all parts of a delta are the # same. The easiest way to do this is to convert all of the large # components to the smallest ones, then convert the smaller components # back to the larger ones. # Do the year/month part $mon += $y*12; # convert y to m $sign1="+"; if ($mon<0) { $mon *= -1; $sign1="-"; } $y = $mon/12; # convert m to y $mon -= $y*12; $y=0 if ($y eq "-0"); # get around silly -0 problem $mon=0 if ($mon eq "-0"); # Do the wk/day/hour/min/sec part { # Unfortunately, $s is overflowing for dates more than ~70 years # apart. no integer; if ($mode==3 || $mode==2) { $s += $d*$len*60 + $h*3600 + $m*60; # convert d/h/m to s } else { $s += ($d+7*$w)*$len*60 + $h*3600 + $m*60; # convert w/d/h/m to s } $sign2="+"; if ($s<0) { $s*=-1; $sign2="-"; } $m = int($s/60); # convert s to m $s -= $m*60; $d = int($m/$len); # convert m to d $m -= $d*$len; # The rest should be fine. } $h = $m/60; # convert m to h $m -= $h*60; if ($mode == 3 || $mode == 2) { $w = $w*1; # get around +0 problem } else { $w = $d/7; # convert d to w $d -= $w*7; } $w=0 if ($w eq "-0"); # get around silly -0 problem $d=0 if ($d eq "-0"); $h=0 if ($h eq "-0"); $m=0 if ($m eq "-0"); $s=0 if ($s eq "-0"); # Only include two signs if necessary $sign1=$sign2 if ($y==0 and $mon==0); $sign2=$sign1 if ($w==0 and $d==0 and $h==0 and $m==0 and $s==0); $sign2="" if ($sign1 eq $sign2 and ! $Cnf{"DeltaSigns"}); if ($Cnf{"DeltaSigns"}) { return "$sign1$y:$sign1$mon:$sign2$w:$sign2$d:$sign2$h:$sign2$m:$sign2$s"; } else { return "$sign1$y:$mon:$sign2$w:$d:$h:$m:$s"; } } # This checks a delta to make sure it is valid. If it is, it splits # it and returns the elements with a sign on each. The 2nd argument # specifies the default sign. Blank elements are set to 0. If the # third element is non-nil, exactly 7 elements must be included. sub Delta_Split { print "DEBUG: Delta_Split\n" if ($Curr{"Debug"} =~ /trace/); my($delta,$sign,$exact)=@_; my(@delta)=split(/:/,$delta); return () if ($exact and $#delta != 6); my($i)=(); $sign="+" if (! defined $sign); for ($i=0; $i<=$#delta; $i++) { $delta[$i]="0" if (! $delta[$i]); return () if ($delta[$i] !~ /^[+-]?\d+$/); $sign = ($delta[$i] =~ s/^([+-])// ? $1 : $sign); $delta[$i] = $sign.$delta[$i]; } @delta; } # Reads up to 3 arguments. $h may contain the time in any international # format. Any empty elements are set to 0. sub Date_ParseTime { print "DEBUG: Date_ParseTime\n" if ($Curr{"Debug"} =~ /trace/); my($h,$m,$s)=@_; my($t)=&CheckTime("one"); if (defined $h and $h =~ /$t/) { $h=$1; $m=$2; $s=$3 if (defined $3); } $h="00" if (! defined $h); $m="00" if (! defined $m); $s="00" if (! defined $s); ($h,$m,$s); } # Forms a date with the 6 elements passed in (all of which must be defined). # No check as to validity is made. sub Date_Join { print "DEBUG: Date_Join\n" if ($Curr{"Debug"} =~ /trace/); my($y,$m,$d,$h,$mn,$s)=@_; my($ym,$md,$dh,$hmn,$mns)=(); if ($Cnf{"Internal"} == 0) { $ym=$md=$dh=""; $hmn=$mns=":"; } elsif ($Cnf{"Internal"} == 1) { $ym=$md=$dh=$hmn=$mns=""; } elsif ($Cnf{"Internal"} == 2) { $ym=$md="-"; $dh=" "; $hmn=$mns=":"; } else { confess "ERROR: Invalid internal format in Date_Join.\n"; } $m="0$m" if (length($m)==1); $d="0$d" if (length($d)==1); $h="0$h" if (length($h)==1); $mn="0$mn" if (length($mn)==1); $s="0$s" if (length($s)==1); "$y$ym$m$md$d$dh$h$hmn$mn$mns$s"; } # This checks a time. If it is valid, it splits it and returns 3 elements. # If "one" or "two" is passed in, a regexp with 1/2 or 2 digit hours is # returned. sub CheckTime { print "DEBUG: CheckTime\n" if ($Curr{"Debug"} =~ /trace/); my($time)=@_; my($h)='(?:0?[0-9]|1[0-9]|2[0-3])'; my($h2)='(?:0[0-9]|1[0-9]|2[0-3])'; my($m)='[0-5][0-9]'; my($s)=$m; my($hm)="(?:". $Lang{$Cnf{"Language"}}{"SepHM"} ."|:)"; my($ms)="(?:". $Lang{$Cnf{"Language"}}{"SepMS"} ."|:)"; my($ss)=$Lang{$Cnf{"Language"}}{"SepSS"}; my($t)="^($h)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$"; if ($time eq "one") { return $t; } elsif ($time eq "two") { $t="^($h2)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$"; return $t; } if ($time =~ /$t/i) { ($h,$m,$s)=($1,$2,$3); $h="0$h" if (length($h)<2); $m="0$m" if (length($m)<2); $s="00" if (! defined $s); return ($h,$m,$s); } else { return (); } } # This checks a recurrence. If it is valid, it splits it and returns the # elements. Otherwise, it returns an empty list. # ($recur0,$recur1,$flags,$dateb,$date0,$date1)=&Recur_Split($recur); sub Recur_Split { print "DEBUG: Recur_Split\n" if ($Curr{"Debug"} =~ /trace/); my($recur)=@_; my(@ret,@tmp); my($R) = '(\*?(?:[-,0-9]+[:\*]){6}[-,0-9]+)'; my($F) = '(?:\*([^*]*))'; my($DB,$D0,$D1); $DB=$D0=$D1=$F; if ($recur =~ /^$R$F?$DB?$D0?$D1?$/) { @ret=($1,$2,$3,$4,$5); @tmp=split(/\*/,shift(@ret)); return () if ($#tmp>1); return (@tmp,"",@ret) if ($#tmp==0); return (@tmp,@ret); } return (); } # This checks a date. If it is valid, it splits it and returns the elements. # If no date is passed in, it returns a regular expression for the date. sub Date_Split { print "DEBUG: Date_Split\n" if ($Curr{"Debug"} =~ /trace/); my($date)=@_; my($ym,$md,$dh,$hmn,$mns)=(); my($y)='(\d{4})'; my($m)='(0[1-9]|1[0-2])'; my($d)='(0[1-9]|[1-2][0-9]|3[0-1])'; my($h)='([0-1][0-9]|2[0-3])'; my($mn)='([0-5][0-9])'; my($s)=$mn; if ($Cnf{"Internal"} == 0) { $ym=$md=$dh=""; $hmn=$mns=":"; } elsif ($Cnf{"Internal"} == 1) { $ym=$md=$dh=$hmn=$mns=""; } elsif ($Cnf{"Internal"} == 2) { $ym=$md="-"; $dh=" "; $hmn=$mns=":"; } else { confess "ERROR: Invalid internal format in Date_Split.\n"; } my($t)="^$y$ym$m$md$d$dh$h$hmn$mn$mns$s\$"; return $t if ($date eq ""); if ($date =~ /$t/) { ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6); my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); $d_in_m[2]=29 if (&Date_LeapYear($y)); return () if ($d>$d_in_m[$m]); return ($y,$m,$d,$h,$mn,$s); } return (); } # This returns the date easter occurs on for a given year as ($month,$day). # This is from the Calendar FAQ. sub Date_Easter { my($y)=@_; $y=&Date_FixYear($y) if (length($y)==2); my($c) = $y/100; my($g) = $y % 19; my($k) = ($c-17)/25; my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30; $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11)); my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7; my($l) = $i-$j; my($m) = 3 + ($l+40)/44; my($d) = $l + 28 - 31*($m/4); return ($m,$d); } # This takes a list of years, months, WeekOfMonth's, and optionally # DayOfWeek's, and returns a list of dates. Optionally, a list of dates # can be passed in as the 1st argument (with the 2nd argument the null list) # and the year/month of these will be used. # # If $FDn is non-zero, the first week of the month contains the first # occurence of this day (1=Monday). If $FIn is non-zero, the first week of # the month contains the date (i.e. $FIn'th day of the month). sub Date_Recur_WoM { my($y,$m,$w,$d,$FDn,$FIn)=@_; my(@y)=@$y; my(@m)=@$m; my(@w)=@$w; my(@d)=@$d; my($date0,$date1,@tmp,@date,$d0,$d1,@tmp2)=(); if (@m) { @tmp=(); foreach $y (@y) { return () if (length($y)==1 || length($y)==3 || ! &IsInt($y,0,9999)); $y=&Date_FixYear($y) if (length($y)==2); push(@tmp,$y); } @y=sort { $a<=>$b } (@tmp); return () if (! @m); foreach $m (@m) { return () if (! &IsInt($m,1,12)); } @m=sort { $a<=>$b } (@m); @tmp=@tmp2=(); foreach $y (@y) { foreach $m (@m) { push(@tmp,$y); push(@tmp2,$m); } } @y=@tmp; @m=@tmp2; } else { foreach $d0 (@y) { @tmp=&Date_Split($d0); return () if (! @tmp); push(@tmp2,$tmp[0]); push(@m,$tmp[1]); } @y=@tmp2; } return () if (! @w); foreach $w (@w) { return () if ($w==0 || ! &IsInt($w,-5,5)); } if (@d) { foreach $d (@d) { return () if (! &IsInt($d,1,7)); } @d=sort { $a<=>$b } (@d); } @date=(); foreach $y (@y) { $m=shift(@m); # Find 1st day of this month and next month $date0=&Date_Join($y,$m,1,0,0,0); $date1=&DateCalc($date0,"+0:1:0:0:0:0:0"); if (@d) { foreach $d (@d) { # Find 1st occurence of DOW (in both months) $d0=&Date_GetNext($date0,$d,1); $d1=&Date_GetNext($date1,$d,1); @tmp=(); while (&Date_Cmp($d0,$d1)<0) { push(@tmp,$d0); $d0=&DateCalc($d0,"+0:0:1:0:0:0:0"); } @tmp2=(); foreach $w (@w) { if ($w>0) { push(@tmp2,$tmp[$w-1]); } else { push(@tmp2,$tmp[$#tmp+1+$w]); } } @tmp2=sort(@tmp2); push(@date,@tmp2); } } else { # Find 1st day of 1st week if ($FDn != 0) { $date0=&Date_GetNext($date0,$FDn,1); } else { $date0=&Date_Join($y,$m,$FIn,0,0,0); } $date0=&Date_GetPrev($date0,$Cnf{"FirstDay"},1); # Find 1st day of 1st week of next month if ($FDn != 0) { $date1=&Date_GetNext($date1,$FDn,1); } else { $date1=&DateCalc($date1,"+0:0:0:".($FIn-1).":0:0:0") if ($FIn>1); } $date1=&Date_GetPrev($date1,$Cnf{"FirstDay"},1); @tmp=(); while (&Date_Cmp($date0,$date1)<0) { push(@tmp,$date0); $date0=&DateCalc($date0,"+0:0:1:0:0:0:0"); } @tmp2=(); foreach $w (@w) { if ($w>0) { push(@tmp2,$tmp[$w-1]); } else { push(@tmp2,$tmp[$#tmp+1+$w]); } } @tmp2=sort(@tmp2); push(@date,@tmp2); } } @date; } # This returns a sorted list of dates formed by adding/subtracting # $delta to $dateb in the range $date0<=$d<$dateb. The first date int # the list is actually the first date<$date0 and the last date in the # list is the first date>=$date1 (because sometimes the set part will # move the date back into the range). sub Date_Recur { my($date0,$date1,$dateb,$delta)=@_; my(@ret,$d)=(); while (&Date_Cmp($dateb,$date0)<0) { $dateb=&DateCalc_DateDelta($dateb,$delta); } while (&Date_Cmp($dateb,$date1)>=0) { $dateb=&DateCalc_DateDelta($dateb,"-$delta"); } # Add the dates $date0..$dateb $d=$dateb; while (&Date_Cmp($d,$date0)>=0) { unshift(@ret,$d); $d=&DateCalc_DateDelta($d,"-$delta"); } # Add the first date earler than the range unshift(@ret,$d); # Add the dates $dateb..$date1 $d=&DateCalc_DateDelta($dateb,$delta); while (&Date_Cmp($d,$date1)<0) { push(@ret,$d); $d=&DateCalc_DateDelta($d,$delta); } # Add the first date later than the range push(@ret,$d); @ret; } # This sets the values in each date of a recurrence. # # $h,$m,$s can each be values or lists "1-2,4". If any are equal to "-1", # they are not set (and none of the larger elements are set). sub Date_RecurSetTime { my($date0,$date1,$dates,$h,$m,$s)=@_; my(@dates)=@$dates; my(@h,@m,@s,$date,@tmp)=(); $m="-1" if ($s eq "-1"); $h="-1" if ($m eq "-1"); if ($h ne "-1") { @h=&ReturnList($h); return () if ! (@h); @h=sort { $a<=>$b } (@h); @tmp=(); foreach $date (@dates) { foreach $h (@h) { push(@tmp,&Date_SetDateField($date,"h",$h,1)); } } @dates=@tmp; } if ($m ne "-1") { @m=&ReturnList($m); return () if ! (@m); @m=sort { $a<=>$b } (@m); @tmp=(); foreach $date (@dates) { foreach $m (@m) { push(@tmp,&Date_SetDateField($date,"mn",$m,1)); } } @dates=@tmp; } if ($s ne "-1") { @s=&ReturnList($s); return () if ! (@s); @s=sort { $a<=>$b } (@s); @tmp=(); foreach $date (@dates) { foreach $s (@s) { push(@tmp,&Date_SetDateField($date,"s",$s,1)); } } @dates=@tmp; } @tmp=(); foreach $date (@dates) { push(@tmp,$date) if (&Date_Cmp($date,$date0)>=0 && &Date_Cmp($date,$date1)<0 && &Date_Split($date)); } @tmp; } sub DateCalc_DateDate { print "DEBUG: DateCalc_DateDate\n" if ($Curr{"Debug"} =~ /trace/); my($D1,$D2,$mode)=@_; my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); $mode=0 if (! defined $mode); # Exact mode if ($mode==0) { my($y1,$m1,$d