[Summary view] [Print] [Text view]

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