home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Time.pm < prev    next >
Text File  |  1998-07-26  |  12KB  |  413 lines
  1. package RISCOS::Time;
  2.  
  3. use RISCOS::SWI;
  4. use Carp;
  5. #use SelfLoader;
  6. require Exporter;
  7. use strict;
  8. use vars qw (@ISA @EXPORT_OK $VERSION $time2utc $time2local $time2_mask
  9.          $s_1900to1970 $seconds_per_day $cs_1900to1970_256 $cs_per_day_256 
  10.          $start $standard_date_and_time $standard_date_and_time_mask);
  11.  
  12. @ISA = qw(Exporter);
  13. @EXPORT_OK = qw(time_age2cs time_age2riscos time_age2unix
  14.         time_cs2age time_cs2riscos time_cs2unix
  15.         time_riscos2age time_riscos2cs time_riscos2unix
  16.         time_unix2age time_unix2cs time_unix2riscos
  17.         time_guess2riscos $s_1900to1970 $seconds_per_day
  18.         time2utc time2local time2_raw standard_date_and_time);
  19. $VERSION = 0.04;
  20.  
  21. $time2utc = SWINumberFromString("XTerritory_ConvertTimeToUTCOrdinals");
  22. $time2local = SWINumberFromString("XTerritory_ConvertTimeToOrdinals");
  23. $time2_mask = ®mask([0..2]);
  24. $standard_date_and_time = SWINumberFromString("XOS_ConvertStandardDateAndTime");
  25. $standard_date_and_time_mask = ®mask([0..2]);
  26.  
  27. # Make constants
  28. # Seconds between 1st January 1900 and 1st January 1970
  29. *s_1900to1970        = \2208988800;    # 17 leap years, 53 normal
  30. *cs_1900to1970_256    = \862886250;    # cs ÷ 256
  31. *seconds_per_day    = \86400;
  32. *cs_per_day_256        = \33750;
  33. # Start time of script in cs/256 since 1st January 1900.
  34. *start            = \($^T / 2.56 + $cs_1900to1970_256);
  35.  
  36. #$time2utc && $time2local && $standard_date_and_time;
  37. #__DATA__
  38.  
  39. sub time_age2cs {
  40.     return ($^T - $_[0] * $seconds_per_day + $s_1900to1970) * 100
  41.       unless wantarray;
  42.     map {  ($^T - $_    * $seconds_per_day + $s_1900to1970) * 100 } @_
  43. }
  44.  
  45. sub time_age2riscos {
  46.     my $temp;    # Remember subroutines are pass by reference, so assigning to
  47.         # $_[0] clobbers the caller's array.
  48.     unless (wantarray) {
  49.     $temp = $start - $_[0] * $cs_per_day_256;
  50.     return pack 'CV', ($temp - int $temp) * 256, $temp;
  51.     }
  52.     map {
  53.     $temp = $start - $_ * $cs_per_day_256;
  54.     pack 'CV', ($temp - int $temp) * 256, $temp;
  55.     } @_
  56. }
  57.  
  58. sub time_age2unix {
  59.     return pack 'I', ($^T - $_[0] * $seconds_per_day) unless wantarray;
  60.     map {  pack 'I', ($^T - $_      * $seconds_per_day) } @_
  61. }
  62.  
  63. sub time_cs2age {
  64.     return ($^T + $s_1900to1970 - $_[0] / 100) / $seconds_per_day
  65.       unless wantarray;
  66.     map {  ($^T + $s_1900to1970 - $_    / 100) / $seconds_per_day } @_
  67. }
  68.  
  69. sub time_cs2riscos {
  70.     # Inspection of pp.c reveals that % (ie pp_modulo) doesn't do doubles. :-(
  71.     my $temp;
  72.     unless (wantarray) {
  73.     $temp = int $_[0] / 256;
  74.     return pack 'CV', $_[0] - $temp * 256, $temp;
  75.     }
  76.     map {
  77.     $temp = int $_ / 256;
  78.     pack 'CV', $_ - $temp * 256, $temp;
  79.     } @_
  80. }
  81.  
  82. sub time_cs2unix {
  83.     return pack 'I', ($_[0] / 100 - $s_1900to1970) unless wantarray;
  84.     map {  pack 'I', ($_    / 100 - $s_1900to1970) } @_
  85. }
  86.  
  87. sub time_riscos2age {
  88.     # ord equivalent to unpack ('C'). Hence whole is unpack 'CV'
  89.     return ($start - ord ($_[0]) / 256 - unpack ('xV', $_[0])) / $cs_per_day_256    unless wantarray;
  90.     map {  ($start - ord ($_) / 256 - unpack ('xV', $_)) / $cs_per_day_256 } @_
  91. }
  92.  
  93. sub time_riscos2cs {
  94.     return ord ($_[0]) + 256 * unpack ('xV', $_[0]) unless wantarray;
  95.     map { ord ($_) + 256 * unpack ('xV', $_)} @_
  96. }
  97.  
  98. sub time_riscos2unix {
  99.     # Very odd conversion to want to make
  100.     time_cs2unix (&time_riscos2cs)
  101. }
  102.  
  103. sub time_unix2age {
  104.     return ($^T - unpack 'I', $_[0]) / $seconds_per_day unless wantarray;
  105.     map {  ($^T - unpack 'I', $_   ) / $seconds_per_day } @_
  106. }
  107.  
  108. sub time_unix2cs {
  109.     return 100 * ($s_1900to1970 + unpack 'I', $_[0]) unless wantarray;
  110.     map {  100 * ($s_1900to1970 + unpack 'I', $_[0]) } @_
  111. }
  112.  
  113. sub time_unix2riscos {
  114.     # Less odd conversion to want to make
  115.     time_cs2riscos (&time_unix2cs)
  116. }
  117.  
  118. sub _time_guess2riscos ($) {
  119.     return undef unless defined $_[0];
  120.     my $length = length $_[0];
  121.  
  122.     # String is an "age" if all the characters are numeric.
  123.     # count the non-numeric. Can't use tr on read only values. :-(
  124.     # OK. if we can match 1 non-numeric.
  125.     return &time_age2riscos unless ($_[0] =~ m/[^-\d.]/);
  126.     return $_[0] if ($length == 5);
  127.     return &time_unix2riscos if ($length == 4);
  128.     if ($length == 6 and $_[0] =~ /\0$/) {
  129.     # Sanity check that last character is "\0"
  130.     my $time = $_[0];
  131.     chop ($time);
  132.     return $time;
  133.     }
  134.     undef;
  135. }
  136.  
  137. sub time_guess2riscos {
  138.     return _time_guess2riscos ($_[0]) unless wantarray;
  139.     map {  _time_guess2riscos $_ } @_
  140. }
  141.  
  142. sub standard_date_and_time ($) {
  143.     my ($time) = $_[0];    # Don't shift
  144.     unless (defined $time and length ($time) == 5) {
  145.     $time = &_time_guess2riscos;    # Pass on @_
  146.     }
  147.  
  148.     my $buffer = 'x'x256;
  149.     return undef
  150.       unless defined $time and swix ($standard_date_and_time,
  151.                      $standard_date_and_time_mask,
  152.                      $time, $buffer, 256);
  153.     $buffer =~ /^([^\0]*)/;    # Everything until the first \0
  154.     $1;
  155. }
  156. sub time2_raw ($$;$) {
  157.     my ($swi, $time, $terr) = @_;
  158.     $terr = -1 unless defined $terr;    # Won't hurt for UTC call
  159.     unless (defined $time and length ($time) == 5) {
  160.     $time = &_time_guess2riscos ($time);
  161.     }
  162.  
  163.     my $buffer = 'x'x36;
  164.     return ()
  165.       unless defined $time
  166.      and defined swix ($swi, $time2_mask, $terr, $time, $buffer);
  167.     unpack 'I*', $buffer;
  168. }
  169.  
  170. sub fix_os {
  171.     return wantarray ? () : undef
  172.       unless my @raw = &time2_raw;    # Pass on @_
  173.     shift @raw;    # Loose centiseconds
  174.     $raw[4]--;    # Lots of bloody fiddly corrections from OS to ANSI
  175.     $raw[5] -= 1900;
  176.     $raw[6]--;
  177.     $raw[7]--;
  178.     @raw;
  179. }
  180.  
  181. sub time2utc ($) {
  182.     return () unless defined $_[0];
  183.     return (gmtime (unpack 'I', $_[0]))[0..7] if 4 == length $_[0];
  184.     (fix_os $time2utc, @_);    # Always list context
  185. }
  186.  
  187. sub time2local ($;$) {
  188.     croak "Can't yet convert territory $_[1]"
  189.       if defined $_[1] and -1 != $_[1];
  190.     return &standard_date_and_time unless wantarray;
  191.     return (localtime (unpack 'I', $_[0]))[0..7] if 4 == length $_[0];
  192.     fix_os $time2local, @_;
  193. }
  194.  
  195. $time2utc && $time2local && $standard_date_and_time;
  196. __END__
  197.  
  198. =head1 NAME
  199.  
  200. RISCOS::Time -- perl interface to S<RISC OS> time SWIs
  201.  
  202. =head1 SYNOPSIS
  203.  
  204.     use RISCOS::Time qw (time2utc time2local);
  205.     print 'symtable updated ', scalar time2local $time;
  206.     print 'script started ' . time2utc (0);    # Auto converts from "age"
  207.  
  208. =head1 DESCRIPTION
  209.  
  210. This module provides perl interface to the SWIs
  211. C<OS_ConvertStandardDateAndTime>, C<Territory_ConvertTimeToUTCOrdinals> and
  212. C<Territory_ConvertTimeToOrdinals> and functions to convert between different
  213. formats for storing time information.
  214.  
  215. Time formats currently understood are
  216.  
  217. =over 4
  218.  
  219. =item * numeric ages as returned by perl's C<-A>, C<-C> and C<-M> functions
  220.  
  221. =item 4 byte scalars - Unix times, seconds starting from 1st January 1970
  222.  
  223. =item 5 byte scalars - S<RISC OS> times, centiseconds starting from 1st January 1900
  224.  
  225. =item 6 byte scalars - S<RISC OS> times, as stored in C<ALF> files.
  226.  
  227. =back
  228.  
  229. Clearly it is not possible to automatically distinguish between all these
  230. formats so where guessing is necessary the following heuristics are used:
  231.  
  232. =over 4
  233.  
  234. =item *
  235.  
  236. If I<time> is composed soley of numeric characters (0-9, "-" and ".") then it
  237. is assumed to be an age in days since the time the script started running
  238. (see L<perlvar/$^T>). Clearly there is possible ambiguity with RISC OS 5 byte
  239. ages that happen to be eqactly 5 characters and composed of legal numeric
  240. characters. However the most recent 5 byte time which could be confused is
  241. C<"99999">, 23:17:53.85 on Friday 18th November 1977, which is likely to predate
  242. most stamped files by about a decade.
  243.  
  244. =item *
  245.  
  246. Otherwise C<if (length $time == 5)> then C<$time> is assumed to be a 5 byte RISC
  247. OS time, encoded as centiseconds since 1900/1/1.
  248.  
  249. =item *
  250.  
  251. C<if (length $time == 4)> then C<$time> is taken to be a 4 byte Unix time,
  252. seconds since 1970/1/1 C<pack>ed as C<'I'>.
  253.  
  254. =item *
  255.  
  256. C<if (length $time == 6)> then C<$time> is expected to be a 6 byte time as
  257. stored in C<ALF> files, also centiseconds since 1900/1/1. If the MSB is not 0
  258. the time is rejected, otherwise it is treated as the equivalent 5 byte RISC OS
  259. time.
  260.  
  261. =back
  262.  
  263. =head2 SWI interface
  264.  
  265. As the SWI interface functions are expect to be used with native times if
  266. C<length $time == 5> then it is taken as a RISC OS time, taking priority over
  267. the guessing heuristic.
  268.  
  269. =over 4
  270.  
  271. =item standard_date_and_time <time>
  272.  
  273. calls C<OS_ConvertStandardDateAndTime> for I<time>, returning the string
  274. representation of that time for the local timezone (the format being set by
  275. C<<Sys$DateFormatE<gt>>). 
  276.  
  277. =item time2utc <time>
  278.  
  279. calls C<Territory_ConvertTimeToUTCOrdinals> for I<time>, returning an array of
  280. integers, adjusted to be consistent with the return array from C<gmtime>.
  281.  
  282.     #  0    1    2     3     4    5     6     7
  283.     ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = time2utc($time);
  284.  
  285. In particular this means that C<$mon> has the range 0..11 and C<$wday> has
  286. the range 0..6 with Sunday as day 0.  B<Note> C<$year> is the number of
  287. years since 1900, B<not> simply the last two digits of the year.
  288. If C<length $time == 4> calls C<gmtime> directly, but drops the 9th element
  289. ("is daylight saving time").
  290.  
  291. =item time2local <time> [, <territory>]
  292.  
  293. calls C<Territory_ConvertTimeToOrdinals> for I<time> to convert to local times.
  294. In scalar context behaves as a call to C<standard_date_and_time>, in array
  295. context returns an array as described in C<time2utc>. If C<length $time == 4>
  296. calls C<localtime> directly. I<territory> defaults to C<-1> - the current
  297. territory.
  298.  
  299. Support for territories other than C<-1> (the current territory) is rather
  300. limited - currently territories may only be used in array context and must be
  301. specified by number only, rather than name. Calls in scalar context may only use
  302. the current territory. (Otherwise the script C<die>s with an error).
  303.  
  304. =item time2_raw <swi_number>, <time> [, <territory>]
  305.  
  306. calls the supplied SWI (which is expected to be
  307. C<Territory_ConvertTimeToUTCOrdinals> or C<Territory_ConvertTimeToOrdinals>) and
  308. returns an array of integers
  309.  
  310.     #  0     1    2     3     4    5    6     7    8
  311.     ($csec,$sec,$min,$hour,$mday,$mon,$year,$wday,$yday)
  312.  
  313. where the ranges for C<$mon>, C<$wday> and C<$yday> run from B<1> upwards
  314. (I<c.f.> B<0> upwards for the other subroutines and the perl builtins) and
  315. C<$year> is the full Gregorian year (rather then the number of years since
  316. 1900).
  317.  
  318. =back
  319.  
  320. Values are returned consistent with ANSI C and perl's idea of the base values
  321. for days of the week, days of the year I<etc.> from C<time2utc> and
  322. C<time2local> - the native RISC OS values are available from C<time2_raw>.
  323.  
  324. =head2 Conversion functions
  325.  
  326. 13 functions are provided to convert between different time formats. In scalar
  327. context all convert only the first argument, in list context a list of
  328. conversions corresponding to the argument list.
  329.  
  330. =over 4
  331.  
  332. =item time_guess2riscos
  333.  
  334. Each argument is processed according to the guessing heuristics to determine
  335. which conversion to use.
  336.  
  337. =item time_age2cs
  338.  
  339. =item time_age2riscos
  340.  
  341. =item time_age2unix
  342.  
  343. =item time_cs2age
  344.  
  345. =item time_cs2riscos
  346.  
  347. =item time_cs2unix
  348.  
  349. =item time_riscos2age
  350.  
  351. =item time_riscos2cs
  352.  
  353. =item time_riscos2unix
  354.  
  355. =item time_unix2age
  356.  
  357. =item time_unix2cs
  358.  
  359. =item time_unix2riscos
  360.  
  361. Arguments are converted from the first named format to the second, where formats
  362. are
  363.  
  364. =over 4
  365.  
  366. =item age
  367.  
  368. numeric ages as returned by perl's C<-A>, C<-C> and C<-M> functions (see
  369. L<perlfunc/-X>)in days since the script start time (C<$^T>).
  370.  
  371. =item cs
  372.  
  373. centiseconds since 1900/1/1 expressed as a number.
  374.  
  375. =item riscos
  376.  
  377. centiseconds since 1900/1/1 packed as 5 bytes.
  378.  
  379. =item unix
  380.  
  381. seconds since 1970/1/1 packed as 4 bytes.
  382.  
  383. =back
  384.  
  385. =back
  386.  
  387. =head2 Constants
  388.  
  389. C<RISCOS::Time> is able to export these "useful" constants:
  390.  
  391. =over 4
  392.  
  393. =item $s_1900to1970
  394.  
  395. C<2208988800>, the number of seconds between Janaury 1st 1900 and 1970.
  396.  
  397. =item $seconds_per_day
  398.  
  399. C<86400>, the number of seconds in a day.
  400.  
  401. =back
  402.  
  403. =head1 BUGS
  404.  
  405. Support for territories other than the current territory is very limited. It
  406. might help if Acorn supplied more than one territory on the standard UK machine.
  407.  
  408. =head1 AUTHOR
  409.  
  410. Nicholas Clark <F<nick@unfortu.net>>
  411.  
  412. =cut
  413.