home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / Net / Time.pm < prev   
Encoding:
Perl POD Document  |  2002-06-19  |  3.5 KB  |  152 lines
  1. # Net::Time.pm
  2. #
  3. # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.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 = "2.09"; # $Id: //depot/libnet/Net/Time.pm#9 $
  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.  return unless $me;
  45.  
  46.  $me->send("\n")
  47.     if $proto eq 'udp';
  48.  
  49.  $timeout = $TIMEOUT
  50.     unless defined $timeout;
  51.  
  52.  IO::Select->new($me)->can_read($timeout)
  53.     ? $me
  54.     : undef;
  55. }
  56.  
  57. sub inet_time
  58. {
  59.  my $s = _socket('time',37,@_) || return undef;
  60.  my $buf = '';
  61.  my $offset = 0 | 0;
  62.  
  63.  return undef
  64.     unless $s->recv($buf, length(pack("N",0)));
  65.  
  66.  # unpack, we | 0 to ensure we have an unsigned
  67.  my $time = (unpack("N",$buf))[0] | 0;
  68.  
  69.  # the time protocol return time in seconds since 1900, convert
  70.  # it to a the required format
  71.  
  72.  if($^O eq "MacOS") {
  73.    # MacOS return seconds since 1904, 1900 was not a leap year.
  74.    $offset = (4 * 31536000) | 0;
  75.  }
  76.  else {
  77.    # otherwise return seconds since 1972, there were 17 leap years between
  78.    # 1900 and 1972
  79.    $offset =  (70 * 31536000 + 17 * 86400) | 0;
  80.  }
  81.  
  82.  $time - $offset;
  83. }
  84.  
  85. sub inet_daytime
  86. {
  87.  my $s = _socket('daytime',13,@_) || return undef;
  88.  my $buf = '';
  89.  
  90.  $s->recv($buf, 1024) ? $buf
  91.                       : undef;
  92. }
  93.  
  94. 1;
  95.  
  96. __END__
  97.  
  98. =head1 NAME
  99.  
  100. Net::Time - time and daytime network client interface
  101.  
  102. =head1 SYNOPSIS
  103.  
  104.     use Net::Time qw(inet_time inet_daytime);
  105.  
  106.     print inet_time();        # use default host from Net::Config
  107.     print inet_time('localhost');
  108.     print inet_time('localhost', 'tcp');
  109.  
  110.     print inet_daytime();    # use default host from Net::Config
  111.     print inet_daytime('localhost');
  112.     print inet_daytime('localhost', 'tcp');
  113.  
  114. =head1 DESCRIPTION
  115.  
  116. C<Net::Time> provides subroutines that obtain the time on a remote machine.
  117.  
  118. =over 4
  119.  
  120. =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
  121.  
  122. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  123. or not defined, using the protocol as defined in RFC868. The optional
  124. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  125. C<udp>. The result will be a time value in the same units as returned
  126. by time() or I<undef> upon failure.
  127.  
  128. =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
  129.  
  130. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  131. or not defined, using the protocol as defined in RFC867. The optional
  132. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  133. C<udp>. The result will be an ASCII string or I<undef> upon failure.
  134.  
  135. =back
  136.  
  137. =head1 AUTHOR
  138.  
  139. Graham Barr <gbarr@pobox.com>
  140.  
  141. =head1 COPYRIGHT
  142.  
  143. Copyright (c) 1995-1998 Graham Barr. All rights reserved.
  144. This program is free software; you can redistribute it and/or modify
  145. it under the same terms as Perl itself.
  146.  
  147. =for html <hr>
  148.  
  149. I<$Id: //depot/libnet/Net/Time.pm#9 $>
  150.  
  151. =cut
  152.