expvintl/source-engine
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
18051fd0de
source-engine/devtools/shotmaker.pl

956 lines
29 KiB
Perl
Raw Normal View History

1
2020-04-23 00:56:21 +08:00
#!perl
$rdir=shift || &printargs;
$map=shift || &printargs;
$mod=shift || &printargs;
$startdate=shift || &printargs;
$enddate=shift || &printargs;
$dateinc=shift || &printargs;
die "bad date format $startdate" unless $startdate=~s@^(\d\d\d\d)/(\d\d)/(\d\d)$@\1\2\3@;
die "bad date format $enddate" unless $enddate=~s@^(\d\d\d\d)/(\d\d)/(\d\d)$@\1\2\3@;
$jday=MJD($startdate);
$jday1=MJD($enddate);
for($day=$jday;$day<=$jday1;$day+=$dateinc)
{
($y, $m, $d)=DJM($day);
$p4cmd="p4 sync $rdir\\...\@$y/$m/$d:01:00:00 >nul 2>&1";
$hl2cmd="$rdir\\hl2 -game $mod -sw +map $map -makedevshots -dev -width 1024 -height 768";
print "Taking shots for $m/$d/$y\n";
print "$p4cmd\n";
print `$p4cmd`;
print "hl2cmd\n";
print `$hl2cmd`;
}
sub printargs
{
print STDERR "format is SHOTMAKER.PL rootdir mapname mod startdate enddate dateincrement\n";
print STDERR "ex:\nSHOTMAKER u:\\dev\\valvegames\\main\\game ep1_c17_01 episodic 2005/10/01 2005/10/05 7\n";
die;
}
# Toby Thurston --- 12 May 2003
use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @mon @dom);
require Exporter;
@ISA = qw(Exporter);
$VERSION = '0.03';
=head1 NAME
Cal::Date - a simple set of calendar functions for Perl
(yes, yes, I know about L<Date::Calc> and L<Date::Manip> but mine is
simpler, and nicer :-).
=head1 SYNOPSIS
use Cal::Date qw(DJM MJD today);
$date = $ARGV[0] || today();
print "$date --> " . MJD($date) . "\n";
print "Day after -->" . DJM(MJD($date)+1) . "\n";
=head1 DESCRIPTION
A simple compact interface to some simple calendar routines.
Implemented purely in Perl, no need for external C code etc.
=head1 FUNCTIONS
No functions are exported by default.
=cut
@EXPORT = qw();
=pod
The following functions can be exported from the C<Cal::Date> module:
MJD DJM
Easter old_style_Easter orthodox_Easter
ISO_week ISO_day ISO_week_and_day
day_of_year days_to_go
days_in_month
UK_tax_week UK_tax_month
working_days
today now
J2G
v_date r_date
adjust_to_local_time adjust_to_UTC
is_a_date
=cut
@EXPORT_OK = qw(
MJD DJM
Easter old_style_Easter orthodox_Easter
ISO_week ISO_day ISO_week_and_day
day_of_year days_to_go
days_in_month
UK_tax_week UK_tax_month
working_days
today now
J2G
v_date r_date
adjust_to_local_time adjust_to_UTC
is_a_date
);
=pod
You can import all of them at once with
C<use Cal::Date ':all';>
=cut
%EXPORT_TAGS = (all => [@EXPORT_OK]);
=over 4
=item MJD(yyyymmdd) or MJD(y,m,d)
MJD returns the `modified julian day' number for a date.
This is suitably small integer that you can use as the basis of many
date calculations. You can call C<MJD()> with a single 8 digit string
representing a date in compact ISO form, C<yyyymmdd>, or with three integers
representing year, month and day of the month.
Unlike the values returned from the C<gmtime()> etc. functions,
year is the full AD year and month 1 is January. Other than checking
that the arguments are whole numbers, the internal function C<_getYMD>
does no range checking. This is a feature rather than a bug. It means
you can use 0 as a month number to refer to December in the previous year,
and 13 to refer to January in the next year. For example,
assuming C<$month == 12>, the following are equivalent:
MJD(19991301);
MJD(1999, $month+1, 1);
MJD(20000101);
MJD(2000, 1, 1);
You can do the same trick with the day numbers too; this provides a handy
way to refer to the last day of the previous month. Thus C<MJD(20000100)>
refers to 31 December 1999 (but note that C<MJD(20000000)> refers to
30 November 1999). This works with leap years too (of course) so
C<MJD($y,3,0)> refers to the last day of February for any value of C<$y>.
=cut
sub MJD { # returns mjd from yyyymmdd or y,m,d
use integer;
my ($y, $m, $d) = &_getYMD;
# allow month to be enormous
while ( $m > 12) { $m -= 12; $y++ }
# adjust the month/year to make it a date after 1 March
if ($m < 3) { $m += 12; $y-- }
# work out days upto and including the day before the previous 1 March
# year * 365 + leap days - 306
# we are using the (possibly proleptic) Gregorian calendar
my $mjd = $y*365 + $y/4 - $y/100 + $y/400 - 306;
# add days since previous 1 March (incl)
$mjd += ($m+1)*306/10 - 122 + $d;
# adjust so 0 == 18 Nov 1858 == JD 2,400,000.5
$mjd -= 678576;
return $mjd;
}
=item DJM(mjd)
This function is the inverse of the C<MJD()> function, hence the rather
cute name. It takes any number, interprets it as an MJD number and returns
the corresponding date in the ISO compact form of YYYYMMDD. This form has
the advantage of being easily sorted and compared.
C<DJM()> is often used in combination with MJD. For example to `correct'
a date use C<DJM(MJD(yyyymmdd))>. If your input date was 20000300, this will
return 20000229. This idiom can also be used to check that an input date is
valid. Like this:
if ($date ne DJM(MJD($date)) ) {
print "$date is not a valid YYYYMMDD date\n";
}
When you pass a real number to C<DJM()> the fractional part is interpreted
as a fraction of a day, and the date and time are returned in C<YYYYMMDD HH:MM>
form. Like this:
print DJM(51455.7356) . "\n"; # prints 19991004 17:39
If you call C<DJM()> in a list context then the parts of the date/time
are returned as elements of a list, like this:
($y, $m, $d, $hr, $min) = DJM(51455.7356);
($y, $m, $d) = DJM(51500);
=cut
sub DJM { # returns yyyymmdd from mjd
return unless defined wantarray; # don't bother doing more
# the supplied MJD may be integer (hour=midnight) or real
# the fractional part repesents the time of day
my $mjd = shift;
# convert to full Julian number
my $jd = $mjd + 2400000.5;
# jd0 is the Julian number for noon on the day in question
# for example mjd jd jd0 === mjd0
# 3.0 ...3.5 ...4.0 === 3.5
# 3.3 ...3.8 ...4.0 === 3.5
# 3.7 ...4.2 ...4.0 === 3.5
# 3.9 ...4.4 ...4.0 === 3.5
# 4.0 ...4.5 ...5.0 === 4.5
my $jd0 = int($jd+0.5);
# next we convert to Julian dates to make the rest of the maths easier.
# JD1867217 = 1 Mar 400, so $b is the number of complete Gregorian
# centuries since then. The constant 36524.25 is the number of days
# in a Gregorian century. The 0.25 on the other constant ensures that
# $b correctly rounds down on the last day of the 400 year cycle.
# For example $b == 15.9999... on 2000 Feb 29 not 16.00000.
my $b = int(($jd0-1867216.25)/36524.25);
# b-int(b/4) is the number of Julian leap days that are not counted in
# the Gregorian calendar, and 1402 is the number of days from 1 Jan 4713BC
# back to 1 Mar 4716BC. $c represents the date in the Julian calendar
# corrected back to the start of a leap year cycle.
my $c = $jd0+($b-int($b/4))+1402;
# d is the whole number of Julian years from 1 Mar 4716BC to the date
# we are trying to find.
my $d = int(($c+0.9)/365.25);
# e is the number of days from 1 Mar 4716BC to 1 Mar this year
# using the Julian calendar
my $e = 365*$d+int($d/4);
# c-e is now the remaining days in this year from 1 Mar to our date
# and we need to work out the magic number f such that f-1 == month
my $f = int(($c-$e+123)/30.6001);
# int(f*30.6001) is the day of the start of the month
# so the day of the month is the difference between that and c-e+123
my $day = $c-$e+123-int(30.6001*$f);
# month is now f-1, except that Jan and Feb are f-13
# ie f 4 5 6 7 8 9 10 11 12 13 14 15
# m 3 4 5 6 7 8 9 10 11 12 1 2
my $month = ($f-2)%12+1;
# year is d - 4716 (adjusted for Jan and Feb again)
my $year = $d - 4716 + ($month<3);
# finally work out the hour (if any)
my $hour = 24 * ($jd+0.5-$jd0);
if ( $hour == 0) {
if (wantarray) {
return ($year, $month, $day)
}
else {
return sprintf "%d%02d%02d", ($year, $month, $day)
}
}
else {
$hour = int($hour*60+0.5)/60; # round to nearest minute
my $min = int(0.5+60 * ($hour - int($hour)));
$hour = int($hour);
if (wantarray) {
return $year, $month, $day, $hour, $min
}
else {
return sprintf "%d%02d%02d %02d:%02d", $year, $month, $day, $hour, $min
}
}
}
=item today() or today(delta)
This function returns today's date in YYYYMMDD form, saving you
all that tedious mucking about with lists and C<undef>s.
It uses C<localtime()> so you get the date adjusted for local time
zone, depending on the time of day this may or may not be the same
as the date at Greenwich. Use C<adjust_to_UTC> to get the UTC date if
that's what you want.
You can supply a number of days as an optional parameter. This number (which
may be negative) will be added to the current date. The number should be a
either a whole number of days or a week specification in a form that will
match C</^[+-]?\d+[wW]\d?$/>. For example: C<1w> means one week, C<-2w3>
means -17 days.
=cut
sub today { # return YYYYMMDD for today
return unless defined wantarray;
my $delta = &_get_delta;
return DJM(MJD()+$delta);
}
sub _get_delta {
my $delta = shift || 0;
if ($delta =~ /^([+-])?(\d+)[wW](\d)?$/) {
local $^W=0; # disable warnings for unitialized $1 or $3
$delta = $1.($2*7+$3)
}
if ( $delta !~ /^([+-]?\d+)$/ ) {
croak "Bad value for day shift: $delta\n";
}
return $delta;
}
sub now { # return hh:mm for now
return unless defined wantarray;
my ($s, $m, $h) = localtime();
return wantarray ? ($h,$m,$s) : sprintf("%02d:%02d:%02d", $h, $m, $s);
}
=item Easter(year,[delta])
This function takes a year number and returns the date of Easter Sunday
in YYYYMMDD form for that year. See below about valid years. The date
is supposed to be the first Sunday after the calendar full moon which
occurs on or after 21 March. The name Easter comes from the Saxon
goddess of the dawn, Eostre, whose festival was celebrated at the vernal
equinox.
You can supply a number of days as an optional parameter. This number
(which may be negative) will be added to the resulting date. This is
handy for working out dates that depend on Easter. For example:
$y = 2000;
$s = Easter($y,-47); # Shrove Tuesday (Pancake Day)
$m = Easter($y,-21); # Mothers day in the UK
$a = Easter($y,+39); # Ascension day
The format of the number should be as described above under L<today()>.
The algorithm used was adapted from D. E. Knuth I<Fundamental
Algorithms>, as Knuth notes it is derived from older sources, and is
only valid after 1582 when the Gregorian calendar was first used in
Europe (but not in Britain). For years before this use the
L<old_style_Easter()> routine below, which returns Julian dates such as
were in use then. I have only validated this routine back to 1066, the
earliest I could find a list in my reference books at home, but it
should be valid further back. I do not know when Easter was first
celebrated as Easter.
=cut
sub Easter {
return unless defined wantarray; # don't bother doing more
use integer;
my $y = shift;
my $delta = &_get_delta;
my $golden = $y%19 + 1;
my $century = $y/100 + 1;
my $x = 3*$century/4 - 12;
my $q = 5*$y/4 - $x - 10;
my $epact = (11*$golden + 15 + (8*$century + 5)/25 - $x) % 30;
++$epact if ($epact == 25 && $golden > 11) || $epact == 24;
my $d = 44 - $epact;
$d += 30 if $d < 21;
$d = $d + 7 - (($q+$d)%7);
return DJM(MJD($y,3,$d)+$delta);
}
=item old_style_Easter(year,[delta])
This function is mainly of historical interest. Before the switch to
Gregorian dates that happened in 1582 in certain parts of Roman Catholic
Europe, the Julian calendar was used. This routine gives you the date
of Easter in the Julian calendar. Because of the way Easter is derived,
this is not a constant number of days apart from the date in Gregorian.
Typically it can be either 4 or 5 weeks or just a few days.
In British historical records between 1582 and 1752 (when Britain
switched) the Julian dates are referred to as `old style' and the
Gregorian dates as `new style'. Hence my name for this function. This
algorithm is based on details found on the web which referred to the
algorithm of Oudin (1940), quoted in I<Explanatory Supplement to the
Astronomical Almanac>, P. Kenneth Seidelmann, editor.
You can add an optional day shift number as above in L<Easter()>.
=cut
sub old_style_Easter {
return unless defined wantarray; # don't bother doing more
use integer;
my $y = shift;
my $delta = &_get_delta;
my $g = $y % 19;
my $i = (19*$g + 15) % 30;
my $j = ($y + $y/4 + $i) % 7;
my $l = $i - $j;
my $m = 3 + ($l + 40)/44;
my $d = $l + 28 - 31*($m/4);
return DJM(MJD($y,$m,$d)+$delta);
}
=item orthodox_Easter(year,[delta])
The various Orthodox parts of the Christian church (principally in Greece, the
Balkans and other parts of eastern Europe and Russia) still use the Julian calendar
(the `old style') to work out the date of Easter, but they express the result
in new style, Gregorian dates. This routine may be handy if you belong to such
a church or if you are planning a spring holiday in Greece, where Easter is always
a special time.
This is essentially just old_style_Easter corrected to Gregorian dates with the L<J2G()> function.
=cut
sub orthodox_Easter {
my ($y,$m,$d) = &old_style_Easter;
return DJM(MJD($y,$m,$d)+J2G($y,$m,$d));
}
=item ISO_week(yyyymmdd) or ISO_week(y,m,d)
This function returns the week number according to the ISO standard.
This states that weeks begin on a Monday (day 1), and that the first
week of a year is the one with 4 Jan in it. The function returns the
date in the ISO week form: yyyy-Wnn. The year is included as it may
differ from the year of the date in yyyymmdd form. For example
C<ISO_week(20000101)> returns C<1999-W52>.
The ISO day number for a given date is given by C<ISO_day()>. See below.
=cut
sub ISO_week {
return unless defined wantarray; # don't bother doing more
use integer;
my ($y, $m, $d) = &_getYMD;
my $jan1 = MJD($y,1,1);
my $week = (MJD($y,$m,$d) - $jan1 + 1 + ($jan1+5)%7 + 3) / 7;
if ( $week == 0 ) {
# week belongs to last year
$y--;
# work out if its W52 or W53
$jan1 = MJD($y,1,1);
$week = (MJD($y,12,31) - $jan1 + 1 + ($jan1+5)%7 + 3) / 7;
}
elsif ( $week == 53 ) {
# week might belong to next year
# if 31 Dec is Weds or earlier
if (ISO_day(MJD($y,12,31)) < 4) {
$y++;
$week = 1;
}
}
return wantarray ? ($y, $week) : sprintf "%d-W%02d", $y, $week;
}
=item ISO_day(mjd)
This function returns the ISO day number for a given MJD value.
According to ISO, Monday is day 1 and Sunday day 7 in the week.
To find today's ISO day number do:
print ISO_day(MJD(today()));
I occasionally find that I call this with a date by mistake for an MJD
number, so as a convenience if the MJD number is over 10,000,000 we will
interpret it as a date. This means that ISO_day won't work for dates
after 29237-12-12, which we can probably live with, but that
c<ISO_day(20010117)> gives a less astonishing result.
=cut
sub ISO_day {
my $mjd = shift;
if ($mjd > 10_000_000) {
$mjd = MJD($mjd);
}
if ($mjd > -3) {
return ($mjd+2)%7+1;
}
else {
return abs(9+$mjd%7)%7+1;
}
}
=item ISO_week_and_day(yyyymmdd) or ISO_week_and_day(y,m,d)
Converts a given date to ISO Week.Day form, sometimes known as business
date form. For example 19991215 maps to 1999-W51-6
=cut
sub ISO_week_and_day {
return unless defined wantarray; # don't bother doing more
return wantarray ? (&ISO_week, ISO_day(&MJD)) : &ISO_week . '-' . ISO_day(&MJD)
}
=item day_of_year(yyyymmdd) or day_of_year(y,m,d)
This function returns the day number of the current year, where Jan 1 = 1,
Feb 1 = 32 etc. It is implemented simply as
MJD($y,$m,$d) - MJD($y-1,12,31)
=cut
sub day_of_year {
my ($y, $m, $d) = &_getYMD;
return MJD($y,$m,$d)-MJD($y,1,0);
}
=item days_to_go(yyyymmdd) or days_to_go(y,m,d)
This function returns the days to the end of the year, where Dec 31 = 0,
Dec 30 = 1, etc. Again it is simply implemented as
MJD($y,12,31)-MJD($y,$m,$d);
=cut
sub days_to_go {
my ($y, $m, $d) = &_getYMD;
return MJD($y,12,31)-MJD($y,$m,$d);
}
=item days_in_month(y,m)
This function returns the days in the current month. It is implemented
like this:
MJD($y,$m+1,1)-MJD($y,$m,1);
Note that this works even in December (when C<$m==12>)
because C<MJD()> interprets 13 to mean January next year.
You may find it easier to use MJD directly for this function, and save
an import.
=cut
sub days_in_month {
my ($y, $m) = @_;
return MJD($y,$m+1,1)-MJD($y,$m,1);
}
=item UK_tax_week(yyyymmdd) or UK_tax_week(y,m,d)
This function is specific to UK Income Tax or `Pay As You Earn' rules.
It returns a string indicating the week in the tax year corresponding to a
given date. The UK tax year starts on April 5 each year. Example:
print UK_tax_week(19991225); # Prints: PAYE Week 38
=cut
sub UK_tax_week {
my ($y, $m, $d) = &_getYMD;
my $april6 = MJD($y,4,6);
my $today = MJD($y,$m,$d);
if ($april6 > $today ) { $april6 = MJD($y-1,4,6) }
use integer;
return sprintf "%d", ($today-$april6)/7+1;
}
=item UK_tax_month()
This function is also specific to UK Income Tax or `Pay As You Earn' rules.
It returns a string indicating the month in the tax year corresponding to a
given date. The UK tax year starts on April 5 each year. Example:
print UK_tax_month(19991225); # Prints: PAYE Month 9
=cut
sub UK_tax_month {
my ($y, $m, $d) = &_getYMD;
return sprintf "%d", ($m+8-($d<6))%12+1;
}
=item working_days(y,m,d,period) or working_days(y,m,d,y2,m2,d2)
This function returns the number of working days in a given period including
start day. Call it with a date and a number of days or with two dates. The
number of days returned is simply the number of non-weekend days, no account
is taken of holidays etc. More sophisticated functions can be found in the
C<Date::Manip> package. The two dates can be given in either order. Should
they be the same, then 1 or 0 may be returned depending on whether the day in
question was a working day or not.
=cut
sub working_days {
my ($start,$end,$m,$count);
$start = MJD($_[0],$_[1],$_[2]);
if (@_ == 4) { $end = $start + $_[3] - 1; }
elsif (@_ == 6) { $end = MJD($_[3],$_[4],$_[5]); }
else { croak "Bad call to working days: $!\n" }
if ($start > $end ) { ($start,$end) = ($end,$start)}
if ($end-$start > 10000 ) { return 'Lots' }
$count = 0;
for $m ($start..$end) {
++$count if ISO_day($m) < 6
}
return $count;
}
=item v_date(year,datespec[,delta])
v_date returns a date as a real MJD (or (y,m,d,h,min,s) in list context)
optionally shifted by delta days, based on the specification in datespec
and the given year.
The format of the delta number should be as described above under L<today()>.
This specification can be one of the standard variable date forms used in
setting a Posix TZ environment variable, extended as noted here.
The main form is Mmm.w.d where `mm' is the month (1-12) number, `w' is the
week of the month (1-5 or L) note that 5 and L are equivalent and refer to
the last week of the months (either the fourth or fifth depending on the
length of the month), and `d' is the day of the week (0-7) where 1 = Monday
and 7 (or 0) = Sunday.
The use of L and 7 above are extensions to the Posix rules. Further you can
extend the meaning of `d' to allow you to specify for example the last working
day in a month. You do this by adding to the d number, eg:
M10.L.12345 means the last working day of October, while
M1.1.67 means the first weekend day in January.
Other forms are...
- Jddd which refers to the day of the year, regardless of leap days (ie 1
March is always day J60 etc).
- ddd which refers to the day of the year counting leap days, (ie day 60 is
Feb 29 in leap years or Mar 1 in non-leap years.
- Dmm.d.w which is exactly the same as the M form, but with the w and d
fields reversed.
Any of the specs may be followed by "/hh[:mm[:ss]]" to indicate a particular
time.
v_date returns undef if called with an invalid spec.
=cut
sub v_date {
return unless defined wantarray;
my $y = shift;
my $spec = shift;
my $delta = &_get_delta;
my ($m,$w,$d,$mjd,$time,$dshift);
# remove any time from spec
if ( $spec =~ /(.*)\/(\d+)(:(\d+)(:(\d+))?)?/ ) {
$time = $2;
if ( defined($4) ) {
$time += $4/60;
if ( defined($6) ) {
$time += $6/3600;
}
}
$spec = $1;
}
else { $time = 0 }
# change D.... to M....
if (($m,$d,$w) = $spec =~ /^D([0-1]?\d).([0-7]+).([1-5L])$/ ) {
$spec = "M$m.$w.$d";
}
# Mmm.w.d
if (($m,$w,$d) = $spec =~ /^M([0-1]?\d).([1-5L]).([0-7]+)$/ ) {
if ($w =~ /[1-4]/ ) {
$mjd = MJD($y,$m,1) + 7*($w-1);
$dshift = 7;
for my $n ( split(/ */,$d)) {
$n = $n - ISO_day($mjd);
if ($n<0) { $n += 7 }
if ($n<$dshift) { $dshift = $n }
}
}
else { # 5 or L
$mjd = MJD($y,$m+1,0);
$dshift = 7;
for my $n ( split(/ */,$d) ) {
$n = $n - ISO_day($mjd)%7;
if ($n>0) { $n -= 7 }
if (abs($n)<abs($dshift)) { $dshift = $n }
}
}
$mjd = $mjd+$dshift+$delta;
}
# Jnnn ....
elsif (($d) = $spec =~ /^J(\d+)$/ ) {
if ($d>59) { $mjd = MJD($y,3,1)+$d-60+$delta }
else { $mjd = MJD($y,1,0)+$d+$delta }
}
# nnn ...
elsif (($d) = $spec =~ /^(\d+)$/ ) {
$mjd = MJD($y,1,0)+$d+$delta
}
else {
croak "Malformed spec for v_date: $spec\n";
}
$mjd += $time/24;
return wantarray ? DJM($mjd) : $mjd;
}
=item r_date(dow[,every[,start[,end]]])
This routine generates a list of MJD integers corresponding to a set of
repeating dates defined by the argument list. The set may be empty in which
case an empty list is returned. In the scalar context you get the number of
dates in the list. The list is returned sorted in ascending numerical order.
dow: should match C</\d/ & /^1?2?3?4?5?6?7?$/>, that is at least one and
at most seven digits between 1 and 7 with no repetitions. So "1" means
Mondays, "6" means Saturdays, "14" means Mondays and Thursdays and so on.
every: 1 means every dow, 2 means every other dow, 3 means every third dow, etc.
Every defaults to 1.
start: is a date in yyyymmdd form. The first date in the returned list
will be on or after this date. Start defaults to Jan 1st in the current year.
end: is another date in yyyymmdd form. The last date in the returned list
will be on or before this date. End defaults to Dec 31st in the current year.
Some examples:
r_date(1) returns a list of every Monday in the current year
r_date(2,2,20030101,20030700)
returns every other Tuesday in the first half of 2003
r_date(15,1,20030501,20030531)
every Monday and Friday in June 2003
=cut
sub r_date {
return unless defined wantarray;
my (undef,undef,undef,undef,undef,$y) = localtime;
my $days = shift;
my $every = shift;
my $start = shift;
my $end = shift;
return undef unless defined $days && $days =~ /\d+/ && $days =~ /^1?2?3?4?5?6?7?$/;
$every = 1 unless defined $every && $every =~ /^\d+$/ && $every<100;
if ( defined $start && $start=~/^\d{8}$/ ) { $start = MJD($start) }
else { $start = MJD($y,1,1) }
if ( defined $end && $end =~/^\d{8}$/ ) { $end = MJD($end) }
else { $end = MJD($y,12,31) }
my @list = ();
for my $dow ( split / */, $days) {
my $day_shift = $dow - ISO_day($start);
$day_shift += 7 if $day_shift < 0;
my $first_date = $start + $day_shift;
for (my $i=0; $first_date+$i<$end; $i+=7*$every) {
push @list, $first_date+$i;
}
}
return sort @list;
}
=item adjust_to_local_time(mjd,tzoffset,tzrule1,tzrule2[,DST_delta])
This routine takes a real MJD number --- representing a UTC date and time ---
and adjusts it for time zone making proper allowance for summer time or
`daylight saving time' (DST). The second argument is the normal difference
between UTC and local time (ie New York = +5) in hours.
The third and fourth arguments are two rules that define when DST should
start when it should stop. If the rules are empty or undefined then the
routine returns the MJD adjusted to local time with no allowance for summer
time. The rules are rules in the format understood by C<v_date()>.
The fifth argument represents the number of hours that the clocks go forward
when DST starts. If this is omitted it will default to 1. This default was
not always correct historically but as far as I have been able to verify it
is currently, so you can nearly always omit the fifth argument.
=cut
sub adjust_to_local_time {
my $mjd = shift;
my $tz = shift || $Cal::Astro::tz;
my $r1 = shift || $Cal::Astro::r1;
my $r2 = shift || $Cal::Astro::r2;
my $dst_delta = shift || 1;
# stop here if no date given
return '' unless defined($mjd);
return '' if $mjd eq '';
# stop here if no TZ given
return $mjd unless defined($tz);
# adjust for time zone
$mjd = $mjd-$tz/24;
# stop here if no summer time rules
return $mjd unless defined($r1) && defined($r2);
# make rules into dates for the current year
my ($year) = DJM($mjd);
my $d1 = v_date($year,$r1);
my $d2 = v_date($year,$r2);
# are we in DST at the start of the year?
# (ie does r1 say October rather than March/April)
my $jan_state = ($d1 > $d2);
# swap the dates so that d1 < d2
($d1,$d2) = ($d2,$d1) if $jan_state;
# if the date is in the summer set the opposite of
# the state at the start of the year & adjust if needed
if ($d1 <= $mjd && $mjd < $d2 ) {
return $mjd + $dst_delta/24 * !$jan_state;
}
# otherwise return the state at the start of the year
return $mjd + $dst_delta/24 * $jan_state;
}
=item adjust_to_UTC(mjd,tzoffset,tzrule1,tzrule2[,DST_delta])
This routine takes a real MJD number --- representing a local date and time ---
and adjusts it back to UTC allowing for local time zone and
summer time rules.
The arguments are all exactly the same as those for C<adjust_to_local_time()>.
=cut
sub adjust_to_UTC {
my $mjd = shift;
my $tz = shift || $Cal::Astro::tz;
my $r1 = shift || $Cal::Astro::r1;
my $r2 = shift || $Cal::Astro::r2;
my $dst_delta = shift || 1;
return adjust_to_local_time($mjd,-$tz,$r1,$r2,-$dst_delta);
}
sub is_a_date {
my $date = shift;
$date =~ s/[^0-9]//g;
return 0 unless $date =~ /\d{8}/;
return $date eq DJM(MJD($date));
}
sub _getYMD {
my ($y, $m, $d);
if ( @_ == 0 ) {
(undef, undef, undef, $d, $m, $y) = localtime();
$y += 1900;
$m ++;
} elsif ( @_ == 1 && !defined $_[0] ) {
my ($package, $filename, $line) = caller;
croak "\nCal::Date routine called with undefined value by $package \nLook at $filename, line $line\n";
} elsif ( @_ == 1 && $_[0] =~ /^\d+$/ && $_[0] > 100000 ) {
$y = substr($_[0],0,-4);
$m = substr($_[0],-4,2);
$d = substr($_[0],-2);
} elsif ( @_ == 1 && $_[0] =~ /^\d+$/ ) {
# probably an MJD as it is so small
($y, $m, $d) = DJM($_[0]);
} elsif (@_ == 1 && $_[0] =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/ ) {
($y, $m, $d) = ($1, $2, $3);
} elsif ( @_ == 3
&& $_[0] =~ /^\d+$/
&& $_[1] =~ /^[-]?\d+$/
&& $_[2] =~ /^[-]?\d+$/) {
($y, $m, $d) = @_
} else {
croak "Can't read a date from this --> [@_]"
}
return ($y, $m, $d);
}
sub J2G { # returns days difference between julian on gregorian dates
use integer;
my ($y, $m, $d) = &_getYMD;
# if the month is Jan or Feb then use the year before
if ($m < 3) { $y-- }
# the difference in leap days is just the omitted century end leap days in the
# Gregorian calendar, less two because they didn't start until
# some long time after 1 AD
return $y/100 - $y/400 - 2;
}
=back
=head1 SEE ALSO
L<Date::Calc> and L<Date::Manip> packages which provide more comprehensive
functions; as they say: there's more than one way to do it.
=head1 AUTHOR
Toby Thurston
web: http://www.wildfire.dircon.co.uk
=cut
1;
Reference in New Issue Copy Permalink