|
Packit |
95306a |
package Date::Manip::Base;
|
|
Packit |
95306a |
# Copyright (c) 1995-2017 Sullivan Beck. All rights reserved.
|
|
Packit |
95306a |
# This program is free software; you can redistribute it and/or modify it
|
|
Packit |
95306a |
# under the same terms as Perl itself.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Any routine that starts with an underscore (_) is NOT intended for
|
|
Packit |
95306a |
# public use. They are for internal use in the the Date::Manip
|
|
Packit |
95306a |
# modules and are subject to change without warning or notice.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
|
|
Packit |
95306a |
require 5.010000;
|
|
Packit |
95306a |
use strict;
|
|
Packit |
95306a |
use warnings;
|
|
Packit |
95306a |
use integer;
|
|
Packit |
95306a |
use utf8;
|
|
Packit |
95306a |
#use re 'debug';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
use Date::Manip::Obj;
|
|
Packit |
95306a |
use Date::Manip::TZ_Base;
|
|
Packit |
95306a |
our @ISA = qw(Date::Manip::Obj Date::Manip::TZ_Base);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
use Encode qw(encode_utf8 from_to find_encoding decode _utf8_off _utf8_on is_utf8);
|
|
Packit |
95306a |
require Date::Manip::Lang::index;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
our $VERSION;
|
|
Packit |
95306a |
$VERSION='6.60';
|
|
Packit |
95306a |
END { undef $VERSION; }
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# BASE METHODS
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _init {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_init_cache();
|
|
Packit |
95306a |
$self->_init_language();
|
|
Packit |
95306a |
$self->_init_config();
|
|
Packit |
95306a |
$self->_init_events();
|
|
Packit |
95306a |
$self->_init_holidays();
|
|
Packit |
95306a |
$self->_init_now();
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# The base object has some config-independant information which is
|
|
Packit |
95306a |
# always reused, and only needs to be initialized once.
|
|
Packit |
95306a |
sub _init_cache {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'cache'}{'init'});
|
|
Packit |
95306a |
$$self{'cache'}{'init'} = 1;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# ly => {Y} = 0/1 1 if it is a leap year
|
|
Packit |
95306a |
# ds1_mon => {Y}{M} = N days since 1BC for Y/M/1
|
|
Packit |
95306a |
# dow_mon => {Y}{M} = DOW day of week of Y/M/1
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'cache'}{'ly'} = {};
|
|
Packit |
95306a |
$$self{'cache'}{'ds1_mon'} = {};
|
|
Packit |
95306a |
$$self{'cache'}{'dow_mon'} = {};
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Config dependent data. Needs to be reset every time the config is reset.
|
|
Packit |
95306a |
sub _init_data {
|
|
Packit |
95306a |
my($self,$force) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'data'}{'calc'} && ! $force);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'calc'} = {}; # Calculated values
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Initializes config dependent data
|
|
Packit |
95306a |
sub _init_config {
|
|
Packit |
95306a |
my($self,$force) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'data'}{'sections'}{'conf'} && ! $force);
|
|
Packit |
95306a |
$self->_init_data();
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Set config defaults
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'} =
|
|
Packit |
95306a |
{
|
|
Packit |
95306a |
# Reset config, holiday lists, or events lists
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'defaults' => '',
|
|
Packit |
95306a |
'eraseholidays' => '',
|
|
Packit |
95306a |
'eraseevents' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Which language to use when parsing dates.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'language' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# 12/10 = Dec 10 (US) or Oct 12 (anything else)
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'dateformat' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Define the work week (1=monday, 7=sunday)
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# These have to be predefined to avoid a bootstrap issue, but
|
|
Packit |
95306a |
# the true defaults are defined below.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'workweekbeg' => 1,
|
|
Packit |
95306a |
'workweekend' => 5,
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# If non-nil, a work day is treated as 24 hours long
|
|
Packit |
95306a |
# (WorkDayBeg/WorkDayEnd ignored)
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'workday24hr' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Start and end time of the work day (any time format allowed,
|
|
Packit |
95306a |
# seconds ignored). If the defaults change, be sure to change
|
|
Packit |
95306a |
# the starting value of bdlength above.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'workdaybeg' => '',
|
|
Packit |
95306a |
'workdayend' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# 2 digit years fall into the 100 year period given by [ CURR-N,
|
|
Packit |
95306a |
# CURR+(99-N) ] where N is 0-99. Default behavior is 89, but
|
|
Packit |
95306a |
# other useful numbers might be 0 (forced to be this year or
|
|
Packit |
95306a |
# later) and 99 (forced to be this year or earlier). It can
|
|
Packit |
95306a |
# also be set to 'c' (current century) or 'cNN' (i.e. c18
|
|
Packit |
95306a |
# forces the year to bet 1800-1899). Also accepts the form
|
|
Packit |
95306a |
# cNNNN to give the 100 year period NNNN to NNNN+99.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'yytoyyyy' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# First day of the week (1=monday, 7=sunday). ISO 8601 says
|
|
Packit |
95306a |
# monday.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'firstday' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# If this is 0, use the ISO 8601 standard that Jan 4 is in week
|
|
Packit |
95306a |
# 1. If 1, make week 1 contain Jan 1.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'jan1week1' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Date::Manip printable format
|
|
Packit |
95306a |
# 0 = YYYYMMDDHH:MN:SS
|
|
Packit |
95306a |
# 1 = YYYYHHMMDDHHMNSS
|
|
Packit |
95306a |
# 2 = YYYY-MM-DD-HH:MN:SS
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'printable' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# If 'today' is a holiday, we look either to 'tomorrow' or
|
|
Packit |
95306a |
# 'yesterday' for the nearest business day. By default, we'll
|
|
Packit |
95306a |
# always look 'tomorrow' first.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'tomorrowfirst' => 1,
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Used to set the current date/time/timezone.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'forcedate' => 0,
|
|
Packit |
95306a |
'setdate' => 0,
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Use this to set the default range of the recurrence.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'recurrange' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Use this to set the default time.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'defaulttime' => 'midnight',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Whether or not to use a period as a time separator.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'periodtimesep' => 0,
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# How to parse mmm#### strings
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'format_mmmyyyy' => '',
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# *** DEPRECATED ***
|
|
Packit |
95306a |
|
|
Packit |
95306a |
'tz' => '',
|
|
Packit |
95306a |
};
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Calculate delta field lengths
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# non-business
|
|
Packit |
95306a |
$$self{'data'}{'len'}{'yrlen'} = 365.2425;
|
|
Packit |
95306a |
$$self{'data'}{'len'}{'0'} =
|
|
Packit |
95306a |
{ 'yl' => 31556952, # 365.2425 * 24 * 3600
|
|
Packit |
95306a |
'ml' => 2629746, # yl / 12
|
|
Packit |
95306a |
'wl' => 604800, # 6 * 24 * 3600
|
|
Packit |
95306a |
'dl' => 86400, # 24 * 3600
|
|
Packit |
95306a |
};
|
|
Packit |
95306a |
$self->_calc_workweek();
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Initialize some config variables that do some additional work.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_config_var('workday24hr', 1);
|
|
Packit |
95306a |
$self->_config_var('workdaybeg', '08:00:00');
|
|
Packit |
95306a |
$self->_config_var('workdayend', '17:00:00');
|
|
Packit |
95306a |
$self->_config_var('workday24hr', 0);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_config_var('dateformat', 'US');
|
|
Packit |
95306a |
$self->_config_var('yytoyyyy', 89);
|
|
Packit |
95306a |
$self->_config_var('jan1week1', 0);
|
|
Packit |
95306a |
$self->_config_var('printable', 0);
|
|
Packit |
95306a |
$self->_config_var('firstday', 1);
|
|
Packit |
95306a |
$self->_config_var('workweekbeg', 1);
|
|
Packit |
95306a |
$self->_config_var('workweekend', 5);
|
|
Packit |
95306a |
$self->_config_var('language', 'english');
|
|
Packit |
95306a |
$self->_config_var('recurrange', 'none');
|
|
Packit |
95306a |
$self->_config_var('defaulttime', 'midnight');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Set OS specific defaults
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $os = $self->_os();
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _calc_workweek {
|
|
Packit |
95306a |
my($self,$beg,$end) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$beg = $self->_config('workweekbeg') if (! $beg);
|
|
Packit |
95306a |
$end = $self->_config('workweekend') if (! $end);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'len'}{'workweek'} = $end - $beg + 1;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _calc_bdlength {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my @beg = @{ $$self{'data'}{'calc'}{'workdaybeg'} };
|
|
Packit |
95306a |
my @end = @{ $$self{'data'}{'calc'}{'workdayend'} };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'len'}{'bdlength'} =
|
|
Packit |
95306a |
($end[0]-$beg[0])*3600 + ($end[1]-$beg[1])*60 + ($end[2]-$beg[2]);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _init_business_length {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
my $x = $$self{'data'}{'len'}{'workweek'};
|
|
Packit |
95306a |
my $y_to_d = $x/7 * 365.2425;
|
|
Packit |
95306a |
my $d_to_s = $$self{'data'}{'len'}{'bdlength'};
|
|
Packit |
95306a |
my $w_to_d = $x;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'len'}{'1'} = { 'yl' => $y_to_d * $d_to_s,
|
|
Packit |
95306a |
'ml' => $y_to_d * $d_to_s / 12,
|
|
Packit |
95306a |
'wl' => $w_to_d * $d_to_s,
|
|
Packit |
95306a |
'dl' => $d_to_s,
|
|
Packit |
95306a |
};
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Events and holidays are reset only when they are read in.
|
|
Packit |
95306a |
sub _init_events {
|
|
Packit |
95306a |
my($self,$force) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'data'}{'events'} && ! $force);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# {data}{sections}{events} = [ STRING, EVENT_NAME, ... ]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# {data}{events}{I}{type} = TYPE
|
|
Packit |
95306a |
# {name} = NAME
|
|
Packit |
95306a |
# TYPE: specified An event with a start/end date (only parsed once)
|
|
Packit |
95306a |
# {beg} = DATE_OBJECT
|
|
Packit |
95306a |
# {end} = DATE_OBJECT
|
|
Packit |
95306a |
# TYPE: ym
|
|
Packit |
95306a |
# {beg} = YM_STRING
|
|
Packit |
95306a |
# {end} = YM_STRING (only for YM;YM)
|
|
Packit |
95306a |
# {YEAR} = [ DATE_OBJECT, DATE_OBJECT ]
|
|
Packit |
95306a |
# TYPE: date An event specified by a date string and delta
|
|
Packit |
95306a |
# {beg} = DATE_STRING
|
|
Packit |
95306a |
# {end} = DATE_STRING (only for Date;Date)
|
|
Packit |
95306a |
# {delta} = DELTA_OBJECT (only for Date;Delta)
|
|
Packit |
95306a |
# {YEAR} = [ DATE_OBJECT, DATE_OBJECT ]
|
|
Packit |
95306a |
# TYPE: recur
|
|
Packit |
95306a |
# {recur} = RECUR_OBJECT
|
|
Packit |
95306a |
# {delta} = DELTA_OBJECT
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# {data}{eventyears}{YEAR} = 0/1
|
|
Packit |
95306a |
# {data}{eventobjs} = 0/1
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'events'} = {};
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'events'} = [];
|
|
Packit |
95306a |
$$self{'data'}{'eventyears'} = {};
|
|
Packit |
95306a |
$$self{'data'}{'eventobjs'} = 0;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _init_holidays {
|
|
Packit |
95306a |
my($self,$force) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'data'}{'holidays'} && ! $force);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# {data}{sections}{holidays} = [ STRING, HOLIDAY_NAME, ... ]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# {data}{holidays}{init} = 1 if holidays have been initialized
|
|
Packit |
95306a |
# {ydone} = { Y => 1 }
|
|
Packit |
95306a |
# {yhols} = { Y => NAME => [Y,M,D] }
|
|
Packit |
95306a |
# {hols} = { NAME => Y => [Y,M,D] }
|
|
Packit |
95306a |
# {dates} = { Y => M => D => NAME }
|
|
Packit |
95306a |
# {defs} = [ NAME DEF NAME DEF ... ]
|
|
Packit |
95306a |
# NAME is the name of a holiday (it will
|
|
Packit |
95306a |
# be 'DMunnamed I' for the Ith unnamed
|
|
Packit |
95306a |
# holiday)
|
|
Packit |
95306a |
# DEF is a string or a Recur
|
|
Packit |
95306a |
# {data}{init_holidays} = 1 if currently initializing holidays
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'holidays'} = {};
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'holidays'} = [];
|
|
Packit |
95306a |
$$self{'data'}{'init_holidays'} = 0;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _init_now {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# {'data'}{'now'} = {
|
|
Packit |
95306a |
# date => [Y,M,D,H,MN,S] now
|
|
Packit |
95306a |
# isdst => ISDST
|
|
Packit |
95306a |
# offset => [H,MN,S]
|
|
Packit |
95306a |
# abb => ABBREV
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# force => 0/1 SetDate/ForceDate information
|
|
Packit |
95306a |
# set => 0/1
|
|
Packit |
95306a |
# setsecs => SECS time (in secs since epoch) when
|
|
Packit |
95306a |
# SetDate was called
|
|
Packit |
95306a |
# setdate => [Y,M,D,H,MN,S] the date (IN GMT) we're calling
|
|
Packit |
95306a |
# now when SetDate was called
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# tz => ZONE timezone we're working in
|
|
Packit |
95306a |
# systz => ZONE timezone of the system
|
|
Packit |
95306a |
# }
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'now'} = {};
|
|
Packit |
95306a |
$$self{'data'}{'now'}{'force'} = 0;
|
|
Packit |
95306a |
$$self{'data'}{'now'}{'set'} = 0;
|
|
Packit |
95306a |
$$self{'data'}{'tmpnow'} = [];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Language information only needs to be initialized if the language changes.
|
|
Packit |
95306a |
sub _init_language {
|
|
Packit |
95306a |
my($self,$force) = @_;
|
|
Packit |
95306a |
return if (exists $$self{'data'}{'lang'} && ! $force);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'lang'} = {}; # Current language info
|
|
Packit |
95306a |
$$self{'data'}{'rx'} = {}; # Regexps generated from language
|
|
Packit |
95306a |
$$self{'data'}{'words'} = {}; # Types of words in the language
|
|
Packit |
95306a |
$$self{'data'}{'wordval'} = {}; # Value of words in the language
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# MAIN METHODS
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub leapyear {
|
|
Packit |
95306a |
my($self,$y) = @_;
|
|
Packit |
95306a |
$y += 0;
|
|
Packit |
95306a |
return $$self{'cache'}{'ly'}{$y}
|
|
Packit |
95306a |
if (exists $$self{'cache'}{'ly'}{$y});
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y % 4 == 0);
|
|
Packit |
95306a |
$$self{'cache'}{'ly'}{$y} = 1, return 1 unless ($y % 100 == 0);
|
|
Packit |
95306a |
$$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y % 400 == 0);
|
|
Packit |
95306a |
$$self{'cache'}{'ly'}{$y} = 1;
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub days_in_year {
|
|
Packit |
95306a |
my($self,$y) = @_;
|
|
Packit |
95306a |
return ($self->leapyear($y) ? 366 : 365);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
{
|
|
Packit |
95306a |
my(@leap)=(31,29,31,30, 31,30,31,31, 30,31,30,31);
|
|
Packit |
95306a |
my(@nonl)=(31,28,31,30, 31,30,31,31, 30,31,30,31);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub days_in_month {
|
|
Packit |
95306a |
my($self,$y,$m) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($m) {
|
|
Packit |
95306a |
return ($self->leapyear($y) ? $leap[$m-1] : $nonl[$m-1]);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return ($self->leapyear($y) ? @leap : @nonl);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
{
|
|
Packit |
95306a |
# DinM = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
|
|
Packit |
95306a |
my(@doy_days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Note: I tested storing both leap year and non-leap year days in
|
|
Packit |
95306a |
# a hash, but it was slightly slower.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($lyd,$n,$remain,$day,$y,$m,$d,$h,$mn,$s,$arg);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub day_of_year {
|
|
Packit |
95306a |
my($self,@args) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
if ($#args == 1) {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $date = day_of_year($y,$day);
|
|
Packit |
95306a |
($y,$n) = @args;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$lyd = $self->leapyear($y);
|
|
Packit |
95306a |
$remain = ($n - int($n));
|
|
Packit |
95306a |
$n = int($n);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Calculate the month and the day
|
|
Packit |
95306a |
for ($m=1; $m<=12; $m++) {
|
|
Packit |
95306a |
last if ($n<=($doy_days[$m] + ($m==1 ? 0 : $lyd)));
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$d = $n-($doy_days[$m-1] + (($m-1)<2 ? 0 : $lyd));
|
|
Packit |
95306a |
return [$y,$m,$d] if (! $remain);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Calculate the hours, minutes, and seconds into the day.
|
|
Packit |
95306a |
$remain *= 24;
|
|
Packit |
95306a |
$h = int($remain);
|
|
Packit |
95306a |
$remain = ($remain - $h)*60;
|
|
Packit |
95306a |
$mn = int($remain);
|
|
Packit |
95306a |
$remain = ($remain - $mn)*60;
|
|
Packit |
95306a |
$s = $remain;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return [$y,$m,$d,$h,$mn,$s];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$arg = $args[0];
|
|
Packit |
95306a |
@args = @$arg;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
($y,$m,$d,$h,$mn,$s) = @args;
|
|
Packit |
95306a |
$lyd = $self->leapyear($y);
|
|
Packit |
95306a |
$lyd = 0 if ($m <= 2);
|
|
Packit |
95306a |
$day = ($doy_days[$m-1]+$d+$lyd);
|
|
Packit |
95306a |
return $day if ($#args==2);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$day += ($h*3600 + $mn*60 + $s)/(24*3600);
|
|
Packit |
95306a |
return $day;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub days_since_1BC {
|
|
Packit |
95306a |
my($self,$arg) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (ref($arg)) {
|
|
Packit |
95306a |
my($y,$m,$d) = @$arg;
|
|
Packit |
95306a |
$y += 0;
|
|
Packit |
95306a |
$m += 0;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! exists $$self{'cache'}{'ds1_mon'}{$y}{$m}) {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! exists $$self{'cache'}{'ds1_mon'}{$y}{1}) {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($Ny,$N4,$N100,$N400,$cc,$yy);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $yyyy = "0000$y";
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$yyyy =~ /(\d\d)(\d\d)$/o;
|
|
Packit |
95306a |
($cc,$yy) = ($1,$2);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Number of full years since Dec 31, 1BC (starting at 0001)
|
|
Packit |
95306a |
$Ny = $y - 1;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Number of full 4th years (0004, 0008, etc.) since Dec 31, 1BC
|
|
Packit |
95306a |
$N4 = int($Ny/4);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Number of full 100th years (0100, 0200, etc.)
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$N100 = $cc + 0;
|
|
Packit |
95306a |
$N100-- if ($yy==0);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Number of full 400th years (0400, 0800, etc.)
|
|
Packit |
95306a |
$N400 = int($N100/4);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'cache'}{'ds1_mon'}{$y}{1} =
|
|
Packit |
95306a |
$Ny*365 + $N4 - $N100 + $N400 + 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($i,$j);
|
|
Packit |
95306a |
my @mon = $self->days_in_month($y,0);
|
|
Packit |
95306a |
for ($i=2; $i<=12; $i++) {
|
|
Packit |
95306a |
$j = shift(@mon);
|
|
Packit |
95306a |
$$self{'cache'}{'ds1_mon'}{$y}{$i} =
|
|
Packit |
95306a |
$$self{'cache'}{'ds1_mon'}{$y}{$i-1} + $j;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($$self{'cache'}{'ds1_mon'}{$y}{$m} + $d - 1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
my($days) = $arg;
|
|
Packit |
95306a |
my($y,$m,$d);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$y = int($days/$$self{'data'}{'len'}{'yrlen'})+1;
|
|
Packit |
95306a |
while ($self->days_since_1BC([$y,1,1]) > $days) {
|
|
Packit |
95306a |
$y--;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$m = 12;
|
|
Packit |
95306a |
while ( ($d=$self->days_since_1BC([$y,$m,1])) > $days ) {
|
|
Packit |
95306a |
$m--;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$d = ($days-$d+1);
|
|
Packit |
95306a |
return [$y,$m,$d];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub day_of_week {
|
|
Packit |
95306a |
my($self,$date) = @_;
|
|
Packit |
95306a |
my($y,$m,$d) = @$date;
|
|
Packit |
95306a |
$y += 0;
|
|
Packit |
95306a |
$m += 0;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($dayofweek,$dec31) = ();
|
|
Packit |
95306a |
if (! exists $$self{'cache'}{'dow_mon'}{$y}{$m}) {
|
|
Packit |
95306a |
$dec31 = 7; # Dec 31, 1BC was Sunday
|
|
Packit |
95306a |
$$self{'cache'}{'dow_mon'}{$y}{$m} =
|
|
Packit |
95306a |
( $self->days_since_1BC([$y,$m,1])+$dec31 ) % 7;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$dayofweek = ($$self{'cache'}{'dow_mon'}{$y}{$m}+$d-1) % 7;
|
|
Packit |
95306a |
$dayofweek = 7 if ($dayofweek==0);
|
|
Packit |
95306a |
return $dayofweek;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Can be the nth DoW of year or month (if $m given). Returns undef if
|
|
Packit |
95306a |
# the date doesn't exists (i.e. 5th Sunday in a month with only 4).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub nth_day_of_week {
|
|
Packit |
95306a |
my($self,$y,$n,$dow,$m) = @_;
|
|
Packit |
95306a |
$y += 0;
|
|
Packit |
95306a |
$m = ($m ? $m+0 : 0);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $d is the current DoM (if $m) or DoY
|
|
Packit |
95306a |
# $max is the max value allowed for $d
|
|
Packit |
95306a |
# $ddow is the DoW of $d
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($d,$max,$ddow);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($m) {
|
|
Packit |
95306a |
$max = $self->days_in_month($y,$m);
|
|
Packit |
95306a |
$d = ($n<0 ? $max : 1);
|
|
Packit |
95306a |
$ddow = $self->day_of_week([$y,$m,$d]);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$max = $self->days_in_year($y);
|
|
Packit |
95306a |
$d = ($n<0 ? $max : 1);
|
|
Packit |
95306a |
if ($n<0) {
|
|
Packit |
95306a |
$d = $max;
|
|
Packit |
95306a |
$ddow = $self->day_of_week([$y,12,31]);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$d = 1;
|
|
Packit |
95306a |
$ddow = $self->day_of_week([$y,1,1]);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Find the first occurrence of $dow on or after $d (if $n>0)
|
|
Packit |
95306a |
# or the last occurrence of $dow on or before $d (if ($n<0);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($dow < $ddow) {
|
|
Packit |
95306a |
$d += 7 - ($ddow-$dow);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$d += ($dow-$ddow);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$d -= 7 if ($d > $max);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Find the nth occurrence of $dow
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($n > 1) {
|
|
Packit |
95306a |
$d += 7*($n-1);
|
|
Packit |
95306a |
return undef if ($d > $max);
|
|
Packit |
95306a |
} elsif ($n < -1) {
|
|
Packit |
95306a |
$d -= 7*(-1*$n-1);
|
|
Packit |
95306a |
return undef if ($d < 1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Return the date
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($m) {
|
|
Packit |
95306a |
return [$y,$m,$d];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return $self->day_of_year($y,$d);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
{
|
|
Packit |
95306a |
# Integer arithmetic doesn't work due to the size of the numbers.
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
# my $sec_70 =($self->days_since_1BC([1970,1,1])-1)*24*3600;
|
|
Packit |
95306a |
my $sec_70 = 62135596800;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Using 'global' variables saves 4%
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s,$sec,$sec_0,$tmp);
|
|
Packit |
95306a |
sub secs_since_1970 {
|
|
Packit |
95306a |
my($self,$arg) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (ref($arg)) {
|
|
Packit |
95306a |
($y,$m,$d,$h,$mn,$s) = @$arg;
|
|
Packit |
95306a |
$sec_0 = ($self->days_since_1BC([$y,$m,$d])-1)*24*3600 + $h*3600 +
|
|
Packit |
95306a |
$mn*60 + $s;
|
|
Packit |
95306a |
$sec = $sec_0 - $sec_70;
|
|
Packit |
95306a |
return $sec;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
($sec) = $arg;
|
|
Packit |
95306a |
$sec_0 = $sec_70 + $sec;
|
|
Packit |
95306a |
$tmp = int($sec_0/24/3600)+1;
|
|
Packit |
95306a |
my $ymd = $self->days_since_1BC($tmp);
|
|
Packit |
95306a |
($y,$m,$d) = @$ymd;
|
|
Packit |
95306a |
$sec_0 -= ($tmp-1)*24*3600;
|
|
Packit |
95306a |
$h = int($sec_0/3600);
|
|
Packit |
95306a |
$sec_0 -= $h*3600;
|
|
Packit |
95306a |
$mn = int($sec_0/60);
|
|
Packit |
95306a |
$s = $sec_0 - $mn*60;
|
|
Packit |
95306a |
return [$y,$m,$d,$h,$mn,$s];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub check {
|
|
Packit |
95306a |
my($self,$date) = @_;
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s) = @$date;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0 if (! $self->check_time([$h,$mn,$s]) ||
|
|
Packit |
95306a |
$y<1 || $y>9999 ||
|
|
Packit |
95306a |
$m<1 || $m>12);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $days = $self->days_in_month($y,$m);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0 if ($d<1 || $d>$days);
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub check_time {
|
|
Packit |
95306a |
my($self,$hms) = @_;
|
|
Packit |
95306a |
my($h,$mn,$s) = @$hms;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0 if ("$h:$mn:$s" !~ /^\d\d?:\d\d?:\d\d?$/o ||
|
|
Packit |
95306a |
$h > 24 || $mn > 59 || $s > 59 ||
|
|
Packit |
95306a |
($h == 24 && ($mn || $s)));
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub week1_day1 {
|
|
Packit |
95306a |
my($self,$year) = @_;
|
|
Packit |
95306a |
my $firstday = $self->_config('firstday');
|
|
Packit |
95306a |
return $self->_week1_day1($firstday,$year);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _week1_day1 {
|
|
Packit |
95306a |
my($self,$firstday,$year) = @_;
|
|
Packit |
95306a |
my $jan1week1 = $self->_config('jan1week1');
|
|
Packit |
95306a |
return $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year}
|
|
Packit |
95306a |
if (exists $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year});
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# First week contains either Jan 4 (default) or Jan 1
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y,$m,$d) = ($year,1,4);
|
|
Packit |
95306a |
$d = 1 if ($jan1week1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Go back to the previous (counting today) $firstday
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $dow = $self->day_of_week([$y,$m,$d]);
|
|
Packit |
95306a |
if ($dow != $firstday) {
|
|
Packit |
95306a |
$firstday = 0 if ($firstday == 7);
|
|
Packit |
95306a |
$d -= ($dow-$firstday);
|
|
Packit |
95306a |
if ($d<1) {
|
|
Packit |
95306a |
$y--;
|
|
Packit |
95306a |
$m = 12;
|
|
Packit |
95306a |
$d += 31;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year} = [ $y,$m,$d ];
|
|
Packit |
95306a |
return [$y,$m,$d];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub weeks_in_year {
|
|
Packit |
95306a |
my($self,$y) = @_;
|
|
Packit |
95306a |
my $firstday = $self->_config('firstday');
|
|
Packit |
95306a |
return $self->_weeks_in_year($firstday,$y);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _weeks_in_year {
|
|
Packit |
95306a |
my($self,$firstday,$y) = @_;
|
|
Packit |
95306a |
my $jan1week1 = $self->_config('jan1week1');
|
|
Packit |
95306a |
return $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y}
|
|
Packit |
95306a |
if (exists $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y});
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Get the week1 day1 dates for this year and the next one.
|
|
Packit |
95306a |
my ($y1,$m1,$d1) = @{ $self->_week1_day1($firstday,$y) };
|
|
Packit |
95306a |
my ($y2,$m2,$d2) = @{ $self->_week1_day1($firstday,$y+1) };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Calculate the number of days between them.
|
|
Packit |
95306a |
my $diy = $self->days_in_year($y);
|
|
Packit |
95306a |
if ($y1 < $y) {
|
|
Packit |
95306a |
$diy += (32-$d1);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$diy -= ($d1-1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
if ($y2 < $y+1) {
|
|
Packit |
95306a |
$diy -= (32-$d2);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$diy += ($d2-1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$diy = $diy/7;
|
|
Packit |
95306a |
$$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y} = $diy;
|
|
Packit |
95306a |
return $diy;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub week_of_year {
|
|
Packit |
95306a |
my($self,@args) = @_;
|
|
Packit |
95306a |
my $firstday = $self->_config('firstday');
|
|
Packit |
95306a |
return $self->_week_of_year($firstday,@args);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _week_of_year {
|
|
Packit |
95306a |
my($self,$firstday,@args) = @_;
|
|
Packit |
95306a |
my $jan1week1 = $self->_config('jan1week1');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($#args == 1) {
|
|
Packit |
95306a |
# (y,m,d) = week_of_year(y,w)
|
|
Packit |
95306a |
my($year,$w) = @args;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w}
|
|
Packit |
95306a |
if (exists $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w});
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $ymd = $self->_week1_day1($firstday,$year);
|
|
Packit |
95306a |
$ymd = $self->calc_date_days($ymd,($w-1)*7) if ($w > 1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w} = $ymd;
|
|
Packit |
95306a |
return $ymd;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# (y,w) = week_of_year([y,m,d])
|
|
Packit |
95306a |
my($y,$m,$d) = @{ $args[0] };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Get the first day of the first week. If the date is before that,
|
|
Packit |
95306a |
# it's the last week of last year.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y0,$m0,$d0) = @{ $self->_week1_day1($firstday,$y) };
|
|
Packit |
95306a |
if ($y0==$y && $m==1 && $d<$d0) {
|
|
Packit |
95306a |
return($y-1,$self->_weeks_in_year($firstday,$y-1));
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Otherwise, we'll figure out how many days are between the two and
|
|
Packit |
95306a |
# divide by 7 to figure out how many weeks in it is.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $n = $self->day_of_year([$y,$m,$d]);
|
|
Packit |
95306a |
if ($y0<$y) {
|
|
Packit |
95306a |
$n += (32-$d0);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$n -= ($d0-1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
my $w = 1+int(($n-1)/7);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Make sure we're not into the first week of next year.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($w>$self->_weeks_in_year($firstday,$y)) {
|
|
Packit |
95306a |
return($y+1,1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return($y,$w);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# CALC METHODS
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub calc_date_date {
|
|
Packit |
95306a |
my($self,$date0,$date1) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Order them so date0 < date1
|
|
Packit |
95306a |
# If $minus = 1, then the delta is negative
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $minus = 0;
|
|
Packit |
95306a |
my $cmp = $self->cmp($date0,$date1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($cmp == 0) {
|
|
Packit |
95306a |
return [0,0,0];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($cmp == 1) {
|
|
Packit |
95306a |
$minus = 1;
|
|
Packit |
95306a |
my $tmp = $date1;
|
|
Packit |
95306a |
$date1 = $date0;
|
|
Packit |
95306a |
$date0 = $tmp;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y0,$m0,$d0,$h0,$mn0,$s0) = @$date0;
|
|
Packit |
95306a |
my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $sameday = ($y0 == $y1 && $m0 == $m1 && $d0 == $d1 ? 1 : 0);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Handle the various cases.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($dh,$dm,$ds);
|
|
Packit |
95306a |
if ($sameday) {
|
|
Packit |
95306a |
($dh,$dm,$ds) = @{ $self->_calc_hms_hms([$h0,$mn0,$s0],[$h1,$mn1,$s1]) };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
# y0-m0-d0 h0:mn0:s0 -> y0-m0-d0 24:00:00
|
|
Packit |
95306a |
# y1-m1-d1 h1:mn1:s1 -> y1-m1-d1 00:00:00
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $t1 = $self->_calc_hms_hms([$h0,$mn0,$s0],[24,0,0]);
|
|
Packit |
95306a |
my $t2 = $self->_calc_hms_hms([0,0,0],[$h1,$mn1,$s1]);
|
|
Packit |
95306a |
($dh,$dm,$ds) = @{ $self->calc_time_time($t1,$t2) };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $dd0 = $self->days_since_1BC([$y0,$m0,$d0]);
|
|
Packit |
95306a |
$dd0++;
|
|
Packit |
95306a |
my $dd1 = $self->days_since_1BC([$y1,$m1,$d1]);
|
|
Packit |
95306a |
$dh += ($dd1-$dd0)*24;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($minus) {
|
|
Packit |
95306a |
$dh *= -1;
|
|
Packit |
95306a |
$dm *= -1;
|
|
Packit |
95306a |
$ds *= -1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return [$dh,$dm,$ds];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub calc_date_days {
|
|
Packit |
95306a |
my($self,$date,$n,$subtract) = @_;
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s) = @$date;
|
|
Packit |
95306a |
my($ymdonly) = (defined $h ? 0 : 1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$n *= -1 if ($subtract);
|
|
Packit |
95306a |
my $d1bc = $self->days_since_1BC([$y,$m,$d]);
|
|
Packit |
95306a |
$d1bc += $n;
|
|
Packit |
95306a |
my $ymd = $self->days_since_1BC($d1bc);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($ymdonly) {
|
|
Packit |
95306a |
return $ymd;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return [@$ymd,$h*1,$mn*1,$s*1];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub calc_date_delta {
|
|
Packit |
95306a |
my($self,$date,$delta,$subtract) = @_;
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s,$dy,$dm,$dw,$dd,$dh,$dmn,$ds) = (@$date,@$delta);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
($y,$m,$d) = @{ $self->_calc_date_ymwd([$y,$m,$d], [$dy,$dm,$dw,$dd],
|
|
Packit |
95306a |
$subtract) };
|
|
Packit |
95306a |
return $self->calc_date_time([$y,$m,$d,$h,$mn,$s],[$dh,$dmn,$ds],$subtract);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub calc_date_time {
|
|
Packit |
95306a |
my($self,$date,$time,$subtract) = @_;
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s,$dh,$dmn,$ds) = (@$date,@$time);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($ds > 59 || $ds < -59) {
|
|
Packit |
95306a |
$dmn += int($ds/60);
|
|
Packit |
95306a |
$ds = $ds % 60;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
if ($dmn > 59 || $dmn < -59) {
|
|
Packit |
95306a |
$dh += int($dmn/60);
|
|
Packit |
95306a |
$dmn = $dmn % 60;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
my $dd = 0;
|
|
Packit |
95306a |
if ($dh > 23 || $dh < -23) {
|
|
Packit |
95306a |
$dd = int($dh/24);
|
|
Packit |
95306a |
$dh = $dh % 24;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Handle subtraction
|
|
Packit |
95306a |
if ($subtract) {
|
|
Packit |
95306a |
$dh *= -1;
|
|
Packit |
95306a |
$dmn *= -1;
|
|
Packit |
95306a |
$ds *= -1;
|
|
Packit |
95306a |
$dd *= -1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($dd == 0) {
|
|
Packit |
95306a |
$y *= 1;
|
|
Packit |
95306a |
$m *= 1;
|
|
Packit |
95306a |
$d *= 1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
($y,$m,$d) = @{ $self->calc_date_days([$y,$m,$d],$dd) };
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_mod_add(60,$ds,\$s,\$mn);
|
|
Packit |
95306a |
$self->_mod_add(60,$dmn,\$mn,\$h);
|
|
Packit |
95306a |
$self->_mod_add(24,$dh,\$h,\$d);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($d<1) {
|
|
Packit |
95306a |
$m--;
|
|
Packit |
95306a |
$y--, $m=12 if ($m<1);
|
|
Packit |
95306a |
my $day_in_mon = $self->days_in_month($y,$m);
|
|
Packit |
95306a |
$d += $day_in_mon;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
my $day_in_mon = $self->days_in_month($y,$m);
|
|
Packit |
95306a |
if ($d>$day_in_mon) {
|
|
Packit |
95306a |
$d -= $day_in_mon;
|
|
Packit |
95306a |
$m++;
|
|
Packit |
95306a |
$y++, $m=1 if ($m>12);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return [$y,$m,$d,$h,$mn,$s];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _calc_date_time_strings {
|
|
Packit |
95306a |
my($self,$date,$time,$subtract) = @_;
|
|
Packit |
95306a |
my @date = @{ $self->split('date',$date) };
|
|
Packit |
95306a |
return '' if (! @date);
|
|
Packit |
95306a |
my @time = @{ $self->split('time',$time) };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my @date2 = @{ $self->calc_date_time(\@date,\@time,$subtract) };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return $self->join('date',\@date2);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _calc_date_ymwd {
|
|
Packit |
95306a |
my($self,$date,$ymwd,$subtract) = @_;
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s) = @$date;
|
|
Packit |
95306a |
my($dy,$dm,$dw,$dd) = @$ymwd;
|
|
Packit |
95306a |
my($ymdonly) = (defined $h ? 0 : 1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$dd += $dw*7;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($subtract) {
|
|
Packit |
95306a |
$y -= $dy;
|
|
Packit |
95306a |
$self->_mod_add(-12,-1*$dm,\$m,\$y);
|
|
Packit |
95306a |
$dd *= -1;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$y += $dy;
|
|
Packit |
95306a |
$self->_mod_add(-12,$dm,\$m,\$y);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $dim = $self->days_in_month($y,$m);
|
|
Packit |
95306a |
$d = $dim if ($d > $dim);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $ymd;
|
|
Packit |
95306a |
if ($dd == 0) {
|
|
Packit |
95306a |
$ymd = [$y,$m,$d];
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$ymd = $self->calc_date_days([$y,$m,$d],$dd);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($ymdonly) {
|
|
Packit |
95306a |
return $ymd;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return [@$ymd,$h,$mn,$s];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _calc_hms_hms {
|
|
Packit |
95306a |
my($self,$hms0,$hms1) = @_;
|
|
Packit |
95306a |
my($h0,$m0,$s0,$h1,$m1,$s1) = (@$hms0,@$hms1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($s) = ($h1-$h0)*3600 + ($m1-$m0)*60 + $s1-$s0;
|
|
Packit |
95306a |
my($m) = int($s/60);
|
|
Packit |
95306a |
$s -= $m*60;
|
|
Packit |
95306a |
my($h) = int($m/60);
|
|
Packit |
95306a |
$m -= $h*60;
|
|
Packit |
95306a |
return [$h,$m,$s];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub calc_time_time {
|
|
Packit |
95306a |
my($self,$time0,$time1,$subtract) = @_;
|
|
Packit |
95306a |
my($h0,$m0,$s0,$h1,$m1,$s1) = (@$time0,@$time1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($subtract) {
|
|
Packit |
95306a |
$h1 *= -1;
|
|
Packit |
95306a |
$m1 *= -1;
|
|
Packit |
95306a |
$s1 *= -1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
my($s) = (($h0+$h1)*60 + ($m0+$m1))*60 + $s0+$s1;
|
|
Packit |
95306a |
my($m) = int($s/60);
|
|
Packit |
95306a |
$s -= $m*60;
|
|
Packit |
95306a |
my($h) = int($m/60);
|
|
Packit |
95306a |
$m -= $h*60;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return [$h,$m,$s];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Returns -1 if date0 is before date1, 0 if date0 is the same as date1, and
|
|
Packit |
95306a |
# 1 if date0 is after date1.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub cmp {
|
|
Packit |
95306a |
my($self,$date0,$date1) = @_;
|
|
Packit |
95306a |
return ($$date0[0] <=> $$date1[0] ||
|
|
Packit |
95306a |
$$date0[1] <=> $$date1[1] ||
|
|
Packit |
95306a |
$$date0[2] <=> $$date1[2] ||
|
|
Packit |
95306a |
$$date0[3] <=> $$date1[3] ||
|
|
Packit |
95306a |
$$date0[4] <=> $$date1[4] ||
|
|
Packit |
95306a |
$$date0[5] <=> $$date1[5]);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# This determines the OS.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _os {
|
|
Packit |
95306a |
my($self) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $os = '';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($^O =~ /MSWin32/io ||
|
|
Packit |
95306a |
$^O =~ /Windows_95/io ||
|
|
Packit |
95306a |
$^O =~ /Windows_NT/io
|
|
Packit |
95306a |
) {
|
|
Packit |
95306a |
$os = 'Windows';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($^O =~ /MacOS/io ||
|
|
Packit |
95306a |
$^O =~ /MPE/io ||
|
|
Packit |
95306a |
$^O =~ /OS2/io ||
|
|
Packit |
95306a |
$^O =~ /NetWare/io
|
|
Packit |
95306a |
) {
|
|
Packit |
95306a |
$os = 'Other';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($^O =~ /VMS/io) {
|
|
Packit |
95306a |
$os = 'VMS';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$os = 'Unix';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return $os;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Config variable functions
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $self->config(SECT);
|
|
Packit |
95306a |
# Creates a new section (if it doesn't already exist).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# $self->config(SECT,'_vars');
|
|
Packit |
95306a |
# Returns a list of (VAR VAL VAR VAL ...)
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# $self->config(SECT,VAR,VAL);
|
|
Packit |
95306a |
# Adds (VAR,VAL) to the list.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _section {
|
|
Packit |
95306a |
my($self,$sect,$var,$val) = @_;
|
|
Packit |
95306a |
$sect = lc($sect);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# $self->_section(SECT) creates a new section
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! defined $var &&
|
|
Packit |
95306a |
! exists $$self{'data'}{'sections'}{$sect}) {
|
|
Packit |
95306a |
if ($sect eq 'conf') {
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{$sect} = {};
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{$sect} = [];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return '';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($var eq '_vars') {
|
|
Packit |
95306a |
return @{ $$self{'data'}{'sections'}{$sect} };
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
push @{ $$self{'data'}{'sections'}{$sect} },($var,$val);
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This sets a config variable. It also performs all side effects from
|
|
Packit |
95306a |
# setting that variable.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _config_var_base {
|
|
Packit |
95306a |
my($self,$var,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($var eq 'defaults') {
|
|
Packit |
95306a |
# Reset the configuration if desired.
|
|
Packit |
95306a |
$self->_init_config(1);
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'eraseholidays') {
|
|
Packit |
95306a |
$self->_init_holidays(1);
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'eraseevents') {
|
|
Packit |
95306a |
$self->_init_events(1);
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'configfile') {
|
|
Packit |
95306a |
$self->_config_file($val);
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'encoding') {
|
|
Packit |
95306a |
my $err = $self->_config_var_encoding($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'language') {
|
|
Packit |
95306a |
my $err = $self->_language($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
$err = $self->_config_var_encoding();
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'yytoyyyy') {
|
|
Packit |
95306a |
$val = lc($val);
|
|
Packit |
95306a |
if ($val ne 'c' &&
|
|
Packit |
95306a |
$val !~ /^c\d\d$/o &&
|
|
Packit |
95306a |
$val !~ /^c\d\d\d\d$/o &&
|
|
Packit |
95306a |
$val !~ /^\d+$/o) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: YYtoYYYY: $val\n";
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'workweekbeg') {
|
|
Packit |
95306a |
my $err = $self->_config_var_workweekbeg($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'workweekend') {
|
|
Packit |
95306a |
my $err = $self->_config_var_workweekend($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'workday24hr') {
|
|
Packit |
95306a |
my $err = $self->_config_var_workday24hr($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'workdaybeg') {
|
|
Packit |
95306a |
my $err = $self->_config_var_workdaybegend(\$val,'WorkDayBeg');
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'workdayend') {
|
|
Packit |
95306a |
my $err = $self->_config_var_workdaybegend(\$val,'WorkDayEnd');
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'firstday') {
|
|
Packit |
95306a |
my $err = $self->_config_var_firstday($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'tz' ||
|
|
Packit |
95306a |
$var eq 'forcedate' ||
|
|
Packit |
95306a |
$var eq 'setdate') {
|
|
Packit |
95306a |
# These can only be used if the Date::Manip::TZ module has been loaded
|
|
Packit |
95306a |
warn "ERROR: [config_var] $var config variable requires TZ module\n";
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'recurrange') {
|
|
Packit |
95306a |
my $err = $self->_config_var_recurrange($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'defaulttime') {
|
|
Packit |
95306a |
my $err = $self->_config_var_defaulttime($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'periodtimesep') {
|
|
Packit |
95306a |
# We have to redo the time regexp
|
|
Packit |
95306a |
delete $$self{'data'}{'rx'}{'time'};
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'format_mmmyyyy') {
|
|
Packit |
95306a |
my $err = $self->_config_var_format_mmmyyyy($val);
|
|
Packit |
95306a |
return if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($var eq 'dateformat' ||
|
|
Packit |
95306a |
$var eq 'jan1week1' ||
|
|
Packit |
95306a |
$var eq 'printable' ||
|
|
Packit |
95306a |
$var eq 'tomorrowfirst') {
|
|
Packit |
95306a |
# do nothing
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid config variable: $var\n";
|
|
Packit |
95306a |
return '';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'}{$var} = $val;
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Specific config variable functions
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_encoding {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $val) {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ @{ $$self{'data'}{'enc'} } ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($val =~ /^(.*),(.*)$/o) {
|
|
Packit |
95306a |
my($in,$out) = ($1,$2);
|
|
Packit |
95306a |
if ($in) {
|
|
Packit |
95306a |
my $o = find_encoding($in);
|
|
Packit |
95306a |
if (! $o) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: Encoding: $in\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
if ($out) {
|
|
Packit |
95306a |
my $o = find_encoding($out);
|
|
Packit |
95306a |
if (! $o) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: Encoding: $out\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($in && $out) {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ $in ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = $out;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($in) {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ $in ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($out) {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ @{ $$self{'data'}{'enc'} } ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = $out;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ @{ $$self{'data'}{'enc'} } ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
my $o = find_encoding($val);
|
|
Packit |
95306a |
if (! $o) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: Encoding: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ $val ];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_out'} = $val;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! @{ $$self{'data'}{'calc'}{'enc_in'} }) {
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'enc_in'} = [ qw(utf-8 perl) ];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_recurrange {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$val = lc($val);
|
|
Packit |
95306a |
if ($val =~ /^(none|year|month|week|day|all)$/o) {
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: RecurRange: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_workweekbeg {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $self->_is_int($val,1,7)) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
if ($val >= $self->_config('workweekend')) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] WorkWeekBeg must be before WorkWeekEnd\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_calc_workweek($val,'');
|
|
Packit |
95306a |
$self->_init_business_length();
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_workweekend {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $self->_is_int($val,1,7)) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
if ($val <= $self->_config('workweekbeg')) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] WorkWeekEnd must be after WorkWeekBeg\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_calc_workweek('',$val);
|
|
Packit |
95306a |
$self->_init_business_length();
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_workday24hr {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($val) {
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'}{'workdaybeg'} = '00:00:00';
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'}{'workdayend'} = '24:00:00';
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'workdaybeg'} = [0,0,0];
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{'workdayend'} = [24,0,0];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_calc_bdlength();
|
|
Packit |
95306a |
$self->_init_business_length();
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_workdaybegend {
|
|
Packit |
95306a |
my($self,$val,$conf) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Must be a valid time. Entered as H, H:M, or H:M:S
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $tmp = $self->split('hms',$$val);
|
|
Packit |
95306a |
if (! defined $tmp) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: $conf: $$val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$$self{'data'}{'calc'}{lc($conf)} = $tmp;
|
|
Packit |
95306a |
$$val = $self->join('hms',$tmp);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# workdaybeg < workdayend
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my @beg = @{ $$self{'data'}{'calc'}{'workdaybeg'} };
|
|
Packit |
95306a |
my @end = @{ $$self{'data'}{'calc'}{'workdayend'} };
|
|
Packit |
95306a |
my $beg = $beg[0]*3600 + $beg[1]*60 + $beg[2];
|
|
Packit |
95306a |
my $end = $end[0]*3600 + $end[1]*60 + $end[2];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($beg > $end) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] WorkDayBeg not before WorkDayEnd\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Calculate bdlength
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'}{'workday24hr'} = 0;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$self->_calc_bdlength();
|
|
Packit |
95306a |
$self->_init_business_length();
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_firstday {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $self->_is_int($val,1,7)) {
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: FirstDay: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_defaulttime {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (lc($val) eq 'midnight' ||
|
|
Packit |
95306a |
lc($val) eq 'curr') {
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: DefaultTime: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _config_var_format_mmmyyyy {
|
|
Packit |
95306a |
my($self,$val) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (lc($val) eq 'first' ||
|
|
Packit |
95306a |
lc($val) eq 'last' ||
|
|
Packit |
95306a |
lc($val) eq '') {
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
warn "ERROR: [config_var] invalid: Format_MMMYYYY: $val\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Language functions
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This reads in a langauge module and sets regular expressions
|
|
Packit |
95306a |
# and word lists based on it.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
no strict 'refs';
|
|
Packit |
95306a |
sub _language {
|
|
Packit |
95306a |
my($self,$lang) = @_;
|
|
Packit |
95306a |
$lang = lc($lang);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! exists $Date::Manip::Lang::index::Lang{$lang}) {
|
|
Packit |
95306a |
warn "ERROR: [language] invalid: $lang\n";
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0 if (exists $$self{'data'}{'sections'}{'conf'} &&
|
|
Packit |
95306a |
$$self{'data'}{'sections'}{'conf'} eq $lang);
|
|
Packit |
95306a |
$self->_init_language(1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $mod = $Date::Manip::Lang::index::Lang{$lang};
|
|
Packit |
95306a |
eval "require Date::Manip::Lang::${mod}";
|
|
Packit |
95306a |
if ($@) {
|
|
Packit |
95306a |
die "ERROR: failed to load Date::Manip::Lang::${mod}: $@\n";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
no warnings 'once';
|
|
Packit |
95306a |
$$self{'data'}{'lang'} = ${ "Date::Manip::Lang::${mod}::Language" };
|
|
Packit |
95306a |
$$self{'data'}{'enc'} = [ @{ "Date::Manip::Lang::${mod}::Encodings" } ];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Common words
|
|
Packit |
95306a |
$self->_rx_wordlist('at');
|
|
Packit |
95306a |
$self->_rx_wordlist('each');
|
|
Packit |
95306a |
$self->_rx_wordlist('last');
|
|
Packit |
95306a |
$self->_rx_wordlist('of');
|
|
Packit |
95306a |
$self->_rx_wordlist('on');
|
|
Packit |
95306a |
$self->_rx_wordlists('when');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Next/prev
|
|
Packit |
95306a |
$self->_rx_wordlists('nextprev');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Field names (years, year, yr, ...)
|
|
Packit |
95306a |
$self->_rx_wordlists('fields');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Numbers (first, 1st)
|
|
Packit |
95306a |
$self->_rx_wordlists('nth');
|
|
Packit |
95306a |
$self->_rx_wordlists('nth','nth_dom',31); # 1-31
|
|
Packit |
95306a |
$self->_rx_wordlists('nth','nth_wom',5); # 1-5
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Calendar names (Mon, Tue and Jan, Feb)
|
|
Packit |
95306a |
$self->_rx_wordlists('day_abb');
|
|
Packit |
95306a |
$self->_rx_wordlists('day_char');
|
|
Packit |
95306a |
$self->_rx_wordlists('day_name');
|
|
Packit |
95306a |
$self->_rx_wordlists('month_abb');
|
|
Packit |
95306a |
$self->_rx_wordlists('month_name');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# H:M:S separators
|
|
Packit |
95306a |
$self->_rx_simple('sephm');
|
|
Packit |
95306a |
$self->_rx_simple('sepms');
|
|
Packit |
95306a |
$self->_rx_simple('sepfr');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Time replacement strings
|
|
Packit |
95306a |
$self->_rx_replace('times');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Some offset strings
|
|
Packit |
95306a |
$self->_rx_replace('offset_date');
|
|
Packit |
95306a |
$self->_rx_replace('offset_time');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# AM/PM strings
|
|
Packit |
95306a |
$self->_rx_wordlists('ampm');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Business/non-business mode
|
|
Packit |
95306a |
$self->_rx_wordlists('mode');
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return 0;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
use strict 'refs';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This takes a string or strings from the language file which is a
|
|
Packit |
95306a |
# regular expression and copies it to the regular expression cache.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If the language file contains a list of strings, a list of strings
|
|
Packit |
95306a |
# is stored in the regexp cache.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _rx_simple {
|
|
Packit |
95306a |
my($self,$ele) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (exists $$self{'data'}{'lang'}{$ele}) {
|
|
Packit |
95306a |
if (ref($$self{'data'}{'lang'}{$ele})) {
|
|
Packit |
95306a |
@{ $$self{'data'}{'rx'}{$ele} } = @{ $$self{'data'}{'lang'}{$ele} };
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele} = $$self{'data'}{'lang'}{$ele};
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele} = undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# We need to quote strings that will be used in regexps, but we don't
|
|
Packit |
95306a |
# want to quote UTF-8 characters.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _qe_quote {
|
|
Packit |
95306a |
my($string) = @_;
|
|
Packit |
95306a |
$string =~ s/([-.+*?])/\\$1/g;
|
|
Packit |
95306a |
return $string;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This takes a list of words and creates a simple regexp which matches
|
|
Packit |
95306a |
# any of them.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# The first word in the list is the default way to express the word using
|
|
Packit |
95306a |
# a normal ASCII character set.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# The second word in the list is the default way to express the word using
|
|
Packit |
95306a |
# a locale character set. If it isn't defined, it defaults to the first word.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _rx_wordlist {
|
|
Packit |
95306a |
my($self,$ele) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (exists $$self{'data'}{'lang'}{$ele}) {
|
|
Packit |
95306a |
my @tmp = @{ $$self{'data'}{'lang'}{$ele} };
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'wordlist'}{$ele} = $tmp[0];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my @tmp2;
|
|
Packit |
95306a |
foreach my $tmp (@tmp) {
|
|
Packit |
95306a |
push(@tmp2,_qe_quote($tmp)) if ($tmp);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
@tmp2 = sort _sortByLength(@tmp2);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele} = join('|',@tmp2);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele} = undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
no strict 'vars';
|
|
Packit |
95306a |
sub _sortByLength {
|
|
Packit |
95306a |
return (length $b <=> length $a);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
use strict 'vars';
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This takes a hash of the form:
|
|
Packit |
95306a |
# word => string
|
|
Packit |
95306a |
# and creates a regular expression to match word (which must be surrounded
|
|
Packit |
95306a |
# by word boundaries).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _rx_replace {
|
|
Packit |
95306a |
my($self,$ele) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! exists $$self{'data'}{'lang'}{$ele}) {
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele} = [];
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my(@key) = keys %{ $$self{'data'}{'lang'}{$ele} };
|
|
Packit |
95306a |
my $i = 1;
|
|
Packit |
95306a |
foreach my $key (sort(@key)) {
|
|
Packit |
95306a |
my $val = $$self{'data'}{'lang'}{$ele}{$key};
|
|
Packit |
95306a |
my $k = _qe_quote($key);
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele}[$i++] = qr/(?:^|\b)($k)(?:\b|$)/i;
|
|
Packit |
95306a |
$$self{'data'}{'wordmatch'}{$ele}{lc($key)} = $val;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
@key = sort _sortByLength(@key);
|
|
Packit |
95306a |
@key = map { _qe_quote($_) } @key;
|
|
Packit |
95306a |
my $rx = join('|',@key);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$ele}[0] = qr/(?:^|\b)(?:$rx)(?:\b|$)/i;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This takes a list of values, each of which can be expressed in multiple
|
|
Packit |
95306a |
# ways, and gets a regular expression which matches any of them, a default
|
|
Packit |
95306a |
# way to express each value, and a hash which matches a matched string to
|
|
Packit |
95306a |
# a value (the value is 1..N where N is the number of values).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _rx_wordlists {
|
|
Packit |
95306a |
my($self,$ele,$subset,$max) = @_;
|
|
Packit |
95306a |
$subset = $ele if (! $subset);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (exists $$self{'data'}{'lang'}{$ele}) {
|
|
Packit |
95306a |
my @vallist = @{ $$self{'data'}{'lang'}{$ele} };
|
|
Packit |
95306a |
$max = $#vallist+1 if (! $max || $max > $#vallist+1);
|
|
Packit |
95306a |
my (@all);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
for (my $i=1; $i<=$max; $i++) {
|
|
Packit |
95306a |
my @tmp = @{ $$self{'data'}{'lang'}{$ele}[$i-1] };
|
|
Packit |
95306a |
$$self{'data'}{'wordlist'}{$subset}[$i-1] = $tmp[0];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my @str;
|
|
Packit |
95306a |
foreach my $str (@tmp) {
|
|
Packit |
95306a |
next if (! $str);
|
|
Packit |
95306a |
$$self{'data'}{'wordmatch'}{$subset}{lc($str)} = $i;
|
|
Packit |
95306a |
push(@str,_qe_quote($str));
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
push(@all,@str);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
@str = sort _sortByLength(@str);
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$subset}[$i] = join('|',@str);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
@all = sort _sortByLength(@all);
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$subset}[0] = join('|',@all);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$$self{'data'}{'rx'}{$subset} = undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Year functions
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# $self->_method(METHOD) use METHOD as the method for YY->YYYY
|
|
Packit |
95306a |
# conversions
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# YEAR = _fix_year(YR) converts a 2-digit to 4-digit year
|
|
Packit |
95306a |
# _fix_year is in TZ_Base
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _method {
|
|
Packit |
95306a |
my($self,$method) = @_;
|
|
Packit |
95306a |
$self->_config('yytoyyyy',$method);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# $self->_mod_add($N,$add,\$val,\$rem);
|
|
Packit |
95306a |
# This calculates $val=$val+$add and forces $val to be in a certain
|
|
Packit |
95306a |
# range. This is useful for adding numbers for which only a certain
|
|
Packit |
95306a |
# range is allowed (for example, minutes can be between 0 and 59 or
|
|
Packit |
95306a |
# months can be between 1 and 12). The absolute value of $N determines
|
|
Packit |
95306a |
# the range and the sign of $N determines whether the range is 0 to N-1
|
|
Packit |
95306a |
# (if N>0) or 1 to N (N<0). $rem is adjusted to force $val into the
|
|
Packit |
95306a |
# appropriate range.
|
|
Packit |
95306a |
# Example:
|
|
Packit |
95306a |
# To add 2 hours together (with the excess returned in days) use:
|
|
Packit |
95306a |
# $self->_mod_add(-24,$h1,\$h,\$day);
|
|
Packit |
95306a |
# To add 2 minutes together (with the excess returned in hours):
|
|
Packit |
95306a |
# $self->_mod_add(60,$mn1,\$mn,\$hr);
|
|
Packit |
95306a |
sub _mod_add {
|
|
Packit |
95306a |
my($self,$N,$add,$val,$rem)=@_;
|
|
Packit |
95306a |
return if ($N==0);
|
|
Packit |
95306a |
$$val+=$add;
|
|
Packit |
95306a |
if ($N<0) {
|
|
Packit |
95306a |
# 1 to N
|
|
Packit |
95306a |
$N = -$N;
|
|
Packit |
95306a |
if ($$val>$N) {
|
|
Packit |
95306a |
$$rem+= int(($$val-1)/$N);
|
|
Packit |
95306a |
$$val = ($$val-1)%$N +1;
|
|
Packit |
95306a |
} elsif ($$val<1) {
|
|
Packit |
95306a |
$$rem-= int(-$$val/$N)+1;
|
|
Packit |
95306a |
$$val = $N-(-$$val % $N);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
# 0 to N-1
|
|
Packit |
95306a |
if ($$val>($N-1)) {
|
|
Packit |
95306a |
$$rem+= int($$val/$N);
|
|
Packit |
95306a |
$$val = $$val%$N;
|
|
Packit |
95306a |
} elsif ($$val<0) {
|
|
Packit |
95306a |
$$rem-= int(-($$val+1)/$N)+1;
|
|
Packit |
95306a |
$$val = ($N-1)-(-($$val+1)%$N);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $flag = $self->_is_int($string [,$low, $high]);
|
|
Packit |
95306a |
# Returns 1 if $string is a valid integer, 0 otherwise. If $low is
|
|
Packit |
95306a |
# entered, $string must be >= $low. If $high is entered, $string must
|
|
Packit |
95306a |
# be <= $high. It is valid to check only one of the bounds.
|
|
Packit |
95306a |
sub _is_int {
|
|
Packit |
95306a |
my($self,$N,$low,$high)=@_;
|
|
Packit |
95306a |
return 0 if (! defined $N or
|
|
Packit |
95306a |
$N !~ /^\s*[-+]?\d+\s*$/o or
|
|
Packit |
95306a |
defined $low && $N<$low or
|
|
Packit |
95306a |
defined $high && $N>$high);
|
|
Packit |
95306a |
return 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Split/Join functions
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub split {
|
|
Packit |
95306a |
my($self,$op,$string,$no_normalize) = @_;
|
|
Packit |
95306a |
$no_normalize = 0 if (! $no_normalize);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($op eq 'date') {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d):(\d\d):(\d\d)$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d\d\d)\-(\d\d)\-(\d\d)\-(\d\d):(\d\d):(\d\d)$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/o) {
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s) = ($1+0,$2+0,$3+0,$4+0,$5+0,$6+0);
|
|
Packit |
95306a |
return [$y,$m,$d,$h,$mn,$s];
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'offset') {
|
|
Packit |
95306a |
if ($string =~ /^([-+]?\d\d)(\d\d)(\d\d)$/o ||
|
|
Packit |
95306a |
$string =~ /^([-+]?\d\d)(\d\d)()$/o ||
|
|
Packit |
95306a |
$string =~ /^([-+]?\d\d?):(\d\d?):(\d\d?)$/o ||
|
|
Packit |
95306a |
$string =~ /^([-+]?\d\d?):(\d\d?)()$/o ||
|
|
Packit |
95306a |
$string =~ /^([-+]?\d\d?)()()$/o) {
|
|
Packit |
95306a |
my($err,$h,$mn,$s) = $self->_offset_fields( { 'source' => 'string',
|
|
Packit |
95306a |
'out' => 'list'},
|
|
Packit |
95306a |
[$1,$2,$3]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return [$h,$mn,$s];
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'hms') {
|
|
Packit |
95306a |
if ($string =~ /^(\d\d)(\d\d)(\d\d)$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d)(\d\d)()$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d?):(\d\d):(\d\d)$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d?):(\d\d)()$/o ||
|
|
Packit |
95306a |
$string =~ /^(\d\d?)()()$/o) {
|
|
Packit |
95306a |
my($err,$h,$mn,$s) = $self->_hms_fields( { 'out' => 'list' },[$1,$2,$3]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return [$h,$mn,$s];
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'time') {
|
|
Packit |
95306a |
if ($string =~ /^[-+]?\d+(:[-+]?\d+){0,2}$/o) {
|
|
Packit |
95306a |
my($err,$dh,$dmn,$ds) = $self->_time_fields( { 'nonorm' => $no_normalize,
|
|
Packit |
95306a |
'source' => 'string',
|
|
Packit |
95306a |
'sign' => -1,
|
|
Packit |
95306a |
}, [split(/:/,$string)]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return [$dh,$dmn,$ds];
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return undef;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'delta' || $op eq 'business') {
|
|
Packit |
95306a |
my($err,@delta) = $self->_split_delta($string);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
($err,@delta) = $self->_delta_fields( { 'business' =>
|
|
Packit |
95306a |
($op eq 'business' ? 1 : 0),
|
|
Packit |
95306a |
'nonorm' => $no_normalize,
|
|
Packit |
95306a |
'source' => 'string',
|
|
Packit |
95306a |
'sign' => -1,
|
|
Packit |
95306a |
}, [@delta]);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return [@delta];
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub join{
|
|
Packit |
95306a |
my($self,$op,$data,$no_normalize) = @_;
|
|
Packit |
95306a |
my @data = @$data;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($op eq 'date') {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($err,$y,$m,$d,$h,$mn,$s) = $self->_date_fields(@data);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
my $form = $self->_config('printable');
|
|
Packit |
95306a |
if ($form == 1) {
|
|
Packit |
95306a |
return "$y$m$d$h$mn$s";
|
|
Packit |
95306a |
} elsif ($form == 2) {
|
|
Packit |
95306a |
return "$y-$m-$d-$h:$mn:$s";
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return "$y$m$d$h:$mn:$s";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'offset') {
|
|
Packit |
95306a |
my($err,$h,$mn,$s) = $self->_offset_fields( { 'source' => 'list',
|
|
Packit |
95306a |
'out' => 'string'},
|
|
Packit |
95306a |
[@data]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return "$h:$mn:$s";
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'hms') {
|
|
Packit |
95306a |
my($err,$h,$mn,$s) = $self->_hms_fields( { 'out' => 'string' },[@data]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return "$h:$mn:$s";
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'time') {
|
|
Packit |
95306a |
my($err,$dh,$dmn,$ds) = $self->_time_fields( { 'nonorm' => $no_normalize,
|
|
Packit |
95306a |
'source' => 'list',
|
|
Packit |
95306a |
'sign' => 0,
|
|
Packit |
95306a |
}, [@data]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return "$dh:$dmn:$ds";
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($op eq 'delta' || $op eq 'business') {
|
|
Packit |
95306a |
my ($err,@delta) = $self->_delta_fields( { 'business' =>
|
|
Packit |
95306a |
($op eq 'business' ? 1 : 0),
|
|
Packit |
95306a |
'nonorm' => $no_normalize,
|
|
Packit |
95306a |
'source' => 'list',
|
|
Packit |
95306a |
'sign' => 0,
|
|
Packit |
95306a |
}, [@data]);
|
|
Packit |
95306a |
return undef if ($err);
|
|
Packit |
95306a |
return join(':',@delta);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _split_delta {
|
|
Packit |
95306a |
my($self,$string) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $sign = '[-+]?';
|
|
Packit |
95306a |
my $num = '(?:\d+(?:\.\d*)?|\.\d+)';
|
|
Packit |
95306a |
my $f = "(?:$sign$num)?";
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($string =~ /^$f(:$f){0,6}$/o) {
|
|
Packit |
95306a |
$string =~ s/::/:0:/go;
|
|
Packit |
95306a |
$string =~ s/^:/0:/o;
|
|
Packit |
95306a |
$string =~ s/:$/:0/o;
|
|
Packit |
95306a |
my(@delta) = split(/:/,$string);
|
|
Packit |
95306a |
return(0,@delta);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return(1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $opts = { business => 0/1,
|
|
Packit |
95306a |
# nonorm => 0/1,
|
|
Packit |
95306a |
# source => string, list
|
|
Packit |
95306a |
# sign => 0/1/-1
|
|
Packit |
95306a |
# }
|
|
Packit |
95306a |
# $fields = [Y,M,W,D,H,Mn,S]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# This function formats the fields in a delta.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If the business option is 1, treat it as a business delta.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If the nonorm option is 1, fields are NOT normalized. By
|
|
Packit |
95306a |
# default, they are normalized.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If source is 'string', then the source of the fields is splitting
|
|
Packit |
95306a |
# a delta (so we need to handle carrying the signs). If it's 'list',
|
|
Packit |
95306a |
# then the source is a valid delta, so each field is correctly signed
|
|
Packit |
95306a |
# already.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If the sign option is 1, a sign is added to every field. If the
|
|
Packit |
95306a |
# sign option is -1, all negative fields are signed. If the sign
|
|
Packit |
95306a |
# option is 0, the minimum number of signs (for fields who's sign is
|
|
Packit |
95306a |
# different from the next higher field) will be added.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# It returns ($err,@fields)
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _delta_fields {
|
|
Packit |
95306a |
my($self,$opts,$fields) = @_;
|
|
Packit |
95306a |
my @fields = @$fields;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure that all fields are defined, numerical, and that there
|
|
Packit |
95306a |
# are 7 of them.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f=0 if (! defined($f));
|
|
Packit |
95306a |
return (1) if ($f !~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)$/o);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return (1) if (@fields > 7);
|
|
Packit |
95306a |
while (@fields < 7) {
|
|
Packit |
95306a |
unshift(@fields,0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure each field is the correct sign so that the math will
|
|
Packit |
95306a |
# work correctly. Get rid of all positive signs and leading 0's.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($$opts{'source'} eq 'string') {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# if the source is splitting a delta, not all fields are signed,
|
|
Packit |
95306a |
# so we need to carry the negative signs.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $sign = '+';
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
if ($f =~ /^([-+])/o) {
|
|
Packit |
95306a |
$sign = $1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$f = "$sign$f";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Normalize them. Values will be signed only if they are
|
|
Packit |
95306a |
# negative. Handle fractional values.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $nonorm = $$opts{'nonorm'};
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
if ($f != int($f)) {
|
|
Packit |
95306a |
$nonorm = 0;
|
|
Packit |
95306a |
last;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y,$m,$w,$d,$h,$mn,$s) = @fields;
|
|
Packit |
95306a |
if (! $nonorm) {
|
|
Packit |
95306a |
($y,$m) = $self->_normalize_ym($y,$m) if ($y || $m);
|
|
Packit |
95306a |
($m,$w) = $self->_normalize_mw($m,$w) if (int($m) != $m);
|
|
Packit |
95306a |
if ($$opts{'business'}) {
|
|
Packit |
95306a |
($w,$d) = $self->_normalize_wd($w,$d,1) if (int($w) != $w);
|
|
Packit |
95306a |
($d,$h,$mn,$s) = $self->_normalize_bus_dhms($d,$h,$mn,$s);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
($w,$d) = $self->_normalize_wd($w,$d,0) if ($w || $d);
|
|
Packit |
95306a |
($d,$h) = $self->_normalize_dh($d,$h) if (int($d) != $d);
|
|
Packit |
95306a |
($h,$mn,$s) = $self->_normalize_hms($h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Now make sure that the signs are included as appropriate.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $$opts{'sign'}) {
|
|
Packit |
95306a |
# Minimum number of signs
|
|
Packit |
95306a |
my $sign;
|
|
Packit |
95306a |
if ($y >= 0) {
|
|
Packit |
95306a |
$sign = '+';
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$sign = '-';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
foreach my $f ($m,$w,$d,$h,$mn,$s) {
|
|
Packit |
95306a |
if ($f > 0) {
|
|
Packit |
95306a |
if ($sign eq '-') {
|
|
Packit |
95306a |
$f = "+$f";
|
|
Packit |
95306a |
$sign = '+';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($f < 0) {
|
|
Packit |
95306a |
if ($sign eq '-') {
|
|
Packit |
95306a |
$f *= -1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$sign = '-';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($$opts{'sign'} == 1) {
|
|
Packit |
95306a |
# All fields signed
|
|
Packit |
95306a |
foreach my $f ($y,$m,$w,$d,$h,$mn,$s) {
|
|
Packit |
95306a |
$f = "+$f" if ($f > 0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return (0,$y,$m,$w,$d,$h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $opts = { out => string, list
|
|
Packit |
95306a |
# }
|
|
Packit |
95306a |
# $fields = [H,M,S]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# This function formats the fields in an HMS.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# If the out options is string, it prepares the fields to be joined (i.e.
|
|
Packit |
95306a |
# they are all 2 digits long). Otherwise, they are just numerical values
|
|
Packit |
95306a |
# (not necessarily 2 digits long).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# HH:MN:SS is always between 00:00:00 and 24:00:00.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# It returns ($err,@fields)
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _hms_fields {
|
|
Packit |
95306a |
my($self,$opts,$fields) = @_;
|
|
Packit |
95306a |
my @fields = @$fields;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure that all fields are defined, numerical (with no sign),
|
|
Packit |
95306a |
# and that there are 3 of them.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f=0 if (! $f);
|
|
Packit |
95306a |
return (1) if ($f !~ /^\d+$/o);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return (1) if (@fields > 3);
|
|
Packit |
95306a |
while (@fields < 3) {
|
|
Packit |
95306a |
push(@fields,0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Check validity.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my ($h,$m,$s) = @fields;
|
|
Packit |
95306a |
return (1) if ($h > 24 || $m > 59 || $s > 59 ||
|
|
Packit |
95306a |
($h==24 && ($m > 0 || $s > 0)));
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Format
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($$opts{'out'} eq 'list') {
|
|
Packit |
95306a |
foreach my $f ($h,$m,$s) {
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
foreach my $f ($h,$m,$s) {
|
|
Packit |
95306a |
$f = "0$f" if (length($f)<2);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return (0,$h,$m,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $opts = { nonorm => 0/1,
|
|
Packit |
95306a |
# source => string, list
|
|
Packit |
95306a |
# sign => 0/1/-1
|
|
Packit |
95306a |
# }
|
|
Packit |
95306a |
# $fields = [H,M,S]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# This function formats the fields in an amount of time measured in
|
|
Packit |
95306a |
# hours, minutes, and seconds.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# It is similar to how _delta_fields (above) works.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _time_fields {
|
|
Packit |
95306a |
my($self,$opts,$fields) = @_;
|
|
Packit |
95306a |
my @fields = @$fields;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure that all fields are defined, numerical, and that there
|
|
Packit |
95306a |
# are 3 of them.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f=0 if (! defined($f));
|
|
Packit |
95306a |
return (1) if ($f !~ /^[+-]?\d+$/o);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return (1) if (@fields > 3);
|
|
Packit |
95306a |
while (@fields < 3) {
|
|
Packit |
95306a |
unshift(@fields,0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure each field is the correct sign so that the math will
|
|
Packit |
95306a |
# work correctly. Get rid of all positive signs and leading 0's.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($$opts{'source'} eq 'string') {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# If the source is splitting a string, not all fields are signed,
|
|
Packit |
95306a |
# so we need to carry the negative signs.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $sign = '+';
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
if ($f =~ /^([-+])/o) {
|
|
Packit |
95306a |
$sign = $1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$f = "$sign$f";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Normalize them. Values will be signed only if they are
|
|
Packit |
95306a |
# negative.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($h,$mn,$s) = @fields;
|
|
Packit |
95306a |
unless ($$opts{'nonorm'}) {
|
|
Packit |
95306a |
($h,$mn,$s) = $self->_normalize_hms($h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Now make sure that the signs are included as appropriate.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (! $$opts{'sign'}) {
|
|
Packit |
95306a |
# Minimum number of signs
|
|
Packit |
95306a |
my $sign;
|
|
Packit |
95306a |
if ($h >= 0) {
|
|
Packit |
95306a |
$sign = '+';
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$sign = '-';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
foreach my $f ($mn,$s) {
|
|
Packit |
95306a |
if ($f > 0) {
|
|
Packit |
95306a |
if ($sign eq '-') {
|
|
Packit |
95306a |
$f = "+$f";
|
|
Packit |
95306a |
$sign = '+';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($f < 0) {
|
|
Packit |
95306a |
if ($sign eq '-') {
|
|
Packit |
95306a |
$f *= -1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$sign = '-';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($$opts{'sign'} == 1) {
|
|
Packit |
95306a |
# All fields signed
|
|
Packit |
95306a |
foreach my $f ($h,$mn,$s) {
|
|
Packit |
95306a |
$f = "+$f" if ($f > 0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return (0,$h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $opts = { source => string, list
|
|
Packit |
95306a |
# out => string, list
|
|
Packit |
95306a |
# }
|
|
Packit |
95306a |
# $fields = [H,M,S]
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# This function formats the fields in a timezone offset measured in
|
|
Packit |
95306a |
# hours, minutes, and seconds.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# All offsets must be -23:59:59 <= offset <= 23:59:59 .
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# The data comes from an offset in string or list format, and is
|
|
Packit |
95306a |
# formatted so that it can be used to create a string or list format
|
|
Packit |
95306a |
# output.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _offset_fields {
|
|
Packit |
95306a |
my($self,$opts,$fields) = @_;
|
|
Packit |
95306a |
my @fields = @$fields;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure that all fields are defined, numerical, and that there
|
|
Packit |
95306a |
# are 3 of them.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f=0 if (! defined $f || $f eq '');
|
|
Packit |
95306a |
return (1) if ($f !~ /^[+-]?\d+$/o);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
return (1) if (@fields > 3);
|
|
Packit |
95306a |
while (@fields < 3) {
|
|
Packit |
95306a |
push(@fields,0);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Check validity.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my ($h,$m,$s) = @fields;
|
|
Packit |
95306a |
if ($$opts{'source'} eq 'string') {
|
|
Packit |
95306a |
# Values = -23 59 59 to +23 59 59
|
|
Packit |
95306a |
return (1) if ($h < -23 || $h > 23 ||
|
|
Packit |
95306a |
$m < 0 || $m > 59 ||
|
|
Packit |
95306a |
$s < 0 || $s > 59);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
# Values (-23,-59,-59) to (23,59,59)
|
|
Packit |
95306a |
# Non-zero values must have the same sign
|
|
Packit |
95306a |
if ($h >0) {
|
|
Packit |
95306a |
return (1) if ( $h > 23 ||
|
|
Packit |
95306a |
$m < 0 || $m > 59 ||
|
|
Packit |
95306a |
$s < 0 || $s > 59);
|
|
Packit |
95306a |
} elsif ($h < 0) {
|
|
Packit |
95306a |
return (1) if ($h < -23 ||
|
|
Packit |
95306a |
$m < -59 || $m > 0 ||
|
|
Packit |
95306a |
$s < -59 || $s > 0);
|
|
Packit |
95306a |
} elsif ($m > 0) {
|
|
Packit |
95306a |
return (1) if ( $m > 59 ||
|
|
Packit |
95306a |
$s < 0 || $s > 59);
|
|
Packit |
95306a |
} elsif ($m < 0) {
|
|
Packit |
95306a |
return (1) if ($m < -59 ||
|
|
Packit |
95306a |
$s < -59 || $s > 0);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return (1) if ($s < -59 || $s > 59);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Make sure each field is the correct sign so that the math will
|
|
Packit |
95306a |
# work correctly. Get rid of all positive signs and leading 0's.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($$opts{'source'} eq 'string') {
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# In a string offset, only the first field is signed, so we need
|
|
Packit |
95306a |
# to carry negative signs.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($h =~ /^\-/) {
|
|
Packit |
95306a |
$h *= 1;
|
|
Packit |
95306a |
$m *= -1;
|
|
Packit |
95306a |
$s *= -1;
|
|
Packit |
95306a |
} elsif ($m =~ /^\-/) {
|
|
Packit |
95306a |
$h *= 1;
|
|
Packit |
95306a |
$m *= 1;
|
|
Packit |
95306a |
$s *= -1;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$h *= 1;
|
|
Packit |
95306a |
$m *= 1;
|
|
Packit |
95306a |
$s *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
foreach my $f (@fields) {
|
|
Packit |
95306a |
$f *= 1;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Format them. They're already done for 'list' output.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($$opts{'out'} eq 'string') {
|
|
Packit |
95306a |
my $sign;
|
|
Packit |
95306a |
if ($h<0 || $m<0 || $s<0) {
|
|
Packit |
95306a |
$h = abs($h);
|
|
Packit |
95306a |
$m = abs($m);
|
|
Packit |
95306a |
$s = abs($s);
|
|
Packit |
95306a |
$sign = '-';
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$sign = '+';
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$h = "0$h" if (length($h) < 2);
|
|
Packit |
95306a |
$m = "0$m" if (length($m) < 2);
|
|
Packit |
95306a |
$s = "0$s" if (length($s) < 2);
|
|
Packit |
95306a |
$h = "$sign$h";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return (0,$h,$m,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# ($err,$y,$m,$d,$h,$mn,$s) = $self->_date_fields($y,$m,$d,$h,$mn,$s);
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Makes sure the fields are the right length.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _date_fields {
|
|
Packit |
95306a |
my($self,@fields) = @_;
|
|
Packit |
95306a |
return (1) if (@fields != 6);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y,$m,$d,$h,$mn,$s) = @fields;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$y = "0$y" while (length($y) < 4);
|
|
Packit |
95306a |
$m = "0$m" if (length($m)==1);
|
|
Packit |
95306a |
$d = "0$d" if (length($d)==1);
|
|
Packit |
95306a |
$h = "0$h" if (length($h)==1);
|
|
Packit |
95306a |
$mn = "0$mn" if (length($mn)==1);
|
|
Packit |
95306a |
$s = "0$s" if (length($s)==1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if (wantarray) {
|
|
Packit |
95306a |
return (0,$y,$m,$d,$h,$mn,$s);
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
return "$y$m$d$h:$mn:$s";
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _normalize_ym {
|
|
Packit |
95306a |
my($self,$y,$m) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$m += $y*12;
|
|
Packit |
95306a |
$y = int($m/12);
|
|
Packit |
95306a |
$m -= $y*12;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($y,$m);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This is only used for deltas with fractional months.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _normalize_mw {
|
|
Packit |
95306a |
my($self,$m,$w) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $d = ($m-int($m)) * $$self{'data'}{'len'}{'yrlen'}/12;
|
|
Packit |
95306a |
$w += $d/7;
|
|
Packit |
95306a |
$m = int($m);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($m,$w);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _normalize_bus_dhms {
|
|
Packit |
95306a |
my($self,$d,$h,$mn,$s) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $dl = $$self{'data'}{'len'}{'1'}{'dl'};
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$s += $d*$dl + $h*3600 + $mn*60;
|
|
Packit |
95306a |
$d = int($s/$dl);
|
|
Packit |
95306a |
$s -= $d*$dl;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$mn = int($s/60);
|
|
Packit |
95306a |
$s -= $mn*60;
|
|
Packit |
95306a |
$s = int($s);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$h = int($mn/60);
|
|
Packit |
95306a |
$mn -= $h*60;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($d,$h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _normalize_hms {
|
|
Packit |
95306a |
my($self,$h,$mn,$s) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$s += $h*3600 + $mn*60;
|
|
Packit |
95306a |
$mn = int($s/60);
|
|
Packit |
95306a |
$s -= $mn*60;
|
|
Packit |
95306a |
$s = int($s);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$h = int($mn/60);
|
|
Packit |
95306a |
$mn -= $h*60;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($h,$mn,$s);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# Business deltas only mix week and day if the week has a fractional
|
|
Packit |
95306a |
# part.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _normalize_wd {
|
|
Packit |
95306a |
my($self,$w,$d,$business) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my $weeklen = ($business ? $$self{'data'}{'len'}{'workweek'} : 7);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$d += $w*$weeklen;
|
|
Packit |
95306a |
$w = int($d/$weeklen);
|
|
Packit |
95306a |
$d -= $w*$weeklen;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($w,$d);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# This is only done for non-business days with a fractional part.
|
|
Packit |
95306a |
# part.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _normalize_dh {
|
|
Packit |
95306a |
my($self,$d,$h) = @_;
|
|
Packit |
95306a |
no integer;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$h += $d*24;
|
|
Packit |
95306a |
$d = int($h/24);
|
|
Packit |
95306a |
$h -= $d*24;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($d,$h);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# $self->_delta_convert(FORMAT,DELTA)
|
|
Packit |
95306a |
# This converts delta into the given format. Returns '' if invalid.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _delta_convert {
|
|
Packit |
95306a |
my($self,$format,$delta)=@_;
|
|
Packit |
95306a |
my $fields = $self->split($format,$delta);
|
|
Packit |
95306a |
return undef if (! defined $fields);
|
|
Packit |
95306a |
return $self->join($format,$fields);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Timezone critical dates
|
|
Packit |
95306a |
|
|
Packit |
95306a |
# NOTE: Although I would prefer to stick this routine in the
|
|
Packit |
95306a |
# Date::Manip::TZ module where it would be more appropriate, it must
|
|
Packit |
95306a |
# appear here as it will be used to generate the data that will be
|
|
Packit |
95306a |
# used by the Date::Manip::TZ module.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# This calculates a critical date based on timezone information. The
|
|
Packit |
95306a |
# critical date is the date (usually in the current time) at which
|
|
Packit |
95306a |
# the current timezone period ENDS.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Input is:
|
|
Packit |
95306a |
# $year,$mon,$flag,$num,$dow
|
|
Packit |
95306a |
# This is information from the appropriate Rule line from the
|
|
Packit |
95306a |
# zoneinfo files. These are used to determine the date (Y/M/D)
|
|
Packit |
95306a |
# when the timezone period will end.
|
|
Packit |
95306a |
# $isdst
|
|
Packit |
95306a |
# Whether or not the next timezone period is a Daylight Saving
|
|
Packit |
95306a |
# Time period.
|
|
Packit |
95306a |
# $time,$timetype
|
|
Packit |
95306a |
# The time of day when the change occurs. The timetype can be
|
|
Packit |
95306a |
# 'w' (wallclock time in the current period), 's' (standard
|
|
Packit |
95306a |
# time which will match wallclock time in a non-DST period, or
|
|
Packit |
95306a |
# be off an hour in a DST period), and 'u' (universal time).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Output is:
|
|
Packit |
95306a |
# $endUT, $endLT, $begUT, $begLT
|
|
Packit |
95306a |
# endUT is the actual last second of the current timezone
|
|
Packit |
95306a |
# period. endLT is the same time expressed in local time.
|
|
Packit |
95306a |
# begUT is the start (in UT) of the next time period. Note that
|
|
Packit |
95306a |
# the begUT date is the one which actually corresponds to the
|
|
Packit |
95306a |
# date/time specified in the input. begLT is the time in the new
|
|
Packit |
95306a |
# local time. The endUT/endLT are the time one second earlier.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
sub _critical_date {
|
|
Packit |
95306a |
my($self,$year,$mon,$flag,$num,$dow,
|
|
Packit |
95306a |
$isdst,$time,$timetype,$stdoff,$dstoff) = @_;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Get the predicted Y/M/D
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($y,$m,$d) = ($year+0,$mon+0,1);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($flag eq 'dom') {
|
|
Packit |
95306a |
$d = $num;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($flag eq 'last') {
|
|
Packit |
95306a |
my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
|
|
Packit |
95306a |
$d = $$ymd[2];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($flag eq 'ge') {
|
|
Packit |
95306a |
my $ymd = $self->nth_day_of_week($year,1,$dow,$mon);
|
|
Packit |
95306a |
$d = $$ymd[2];
|
|
Packit |
95306a |
while ($d < $num) {
|
|
Packit |
95306a |
$d += 7;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
} elsif ($flag eq 'le') {
|
|
Packit |
95306a |
my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
|
|
Packit |
95306a |
$d = $$ymd[2];
|
|
Packit |
95306a |
while ($d > $num) {
|
|
Packit |
95306a |
$d -= 7;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Get the predicted time and the date (not yet taking into
|
|
Packit |
95306a |
# account time type).
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($h,$mn,$s) = @{ $self->split('hms',$time) };
|
|
Packit |
95306a |
my $date = [ $y,$m,$d,$h,$mn,$s ];
|
|
Packit |
95306a |
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
# Calculate all the relevant dates.
|
|
Packit |
95306a |
#
|
|
Packit |
95306a |
|
|
Packit |
95306a |
my($endUT,$endLT,$begUT,$begLT,$offset);
|
|
Packit |
95306a |
$stdoff = $self->split('offset',$stdoff);
|
|
Packit |
95306a |
$dstoff = $self->split('offset',$dstoff);
|
|
Packit |
95306a |
|
|
Packit |
95306a |
if ($timetype eq 'w') {
|
|
Packit |
95306a |
$begUT = $self->calc_date_time($date,($isdst ? $stdoff : $dstoff), 1);
|
|
Packit |
95306a |
} elsif ($timetype eq 'u') {
|
|
Packit |
95306a |
$begUT = $date;
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
$begUT = $self->calc_date_time($date,$stdoff, 1);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
$endUT = $self->calc_date_time($begUT,[0,0,-1]);
|
|
Packit |
95306a |
$endLT = $self->calc_date_time($endUT,($isdst ? $stdoff : $dstoff));
|
|
Packit |
95306a |
$begLT = $self->calc_date_time($begUT,($isdst ? $dstoff : $stdoff));
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return ($endUT,$endLT,$begUT,$begLT);
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
###############################################################################
|
|
Packit |
95306a |
# Get a list of strings to try to parse.
|
|
Packit |
95306a |
|
|
Packit |
95306a |
sub _encoding {
|
|
Packit |
95306a |
my($self,$string) = @_;
|
|
Packit |
95306a |
my @ret;
|
|
Packit |
95306a |
|
|
Packit |
95306a |
foreach my $enc (@{ $$self{'data'}{'calc'}{'enc_in'} }) {
|
|
Packit |
95306a |
if (lc($enc) eq 'utf-8') {
|
|
Packit |
95306a |
_utf8_on($string);
|
|
Packit |
95306a |
push(@ret,$string) if is_utf8($string, 1);
|
|
Packit |
95306a |
} elsif (lc($enc) eq 'perl') {
|
|
Packit |
95306a |
push(@ret,encode_utf8($string));
|
|
Packit |
95306a |
} else {
|
|
Packit |
95306a |
my $tmp = $string;
|
|
Packit |
95306a |
_utf8_off($tmp);
|
|
Packit |
95306a |
$tmp = encode_utf8(decode($enc, $tmp));
|
|
Packit |
95306a |
_utf8_on($tmp);
|
|
Packit |
95306a |
push(@ret,$tmp) if is_utf8($tmp, 1);;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
return @ret;
|
|
Packit |
95306a |
}
|
|
Packit |
95306a |
|
|
Packit |
95306a |
1;
|
|
Packit |
95306a |
# Local Variables:
|
|
Packit |
95306a |
# mode: cperl
|
|
Packit |
95306a |
# indent-tabs-mode: nil
|
|
Packit |
95306a |
# cperl-indent-level: 3
|
|
Packit |
95306a |
# cperl-continued-statement-offset: 2
|
|
Packit |
95306a |
# cperl-continued-brace-offset: 0
|
|
Packit |
95306a |
# cperl-brace-offset: 0
|
|
Packit |
95306a |
# cperl-brace-imaginary-offset: 0
|
|
Packit |
95306a |
# cperl-label-offset: 0
|
|
Packit |
95306a |
# End:
|