home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / Net / Time.pm < prev   
Text File  |  1997-11-18  |  3KB  |  141 lines
  1. # Net::Time.pm
  2. #
  3. # Copyright (c) 1995-1997 Graham Barr <gbarr@ti.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package Net::Time;
  8.  
  9. use strict;
  10. use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
  11. use Carp;
  12. use IO::Socket;
  13. require Exporter;
  14. use Net::Config;
  15. use IO::Select;
  16.  
  17. @ISA = qw(Exporter);
  18. @EXPORT_OK = qw(inet_time inet_daytime);
  19.  
  20. $VERSION = do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
  21.  
  22. $TIMEOUT = 120;
  23.  
  24. sub _socket
  25. {
  26.  my($pname,$pnum,$host,$proto,$timeout) = @_;
  27.  
  28.  $proto ||= 'udp';
  29.  
  30.  my $port = (getservbyname($pname, $proto))[2] || $pnum;
  31.  
  32.  my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};
  33.  
  34.  my $me;
  35.  
  36.  foreach $host (@$hosts)
  37.   {
  38.    $me = IO::Socket::INET->new(PeerAddr => $host,
  39.                                PeerPort => $port,
  40.                                Proto    => $proto
  41.                               ) and last;
  42.   }
  43.  
  44.  $me->send("\n")
  45.     if(defined $me && $proto eq 'udp');
  46.  
  47.  $timeout = $TIMEOUT
  48.     unless defined $timeout;
  49.  
  50.  IO::Select->new($me)->can_read($timeout)
  51.     ? $me
  52.     : undef;
  53. }
  54.  
  55. sub inet_time
  56. {
  57.  my $s = _socket('time',37,@_) || return undef;
  58.  my $buf = '';
  59.  
  60.  # the time protocol return time in seconds since 1900, convert
  61.  # it to a unix time (seconds since 1970)
  62.  if($^O eq "MacOS") {
  63.  #on a Macintosh, return seconds since 1904, the beginning of time on a Mac
  64.  #note that 1900 was not a leap year
  65.  $s->recv($buf, length(pack("N",0)))
  66.         ? (unpack("N",$buf))[0] -  4 * 31536000
  67.     : undef;
  68.  } else {
  69.  # 2208988800 = 70 * 3153600 + 17 * 86400, since there are 17 leap days from
  70.  # 1900 to 1970
  71.  
  72.  $s->recv($buf, length(pack("N",0)))
  73.     ? (unpack("N",$buf))[0] - 2208988800
  74.     : undef;
  75.  }
  76. }
  77.  
  78. sub inet_daytime
  79. {
  80.  my $s = _socket('daytime',13,@_) || return undef;
  81.  my $buf = '';
  82.  
  83.  $s->recv($buf, 1024) ? $buf
  84.                       : undef;
  85. }
  86.  
  87. 1;
  88.  
  89. __END__
  90.  
  91. =head1 NAME
  92.  
  93. Net::Time - time and daytime network client interface
  94.  
  95. =head1 SYNOPSIS
  96.  
  97.     use Net::Time qw(inet_time inet_daytime);
  98.     
  99.     print inet_time();        # use default host from Net::Config
  100.     print inet_time('localhost');
  101.     print inet_time('localhost', 'tcp');
  102.     
  103.     print inet_daytime();    # use default host from Net::Config
  104.     print inet_daytime('localhost');
  105.     print inet_daytime('localhost', 'tcp');
  106.  
  107. =head1 DESCRIPTION
  108.  
  109. C<Net::Time> provides subroutines that obtain the time on a remote machine.
  110.  
  111. =over 4
  112.  
  113. =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
  114.  
  115. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  116. or not defined, using the protocol as defined in RFC868. The optional
  117. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  118. C<udp>. The result will be a unix-like time value or I<undef> upon
  119. failure.
  120.  
  121. =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
  122.  
  123. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  124. or not defined, using the protocol as defined in RFC867. The optional
  125. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  126. C<udp>. The result will be an ASCII string or I<undef> upon failure.
  127.  
  128. =back
  129.  
  130. =head1 AUTHOR
  131.  
  132. Graham Barr <gbarr@ti.com>
  133.  
  134. =head1 COPYRIGHT
  135.  
  136. Copyright (c) 1995-1997 Graham Barr. All rights reserved.
  137. This program is free software; you can redistribute it and/or modify
  138. it under the same terms as Perl itself.
  139.  
  140. =cut
  141.