diff options
Diffstat (limited to 'mmuegel/libs/date.pl')
| -rw-r--r-- | mmuegel/libs/date.pl | 324 |
1 files changed, 324 insertions, 0 deletions
diff --git a/mmuegel/libs/date.pl b/mmuegel/libs/date.pl new file mode 100644 index 0000000..6732438 --- /dev/null +++ b/mmuegel/libs/date.pl @@ -0,0 +1,324 @@ +;# +;# Name +;# date.pl - Perl emulation of (the output side of) date(1) +;# +;# Synopsis +;# require "date.pl"; +;# $Date = &date(time); +;# $Date = &date(time, $format); +;# +;# Description +;# This package implements the output formatting functions of date(1) in +;# Perl. The format options are based on those supported by Ultrix 4.0 +;# plus a couple of additions from SunOS 4.1.1 and elsewhere: +;# +;# %a abbreviated weekday name - Sun to Sat +;# %A full weekday name - Sunday to Saturday +;# %b abbreviated month name - Jan to Dec +;# %B full month name - January to December +;# %c date and time in local format [+] +;# %C date and time in long local format [+] +;# %d day of month - 01 to 31 +;# %D date as mm/dd/yy +;# %e day of month (space padded) - ` 1' to `31' +;# %E day of month (with suffix: 1st, 2nd, 3rd...) +;# %f month of year (space padded) - ` 1' to `12' +;# %h abbreviated month name - Jan to Dec +;# %H hour - 00 to 23 +;# %i hour (space padded) - ` 1' to `12' +;# %I hour - 01 to 12 +;# %j day of the year (Julian date) - 001 to 366 +;# %k hour (space padded) - ` 0' to `23' +;# %l date in ls(1) format +;# %m month of year - 01 to 12 +;# %M minute - 00 to 59 +;# %n insert a newline character +;# %p ante-meridiem or post-meridiem indicator (AM or PM) +;# %r time in AM/PM notation +;# %R time as HH:MM +;# %S second - 00 to 59 +;# %t insert a tab character +;# %T time as HH:MM:SS +;# %u date/time in date(1) required format +;# %U week number, Sunday as first day of week - 00 to 53 +;# %V date-time in SysV touch format (mmddHHMMyy) +;# %w day of week - 0 (Sunday) to 6 +;# %W week number, Monday as first day of week - 00 to 53 +;# %x date in local format [+] +;# %X time in local format [+] +;# %y last 2 digits of year - 00 to 99 +;# %Y all 4 digits of year ~ 1700 to 2000 odd ? +;# %z time zone from TZ environment variable w/ a trailing space +;# %Z time zone from TZ environment variable +;# %% insert a `%' character +;# %+ insert a `+' character +;# +;# [+]: These may need adjustment to fit local conventions, see below. +;# +;# For the sake of compatibility, a leading `+' in the format +;# specificaiton is removed if present. +;# +;# Remarks +;# This is version 3.4 of date.pl +;# +;# An extension of `ctime.pl' by Waldemar Kebsch (kebsch.pad@nixpbe.UUCP), +;# as modified by Marion Hakanson (hakanson@ogicse.ogi.edu). +;# +;# Unlike date(1), unknown format tags are silently replaced by "". +;# +;# defaultTZ is a blatant hack, but I wanted to be able to get date(1) +;# like behaviour by default and there does'nt seem to be an easy (read +;# portable) way to get the local TZ name back... +;# +;# For a cheap date, try... +;# +;# #!/usr/local/bin/perl +;# require "date.pl"; +;# exit print (&date(time, shift @ARGV) . "\n") ? 0 : 1; +;# +;# This package is redistributable under the same terms as apply to +;# the Perl 4.0 release. See the COPYING file in your Perl kit for +;# more information. +;# +;# Please send any bug reports or comments to tmcgonigal@gallium.com +;# +;# Modification History +;# Nmemonic Version Date Who +;# +;# NONE 1.0 02feb91 Terry McGonigal (tmcgonigal@gallium.com) +;# Created from ctime.pl +;# +;# NONE 2.0 07feb91 tmcgonigal +;# Added some of Marion Hakanson (hakanson@ogicse.ogi.edu)'s ctime.pl +;# TZ handling changes. +;# +;# NONE 2.1 09feb91 tmcgonigal +;# Corrected week number calculations. +;# +;# NONE 2.2 21oct91 tmcgonigal +;# Added ls(1) date format, `%l'. +;# +;# NONE 2.3 06nov91 tmcgonigal +;# Added SysV touch(1) date-time format, `%V' (pretty thin as +;# mnemonics go, I know, but `t' and `T' were both gone already!) +;# +;# NONE 2.4 05jan92 tmcgonigal +;# Corrected slight (cosmetic) problem with %V replacment string +;# +;# NONE 3.0 09jul92 tmcgonigal +;# Fixed a couple of problems with &ls as pointed out by +;# Thomas Richter (richter@ki1.chemie.fu-berlin.de), thanks Thomas! +;# Also added a couple of SunOS 4.1.1 strftime-ish formats, %i and %k +;# for space padded hours (` 1' to `12' and ` 0' to `23' respectivly), +;# and %C for locale long date/time format. Changed &mH to take a +;# pad char parameter to make to evaled code for %i and %k simpler. +;# Added %E for suffixed day-of-month (ie 1st, 3rd, 4th etc). +;# +;# NONE 3.1 16jul92 tmcgonigal +;# Added `%u' format to generate date/time in date(1) required +;# format (ie '%y%m%d%H%M.%S'). +;# +;# NONE 3.2 23jan93 tmcgonigal +;# Added `%f' format to generate space padded month numbers, added +;# `%E' to the header comments, it seems to have been left out (and +;# I'm sure I wanted to use it at some point in the past...). +;# +;# NONE 3.3 03feb93 tmcgonigal +;# Corrected some problems with AM/PM handling pointed out by +;# Michael S. Muegel (mmuegel@mot.com). Thanks Michael, I hope +;# this is the behaviour you were looking for, it seems more +;# correct to me... +;# +;# NONE 3.4 26jul93 tmcgonigal +;# Incorporated some fixes provided by DaviD W. Sanderson +;# (dws@ssec.wisc.edu): February was spelled incorrectly and +;# &wkno() was always using the current year while calculating +;# week numbers, regardless of year implied by the time value +;# passed to &date(). DaviD also contributed an improved &date() +;# test script, thanks DaviD, I appreciate the effort. Finally, +;# changed my mailling address from @gvc.com to @gallium.com +;# to reflect, well, my new address! +;# +;# SccsId = "%W% %E%" +;# +require 'timelocal.pl'; +package date; + +# Months of the year +@MoY = ('January', 'February', 'March', 'April', 'May', 'June', + 'July', 'August', 'September','October', 'November', 'December'); + +# days of the week +@DoW = ('Sunday', 'Monday', 'Tuesday', 'Wednesday', + 'Thursday', 'Friday', 'Saturday'); + +# CUSTOMIZE - defaults +$defaultTZ = 'CST'; # time zone (hack!) +$defaultFMT = '%a %h %e %T %z%Y'; # format (ala date(1)) + +# CUSTOMIZE - `local' formats +$locTF = '%T'; # time (as HH:MM:SS) +$locDF = '%D'; # date (as mm/dd/yy) +$locDTF = '%a %b %d %T %Y'; # date/time (as dow mon dd HH:MM:SS yyyy) +$locLDTF = '%i:%M:%S %p %A %B %E %Y'; # long date/time (as HH:MM:SS a/p day month dom yyyy) + +# Time zone info +$TZ; # wkno needs this info too + +# define the known format tags as associative keys with their associated +# replacement strings as values. Each replacement string should be +# an eval-able expresion assigning a value to $rep. These expressions are +# eval-ed, then the value of $rep is substituted into the supplied +# format (if any). +%Tags = ( '%a', q|($rep = $DoW[$wday])=~ s/^(...).*/\1/|, # abbr. weekday name - Sun to Sat + '%A', q|$rep = $DoW[$wday]|, # full weekday name - Sunday to Saturday + '%b', q|($rep = $MoY[$mon]) =~ s/^(...).*/\1/|, # abbr. month name - Jan to Dec + '%B', q|$rep = $MoY[$mon]|, # full month name - January to December + '%c', q|$rep = $locDTF; 1|, # date/time in local format + '%C', q|$rep = $locLDTF; 1|, # date/time in local long format + '%d', q|$rep = &date'pad($mday, 2, "0")|, # day of month - 01 to 31 + '%D', q|$rep = '%m/%d/%y'|, # date as mm/dd/yy + '%e', q|$rep = &date'pad($mday, 2, " ")|, # day of month (space padded) ` 1' to `31' + '%E', q|$rep = &date'dsuf($mday)|, # day of month (w/suffix) `1st' to `31st' + '%f', q|$rep = &date'pad($mon+1, 2, " ")|, # month of year (space padded) ` 1' to `12' + '%h', q|$rep = '%b'|, # abbr. month name (same as %b) + '%H', q|$rep = &date'pad($hour, 2, "0")|, # hour - 00 to 23 + '%i', q|$rep = &date'ampmH($hour, " ")|, # hour (space padded ` 1' to `12' + '%I', q|$rep = &date'ampmH($hour, "0")|, # hour - 01 to 12 + '%j', q|$rep = &date'pad($yday+1, 3, "0")|, # Julian date 001 - 366 + '%k', q|$rep = &date'pad($hour, 2, " ")|, # hour (space padded) ` 0' to `23' + '%l', q|$rep = '%b %d ' . &date'ls($year)|, # ls(1) style date + '%m', q|$rep = &date'pad($mon+1, 2, "0")|, # month of year - 01 to 12 + '%M', q|$rep = &date'pad($min, 2, "0")|, # minute - 00 to 59 + '%n', q|$rep = "\n"|, # insert a newline + '%p', q|$rep = &date'ampmD($hour)|, # insert `AM' or `PM' + '%r', q|$rep = '%I:%M:%S %p'|, # time in AM/PM notation + '%R', q|$rep = '%H:%M'|, # time as HH:MM + '%S', q|$rep = &date'pad($sec, 2, "0")|, # second - 00 to 59 + '%t', q|$rep = "\t"|, # insert a tab + '%T', q|$rep = '%H:%M:%S'|, # time as HH:MM:SS + '%u', q|$rep = '%y%m%d%H%M.%S'|, # daaate/time in date(1) required format + '%U', q|$rep = &date'wkno($year, $yday, 0)|, # week number (weeks start on Sun) - 00 to 53 + '%V', q|$rep = '%m%d%H%M%y'|, # SysV touch(1) date-time format (mmddHHMMyy) + '%w', q|$rep = $wday; 1|, # day of week - Sunday = 0 + '%W', q|$rep = &date'wkno($year, $yday, 1)|, # week number (weeks start on Mon) - 00 to 53 + '%x', q|$rep = $locDF; 1|, # date in local format + '%X', q|$rep = $locTF; 1|, # time in local format + '%y', q|($rep = $year) =~ s/..(..)/\1/|, # last 2 digits of year - 00 to 99 + '%Y', q|$rep = "$year"; 1|, # full year ~ 1700 to 2000 odd + '%z', q|$rep = $TZ eq "" ? "" : "$TZ "|, # time zone from TZ env var (w/trail. space) + '%Z', q|$rep = $TZ; 1|, # time zone from TZ env. var. + '%%', q|$rep = '%'; $adv=1|, # insert a `%' + '%+', q|$rep = '+'| # insert a `+' +); + +sub main'date { + local($time, $format) = @_; + local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); + local($pos, $tag, $rep, $adv) = (0, "", "", 0); + + # default to date/ctime format or strip leading `+'... + if ($format eq "") { + $format = $defaultFMT; + } elsif ($format =~ /^\+/) { + $format = $'; + } + + # Use local time if can't find a TZ in the environment + $TZ = defined($ENV{'TZ'}) ? $ENV{'TZ'} : $defaultTZ; + ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = + &gettime ($TZ, $time); + + # Hack to deal with 'PST8PDT' format of TZ + # Note that this can't deal with all the esoteric forms, but it + # does recognize the most common: [:]STDoff[DST[off][,rule]] + if ($TZ =~ /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) { + $TZ = $isdst ? $4 : $1; + } + + # watch out in 2070... + $year += ($year < 70) ? 2000 : 1900; + + # now loop throught the supplied format looking for tags... + while (($pos = index ($format, '%')) != -1) { + + # grab the format tag + $tag = substr($format, $pos, 2); + $adv = 0; # for `%%' processing + + # do we have a replacement string? + if (defined $Tags{$tag}) { + + # trap dead evals... + if (! eval $Tags{$tag}) { + print STDERR "date.pl: internal error: eval for $tag failed: $@\n"; + return ""; + } + } else { + $rep = ""; + } + + # do the substitution + substr ($format, $pos, 2) =~ s/$tag/$rep/; + $pos++ if ($adv); + } + + $format; +} + +# dsuf - add `st', `nd', `rd', `th' to a date (ie 1st, 22nd, 29th) +sub dsuf { + local ($mday) = @_; + + return $mday . 'st' if ($mday =~ m/.*1$/); + return $mday . 'nd' if ($mday =~ m/.*2$/); + return $mday . 'rd' if ($mday =~ m/.*3$/); + return $mday . 'th'; +} + +# weekno - figure out week number +sub wkno { + local ($year, $yday, $firstweekday) = @_; + local ($jan1, @jan1, $wks); + + # figure out the `time' value for January 1 of the given year + $jan1 = &maketime ($TZ, 0, 0, 0, 1, 0, $year-1900); + + # figure out what day of the week January 1 was + @jan1= &gettime ($TZ, $jan1); + + # and calculate the week number + $wks = (($yday + ($jan1[6] - $firstweekday)) + 1)/ 7; + $wks += (($wks - int($wks) > 0.0) ? 1 : 0); + + # supply zero padding + &pad (int($wks), 2, "0"); +} + +# ampmH - figure out am/pm (1 - 12) mode hour value, padded with $p (0 or ' ') +sub ampmH { local ($h, $p) = @_; &pad($h>12 ? $h-12 : ($h ? $h : 12), 2, $p); } + +# ampmD - figure out am/pm designator +sub ampmD { shift @_ >= 12 ? "PM" : "AM"; } + +# gettime - get the time via {local,gmt}time +sub gettime { ((shift @_) eq 'GMT') ? gmtime(shift @_) : localtime(shift @_); } + +# maketime - make a time via time{local,gmt} +sub maketime { ((shift @_) eq 'GMT') ? &main'timegm(@_) : &main'timelocal(@_); } + +# ls - generate the time/year portion of an ls(1) style date +sub ls { + return ((&gettime ($TZ, time))[5] == @_[0]) ? "%R" : " %Y"; +} + +# pad - pad $in with leading $pad until lenght $len +sub pad { + local ($in, $len, $pad) = @_; + local ($out) = "$in"; + + $out = $pad . $out until (length ($out) == $len); + return $out; +} + +1; |