# # sfldate.pl SFL date package # # Written: 97/05/22 Pieter Hintjens # Revised: 97/05/25 Pieter Hintjens # # Implements the complete set of macros and functions in the SFL date # package (sfldate.c). Macros are defined in lower-case: &get_month. # package sfldate; CONFIG: { # Julian date calculation: days before 1st of each month in year @julian_base = ( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334); # Number of days in each month, in a leap year @month_days = ( 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); # The timezone calculation was plucked from the timelocal.pl module. local (@epoch) = localtime (0); $'daylight = (localtime) [8]; # Is daylight savings time? $'timezone = $epoch [2] * 60 * 60 + $epoch [1] * 60; if ($'timezone > 0) { # Seconds west of GMT $'timezone = 24 * 60 * 60 - $'timezone; $'timezone -= 24 * 60 * 60 if $epoch [5] == 70; # Account for the date line } # Interval values, specified in centiseconds $'INTERVAL_CENTI = 1; $'INTERVAL_SEC = 100; $'INTERVAL_MIN = 6000; $'INTERVAL_HOUR = 360000; $'INTERVAL_DAY = 8640000; } # # Implement the date/time access macros from sfldate.h sub 'get_century { local ($date) = @_; return (int ($date / 1000000)); } sub 'get_ccyear { local ($date) = @_; return (int ($date / 10000)); } sub 'get_year { local ($date) = @_; return (int (($date % 1000000) / 10000)); } sub 'get_month { local ($date) = @_; return (int (($date % 10000) / 100)); } sub 'get_day { local ($date) = @_; return ($date % 100); } sub 'get_hour { local ($time) = @_; return (int ($time / 1000000)); } sub 'get_minute { local ($time) = @_; return (int (($time % 1000000) / 10000)); } sub 'get_second { local ($time) = @_; return (int (($time % 10000) / 100)); } sub 'get_centi { local ($time) = @_; return ($time % 100); } sub 'make_date { local ($century, $year, $month, $day) = @_; return ($century * 1000000 + $year * 10000 + $month * 100 + $day); } sub 'make_time { local ($hour, $minute, $second, $centi) = @_; return ($hour * 1000000 + $minute * 10000 + $second * 100 + $centi); } sub 'timeeq { local ($date1, $time1, $date2, $time2) = @_; return ($date1 == $date2 && $time1 == $time2); } sub 'timeneq { local ($date1,$time1,$date2,$time2) = @_; return ($date1 != $date2 || $time1 != $time2); } sub 'timelt { local ($date1,$time1,$date2,$time2) = @_; return ($date1 < $date2 || ($date1 == $date2 && $time1 < $time2)); } sub 'timele { local ($date1,$time1,$date2,$time2) = @_; return ($date1 < $date2 || ($date1 == $date2 && $time1 <= $time2)); } sub 'timegt { local ($date1,$time1,$date2,$time2) = @_; return ($date1 > $date2 || ($date1 == $date2 && $time1 > $time2)); } sub 'timege { local ($date1,$time1,$date2,$time2) = @_; return ($date1 > $date2 || ($date1 == $date2 && $time1 >= $time2)); } # ------------------------------------------------------------------------- # &date_now # # Synopsis: Returns the current date as a long value (CCYYMMDD). Since # most system clocks do not return a century, this function assumes that # all years 80 and above are in the 20th century, and all years 00 to 79 # are in the 21st century. For best results, consume before 1 Jan 2080. # # Selftest: # &date_now > 19970524 # &date_now == &'timer_to_date (date_to_timer (&date_now, &time_now)) # ------------------------------------------------------------------------- sub 'date_now { local ($day, $month, $year) = (localtime) [3..5]; return (&'make_date (0, $year + 1900, $month + 1, $day)); } # ------------------------------------------------------------------------- # &time_now # # Synopsis: Returns the current time as a long value (HHMMSSCC). If the # system clock does not return centiseconds, these are set to zero. # # Selftest: # &time_now == &'timer_to_time (date_to_timer (&date_now, &time_now)) # ------------------------------------------------------------------------- sub 'time_now { local ($sec, $min, $hour) = (localtime) [0..2]; return (&'make_time ($hour, $min, $sec, 0)); } # ------------------------------------------------------------------------- # &leap_year (year_value) # # Synopsis: Returns 1 if the year is a leap year. You must supply a # 4-digit value for the year: 90 is taken to mean 90 ad. Handles leap # centuries correctly. # # Selftest: # &leap_year (1984) == 1 # &leap_year (1985) == 0 # &leap_year (1900) == 0 # &leap_year (2000) == 1 # ------------------------------------------------------------------------- sub 'leap_year { local ($year) = @_; # Get subroutine arguments return (($year % 4 == 0 && $year % 100 != 0) || $year % 400 == 0); } # ------------------------------------------------------------------------- # &julian_date (date_value) # # Synopsis: Returns the number of days since 31 December last year. The # Julian date of 1 January is 1. # # Selftest: # &julian_date (19970101) == 1 # &julian_date (19970102) == 2 # &julian_date (19970201) == 32 # &julian_date (19971231) == 365 # ------------------------------------------------------------------------- sub 'julian_date { local ($date) = @_; # Get subroutine arguments local ($julian); $julian = $julian_base [&'get_month ($date) - 1] + &'get_day ($date); if (&'get_month ($date) > 2 && &'leap_year (&'get_year ($date))) { $julian++; } return ($julian); } # ------------------------------------------------------------------------- # &day_of_week (date_value) # # Synopsis: Returns the day of the week where 0 is Sunday, 1 is Monday, # ... 6 is Saturday. Uses Zeller's Congurence algorithm. # # Selftest: # &day_of_week (19961203) == 2 # &day_of_week (19970525) == 0 # -------------------------------------------------------------------------- sub 'day_of_week { local ($date) = @_; # Get subroutine arguments local ($year) = &'get_ccyear ($date); local ($month) = &'get_month ($date); local ($day) = &'get_day ($date); if ($month > 2) { $month -= 2; } else { $month += 10; $year--; } $day = (int ((13 * $month - 1) / 5) + $day + ($year % 100) + int (($year % 100) / 4) + int (int ($year / 100) / 4) - 2 * int ($year / 100) + 77); return ($day - 7 * int ($day / 7)); } # ------------------------------------------------------------------------- # &week_of_year (date_value) # # Synopsis: Returns the week of the year, where 1 is the first full week. # Week 0 may or may not exist in any year. Uses a Lillian date algorithm # to calculate the week of the year. The week starts on Sunday. # # Selftest: # &week_of_year (19970524) == 20 # &week_of_year (19970526) == 21 # -------------------------------------------------------------------------- sub 'week_of_year { local ($date) = @_; # Get subroutine arguments local ($year) = &'get_ccyear ($date) - 1501; local ($day) = $year * 365 + int ($year / 4) - 29872 + 1 - int ($year / 100) + int (($year - 300) / 400); return (int ((&'julian_date ($date) + int (($day + 4) % 7)) / 7)); } # ------------------------------------------------------------------------- # &year_quarter (date_value) # # Synopsis: Returns the year quarter, 1 to 4, depending on the month # specified. # # Selftest: # &year_quarter (19970331) == 1 # &year_quarter (19970401) == 2 # &year_quarter (19971231) == 4 # -------------------------------------------------------------------------- sub 'year_quarter { local ($date) = @_; # Get subroutine arguments return (int ((&'get_month ($date) - 1) / 3 + 1)); } # ------------------------------------------------------------------------- # &default_century (date_value) # # Synopsis: Supplies a default century for the year if necessary. If # the year is 51 to 99, the century is set to 19. If the year is 0 to # 50, the century is set to 20. Returns the adjusted date. # # Selftest: # &default_century (19970525) == 19970525 # &default_century (20070525) == 20070525 # &default_century (970525) == 19970525 # &default_century ( 70525) == 20070525 # -------------------------------------------------------------------------- sub 'default_century { local ($date) = @_; # Get subroutine arguments if (&'get_century ($date) == 0) { $date += &'get_year ($date) > 50? 19000000: 20000000; } return ($date); } # ------------------------------------------------------------------------- # &pack_date (date_value) # # Synopsis: Packs the date into a single unsigned short word. Use this # function to store dates when memory space is at a premium. The packed # date can be used correctly in comparisons. Returns the packed date. # The date must be later than 31 December 1979. # # Selftest: # &pack_date (19800101) == 33 # &pack_date (19970525) == 8889 # &unpack_date (&pack_date ($date = &date_now ())) == $date # -------------------------------------------------------------------------- sub 'pack_date { local ($date) = @_; # Get subroutine arguments return (((&'get_ccyear ($date) - 1980) << 9) + (&'get_month ($date) << 5) + &'get_day ($date)); } # ------------------------------------------------------------------------- # &pack_time (time_value) # # Synopsis: Packs the time into a single unsigned short word. Use this # function to store times when memory space is at a premium. The packed # time can be used correctly in comparisons. Returns the packed time. # Seconds are stored with 2-second accuracy and centiseconds are lost. # # Selftest: # &pack_time (12590000) == 26464; # &unpack_time (&pack_time ($time = &time_now ())) == int ($time / 200) * 200 # -------------------------------------------------------------------------- sub 'pack_time { local ($time) = @_; # Get subroutine arguments return ((&'get_hour ($time) << 11) + (&'get_minute ($time) << 5) + (&'get_second ($time) >> 1)); } # ------------------------------------------------------------------------- # &unpack_date (packed_date) # # Synopsis: Converts a packed date back into a long value. # # Selftest: # &unpack_date (33) == 19800101 # &unpack_date (8889) == 19970525 # &unpack_date (&pack_date ($date = &date_now ())) == $date # ------------------------------------------------------------------------- sub 'unpack_date { local ($packdate) = @_; # Get subroutine arguments local ($year); $year = (($packdate & 0xfe00) >> 9) + 1980; return (&'make_date (0, $year, ($packdate & 0x01e0) >> 5, ($packdate & 0x001f))); } # ------------------------------------------------------------------------- # &unpack_time (packed_time) # # Synopsis: Converts a packed time back into a long value. # # Selftest: # &unpack_time (26464) == 12590000; # &unpack_time (&pack_time ($time = &time_now ())) == int ($time / 200) * 200 # -------------------------------------------------------------------------- sub 'unpack_time { local ($packtime) = @_; # Get subroutine arguments return (&'make_time (($packtime & 0xf800) >> 11, ($packtime & 0x07e0) >> 5, ($packtime & 0x001f) << 1, 0)); } # ------------------------------------------------------------------------- # &date_to_days (date_value) # # Synopsis: Converts the date into a number of days since a distant but # unspecified epoch. You can use this function to calculate differences # between dates, and forward dates. Use &days_to_date to calculate the # reverse function. Author: Robert G. Tantzen, translated from the Algol # original in Collected Algorithms of the CACM (algorithm 199). Original # translation into C by Nat Howard, posted to Usenet 5 Jul 1985. Perl'd # By Pieter.(tm) # # Selftest: # &date_to_days (19970525) == 2450594; # &days_to_date (&date_to_days ($date = &date_now)) == $date # -------------------------------------------------------------------------- sub 'date_to_days { local ($date) = @_; # Get subroutine arguments local ($year) = &'get_year ($date), local ($century) = &'get_century ($date), local ($month) = &'get_month ($date), local ($day) = &'get_day ($date); if ($month > 2) { $month -= 3; } else { $month += 9; if ($year) { $year--; } else { $year = 99; $century--; } } return (int ((146097 * $century) / 4) + int ((1461 * $year) / 4) + int ((153 * $month + 2) / 5) + $day + 1721119); } # ------------------------------------------------------------------------- # &days_to_date (number_of_days) # # Synopsis: Converts a number of days since some distant but unspecified # epoch into a date. You can use this function to calculate differences # between dates, and forward dates. Use &date_to_days to calculate the # reverse function. Author: Robert G. Tantzen, translated from the Algol # original in Collected Algorithms of the CACM (algorithm 199). Original # translation into C by Nat Howard, posted to Usenet 5 Jul 1985. # # Selftest: # &date_to_days (19970525) == 2450594; # &days_to_date (&date_to_days ($date = &date_now)) == $date # -------------------------------------------------------------------------- sub 'days_to_date { local ($days) = @_; # Get subroutine arguments local ($century, $year, $month, $day); $days -= 1721119; $century = int ((4 * $days - 1) / 146097); $days = 4 * $days - 1 - 146097 * $century; $day = int ($days / 4); $year = int ((4 * $day + 3) / 1461); $day = 4 * $day + 3 - 1461 * $year; $day = int (($day + 4) / 4); $month = int ((5 * $day - 3) / 153); $day = 5 * $day - 3 - 153 * $month; $day = int (($day + 5) / 5); if ($month < 10) { $month += 3; } else { $month -= 9; $year++; # $year may overflow to 100 } return (&'make_date ($century, $year, $month, $day)); } # ---------------------------------------------------------------------[<]- # $timer = &date_to_timer (date_value, time_value) # # Synopsis: Converts the supplied date and time into a timer value, which # is the number of non-leap seconds since 00:00:00 UTC January 1, 1970. # # Selftest: # &date_now == &timer_to_date (date_to_timer (&date_now, &time_now)) # ---------------------------------------------------------------------[>]-*/ sub 'date_to_timer { local ($date, $time) = @_; # Get subroutine arguments # Get number of days since 1 January, 1970 local ($days) = &'date_to_days ($date) - 2440588; local ($seconds) = (( $days * 24 + &'get_hour ($time) - $'daylight) * 60 + &'get_minute ($time)) * 60 + &'get_second ($time); return ($seconds + $'timezone); } # ---------------------------------------------------------------------[<]- # &timer_to_date # # Synopsis: Converts the supplied timer value into a long date value. # Dates are stored as long values: CCYYMMDD. If the supplied value is # zero, returns zero. # # Selftest: # &date_now == &timer_to_date (date_to_timer (&date_now, &time_now)) # ---------------------------------------------------------------------[>]-*/ sub 'timer_to_date { local ($time_secs) = @_; # Get subroutine arguments if ($time_secs == 0) { return (0); } else { # Convert into a long value CCYYMMDD local ($day, $month, $year) = (localtime ($time_secs)) [3..5]; return (&'make_date (0, $year + 1900, $month + 1, $day)); } } # ---------------------------------------------------------------------[<]- # &timer_to_time # # Synopsis: Converts the supplied timer value into a long time value. # Times are stored as long values: HHMMSS00. Since the timer value does # not hold centiseconds, these are set to zero. If the supplied value # was zero, returns zero. # # Selftest: # &time_now == &timer_to_time (date_to_timer (&date_now, &time_now)) # ---------------------------------------------------------------------[>]-*/ sub 'timer_to_time { local ($time_secs) = @_; # Get subroutine arguments if ($time_secs == 0) { return (0); } else { local ($sec, $min, $hour) = (localtime ($time_secs)) [0..2]; return (&'make_time ($hour, $min, $sec, 0)); } } # ---------------------------------------------------------------------[<]- # &timer_to_gmdate # # Synopsis: Converts the supplied timer value into a long date value in # Greenwich Mean Time (GMT). Dates are stored as long values: CCYYMMDD. # If the supplied value is zero, returns zero. # # Selftest: # &timer_to_gmdate (100000) == &timer_to_date (100000 + timezone) # ---------------------------------------------------------------------[>]-*/ sub 'timer_to_gmdate { local ($time_secs) = @_; # Get subroutine arguments if ($time_secs == 0) { return (0); } else { # Convert into a long value CCYYMMDD local ($day, $month, $year) = (gmtime ($time_secs)) [3..5]; return (&'make_date (0, $year + 1900, $month + 1, $day)); } } # ---------------------------------------------------------------------[<]- # &timer_to_gmtime # # Synopsis: Converts the supplied timer value into a long time value in # Greenwich Mean Time (GMT). Times are stored as long values: HHMMSS00. # On most systems the clock does not return centiseconds, so these are # set to zero. If the supplied value is zero, returns zero. # # Selftest: # &timer_to_gmtime (100000) == &timer_to_time (100000 + $timezone) # ---------------------------------------------------------------------[>]-*/ sub 'timer_to_gmtime { local ($time_secs) = @_; # Get subroutine arguments if ($time_secs == 0) { return (0); } else { local ($sec, $min, $hour) = (gmtime ($time_secs)) [0..2]; return (&'make_time ($hour, $min, $sec, 0)); } } # ------------------------------------------------------------------------- # &time_to_csecs (time_value) # # Synopsis: Converts a time (HHMMSSCC) into a number of centiseconds. # # Selftest: # &csecs_to_time (&time_to_csecs ($time = &time_now)) == $time # -------------------------------------------------------------------------- sub 'time_to_csecs { local ($time) = @_; # Get subroutine arguments return (&'get_hour ($time) * $'INTERVAL_HOUR + &'get_minute ($time) * $'INTERVAL_MIN + &'get_second ($time) * $'INTERVAL_SEC + &'get_centi ($time)); } # ------------------------------------------------------------------------- # &csecs_to_time (centiseconds) # # Synopsis: Converts a number of centiseconds (< INTERVAL_DAY) into a # time value (HHMMSSCC). # # Selftest: # &csecs_to_time (&time_to_csecs ($time = &time_now)) == $time # -------------------------------------------------------------------------- sub 'csecs_to_time { local ($csecs) = @_; # Get subroutine arguments local ($hour, $min, $sec); $hour = int ($csecs / $'INTERVAL_HOUR); $csecs = $csecs % $'INTERVAL_HOUR; $min = int ($csecs / $'INTERVAL_MIN); $csecs = $csecs % $'INTERVAL_MIN; $sec = int ($csecs / $'INTERVAL_SEC); $csecs = $csecs % $'INTERVAL_SEC; return (&'make_time ($hour, $min, $sec, $csecs)); } # ------------------------------------------------------------------------- # ($date, $time) = &future_date ($date, $time, days, csecs) # # Synopsis: Calculates a future date and time from the date and time # specified, plus an interval specified in days and 1/100th seconds. # The date can be any date since some distant epoch (around 1600). # If the date and time arguments are both zero, the current date and # time are used. # # Selftest: # &future_date (19970525, 12000000, 1, 100) == (19970526, 12000100) # &future_date (19970531, 23595900, 0, 100) == (19970601, 0) # -------------------------------------------------------------------------- sub 'future_date { local ($date, $time, $days, $csecs) = @_; # Set date and time to NOW if necessary if ($date == 0 && $time == 0) { $date = &'date_now; $time = &'time_now; } # Get future date in days and centiseconds $days = &'date_to_days ($date) + $days; $csecs = &'time_to_csecs ($time) + $csecs; # Normalise overflow in centiseconds while ($csecs >= $'INTERVAL_DAY) { $days++; $csecs -= $'INTERVAL_DAY; } # Convert date and time back into organised values $date = &'days_to_date ($days); $time = &'csecs_to_time ($csecs); return ($date, $time); } # ------------------------------------------------------------------------- # ($date, $time) = &past_date ($date, $time, days, csecs) # # Synopsis: Calculates a past date and time from the date and time # specified, minus an interval specified in days and 1/100th seconds. # The date can be any date since some distant epoch (around 1600). # If the date and time arguments are both zero, the current date and # time are used. # # Selftest: # &past_date (19970526, 12000100, 1, 100) == (19970525, 12000000) # &past_date (19970601, 0, 0, 100) == (19970531, 23595900) # -------------------------------------------------------------------------- sub 'past_date { local ($date, $time, $days, $csecs) = @_; # Set date and time to NOW if necessary if ($date == 0 && $time == 0) { $date = &'date_now; $time = &'time_now; } # Get past date in days and centiseconds $days = &'date_to_days ($date) - $days; $csecs = &'time_to_csecs ($time) - $csecs; # Normalise underflow in centiseconds while ($csecs < 0) { $days--; $csecs += $'INTERVAL_DAY; } # Convert date and time back into organised values $date = &'days_to_date ($days); $time = &'csecs_to_time ($csecs); return ($date, $time); } # ------------------------------------------------------------------------- # ($days, $csecs) = &date_diff ($date1, $time1, $date2, $time2) # # Synopsis: Calculates the difference between two date/time values, and # returns the difference as a number of days and a number of centiseconds. # The date can be any date since some distant epoch (around 1600). The # calculation is date1:time1 - date2:time2. The returned values may be # negative. # # Selftest: # &date_diff (19970526, 12000100, 19970525, 12000000) == (1, 100) # -------------------------------------------------------------------------- sub 'date_diff { local ($date1, $time1, $date2, $time2) = @_; local ($days, $csecs); $days = &'date_to_days ($date1) - &'date_to_days ($date2); $csecs = &'time_to_csecs ($time1) - &'time_to_csecs ($time2); return ($days, $csecs); } # ------------------------------------------------------------------------- # &valid_date (date_value) # # Synopsis: Returns 1 if the date is valid or zero; returns 0 if the date # is not valid. # # Selftest: # &valid_date (19970526) == 1 # &valid_date (19970532) == 0 # &valid_date (19970229) == 0 # &valid_date (20000229) == 1 # -------------------------------------------------------------------------- sub 'valid_date { local ($date) = @_; # Get subroutine arguments local ($month, $day, $feedback); $month = &'get_month ($date); $day = &'get_day ($date); if ($date == 0) { $feedback = 1; # Zero date is okay } elsif ($month < 1 || $month > 12) { $feedback = 0; # Month out of range } elsif (($day < 1 || $day > $month_days [$month - 1]) || ($month == 2 && $day == 29 && !&'leap_year (&'get_year ($date)))) { $feedback = 0; # Day out of range } else { $feedback = 1; # Zero date is okay } return ($feedback); } # ------------------------------------------------------------------------- # &valid_time (time_value) # # Synopsis: Returns TRUE if the time is valid or zero; returns FALSE if # the time is not valid. # # Selftest: # &valid_time (19596000) == 0 # &valid_time (19595999) == 1 # &valid_time (24000000) == 0 # &valid_time ( 0) == 1 # -------------------------------------------------------------------------- sub 'valid_time { local ($time) = @_; # Get subroutine arguments return (&'get_second ($time) < 60 && &'get_minute ($time) < 60 && &'get_hour ($time) < 24); } # ------------------------------------------------------------------------- # &date_is_future (date_value, time_value) # # Synopsis: Returns TRUE if the specified date and time are in the future. # Returns FALSE if the date and time are in the past, or the present (which # will be the past by the time you've read this). Date is specified as a # YYYYMMDD value; time as HHMMSSCC. # # Selftest: # &date_is_future (&future_date (&date_now, &time_now, 0, 1000)) == 1 # &date_is_future (&future_date (&date_now, &time_now, 0, 0)) == 0 # -------------------------------------------------------------------------- sub 'date_is_future { local ($date, $time) = @_; # Get subroutine arguments return ($date > &'date_now || $date == &'date_now && $time > &'time_now); } # ------------------------------------------------------------------------- # &date_is_past (date_value, time_value) # # Synopsis: Returns TRUE if the specified date and time are in the past. # Returns FALSE if the date and time are in the future or present (which # despite any assertion to the contrary, is not the past. Although that # may change soon). Date is specified as YYYYMMDD; time as HHMMSSCC. # # Selftest: # &date_is_past (&past_date (&date_now, &time_now, 0, 1000)) == 1 # &date_is_past (&past_date (&date_now, &time_now, 0, 0)) == 0 # -------------------------------------------------------------------------- sub 'date_is_past { local ($date, $time) = @_; # Get subroutine arguments return ($date < &'date_now || $date == &'date_now && $time < &'time_now); }