Acme-Tools
view release on metacpan or search on metacpan
#'::z'=>'TZHH:MI:SS',
#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30
#Z=>'TZN', #e.g. CET, EDT, ...
);
my $pkeys=join"|",keys%p;
$format=~s,\%($pkeys),$p{$1},g;
$format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g;
$format=~s/YYYY / 1900+$lt[5] /gxe;
$format=~s/(\s?)yyyy / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe;
$format=~s/YY / sprintf("%02d",$lt[5]%100) /gxei;
$format=~s|CC | sprintf("%02d",(1900+$lt[5])/100) |gxei;
$format=~s/MM / sprintf("%02d",$lt[4]+1) /gxe;
$format=~s/mm / sprintf("%d",$lt[4]+1) /gxe;
$format=~s,M/ , ($lt[4]+1).'/' ,gxe;
$format=~s,/M , '/'.($lt[4]+1) ,gxe;
$format=~s/DD / sprintf("%02d",$lt[3]) /gxe;
$format=~s/d0w|dow0 / $lt[6] /gxei;
$format=~s/dow / $lt[6]?$lt[6]:7 /gxei;
$format=~s/d0y|doy0 / $lt[7] /gxei; #0-364 (365 leap)
$format=~s/doy / $lt[7]+1 /gxei; #1-365 (366 leap)
$format=~s/D(?![AaGgYyEeNn]) / $lt[3] /gxe; #EN pga desember og wednesday
$format=~s/dd / sprintf("%d",$lt[3]) /gxe;
$format=~s/hh12|HH12 / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe;
$format=~s/HH24|HH24|HH|hh / sprintf("%02d",$lt[2]) /gxe;
$format=~s/MI / sprintf("%02d",$lt[1]) /gxei;
$format=~s{SS\.([1-9]) }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei;
$format=~s/SS(?:\.0)? / sprintf("%02d",$lt[0]) /gxei;
$format=~s/(?:am|pm|apm|xm) / $lt[2]<13 ? 'am' : 'pm' /gxe;
$format=~s/(?:AM|PM|APM|XM) / $lt[2]<13 ? 'AM' : 'PM' /gxe;
$format=~s/WWI|WW / sprintf("%02d",weeknum($time)) /gxei;
$format=~s/W / weeknum($time) /gxei;
$format;
}
=head2 easter
Input: A year (a four digit number)
Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April.
sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30;
(($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) }
...is a "golfed" version of Oudins algorithm (1940) L<http://astro.nmsu.edu/~lhuber/leaphist.html>
(see also http://www.smart.net/~mmontes/ec-cal.html )
Valid for any Gregorian year. Dates repeat themselves after 70499183
lunations = 2081882250 days = ca 5699845 years. However, our planet will
by then have a different rotation and spin time...
Example:
( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4
Example 2:
my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000;
print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425
Note: The Spencer Jones formula differs Oudins used in C<easter()> in some years
before 1498. However, in that period the Julian calendar with a different formula was
used anyway. Countries introduced the current Gregorian calendar between 1583 and 1926.
=cut
sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30;
(($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) }
=head2 time_fp
No input arguments.
Return the same number as perls C<time()> except with decimals (fractions of a second, _fp as in floating point number).
print time_fp(),"\n";
print time(),"\n";
Could write:
1116776232.38632
...if that is the time now.
Or just:
1116776232
...from perl's internal C<time()> if C<Time::HiRes> isn't installed and available.
=cut
sub time_fp { # {return 0+gettimeofday} is just as well?
eval{ require Time::HiRes } or return time();
my($sec,$mic)=Time::HiRes::gettimeofday();
return $sec+$mic/1e6; #1e6 not portable?
}
sub timems {
eval{ require Time::HiRes } or return time();
my($sec,$mic)=Time::HiRes::gettimeofday();
return $sec*1000+$mic/1e3;
}
=head2 sleep_fp
sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds:
sleep_fp(0.020); # sleeps for 20 milliseconds
Sub sleep_fp do a C<require Time::HiRes>, thus it might take some
extra time the first call. To avoid that, add C<< use Time::HiRes >>
to your code. Sleep_fp should not be trusted for accuracy to more than
a tenth of a second. Virtual machines tend to be less accurate (sleep
longer) than physical ones. This was tested on VMware and RHEL
(Linux). See also L<Time::HiRes>.
=head2 sleeps
=head2 sleepms
=head2 sleep_until
sleep_until(0.5) sleeps until half a second has passed since the last
call to sleep_until. This example starts the next job excactly ten
seconds after the last job started even if the last job lasted for a
while (but not more than ten seconds):
for(@jobs){
sleep_until(10);
print localtime()."\n";
...heavy job....
}
Might print:
Thu Jan 12 16:00:00 2012
Thu Jan 12 16:00:10 2012
Thu Jan 12 16:00:20 2012
...and so on even if the C<< ...heavy job... >>-part takes more than a
second to complete. Whereas if sleep(10) was used, each job would
spend more than ten seconds in average since the work time would be
added to sleep(10).
Note: sleep_until() will remember the time of ANY last call of this sub,
not just the one on the same line in the source code (this might change
in the future). The first call to sleep_until() will be the same as
sleep_fp() or Perl's own sleep() if the argument is an integer.
=cut
our $Time_last_sleep_until;
sub sleep_until {
my $s=@_==1?shift():0;
my $time=time_fp();
my $sleep=$s-($time-nvl($Time_last_sleep_until,0));
$Time_last_sleep_until=time;
sleep_fp($sleep) if $sleep>0;
}
my %thr;
sub throttle {
my($times,$mintime,$what)=@_;
$what||=join(":",@{[caller(1)]}[3,2]);
$thr{$what}||=[];
my $thr=$thr{$what};
push @$thr,time_fp();
return if @$thr<$times;
my $since=$$thr[-1]-shift(@$thr);
my $sleep=$since<$mintime?$mintime-$since:0;
sleep_fp($sleep);
return $sleep;
}
=head2 leapyear
B<Input:> A year. A four digit number.
B<Output:> True (1) or false (0) of whether the year is a leap year or
not. (Uses current calendar even for periods before leapyears was used).
print join(", ",grep leapyear($_), 1900..2014)."\n";
1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956,
1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012
Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only
if it can be divided by 400.
=cut
sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool
#http://rosettacode.org/wiki/Levenshtein_distance#Perl
our %ldist_cache;
sub ldist {
my($s,$t,$l) = @_;
return length($t) if !$s;
return length($s) if !$t;
%ldist_cache=() if !$l and 1000<0+%ldist_cache;
$ldist_cache{$s,$t} ||=
do {
my($s1,$t1) = ( substr($s,1), substr($t,1) );
substr($s,0,1) eq substr($t,0,1)
? ldist($s1,$t1)
: 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) );
};
}
=head1 OTHER
=head2 nvl
The I<no value> function (or I<null value> function)
C<nvl()> takes two or more arguments. (Oracles nvl-function take just two)
Returns the value of the first input argument with length() > 0.
Return I<undef> if there is no such input argument.
In perl 5.10 and perl 6 this will most often be easier with the C< //
> operator, although C<nvl()> and C<< // >> treats empty strings C<"">
differently. Sub nvl here considers empty strings and undef the same.
=cut
sub nvl {
return $_[0] if defined $_[0] and length($_[0]) or @_==1;
return $_[1] if @_==2;
return nvl(@_[1..$#_]) if @_>2;
return undef;
}
=head2 decode_num
See L</decode>.
=head2 decode
( run in 1.426 second using v1.01-cache-2.11-cpan-5b529ec07f3 )