cpan/libnet/lib/Net/Time.pm

   1 # Net::Time.pm
   2 #
   3 # Versions up to 2.10 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>.
   4 # All rights reserved.
   5 # Changes in Version 2.11 onwards Copyright (C) 2014 Steve Hay.  All rights
   6 # reserved.
   7 # This module is free software; you can redistribute it and/or modify it under
   8 # the same terms as Perl itself, i.e. under the terms of either the GNU General
   9 # Public License or the Artistic License, as specified in the F<LICENCE> file.
  10
  11 package Net::Time;
  12
  13 use 5.008001;
  14
  15 use strict;
  16 use warnings;
  17
  18 use Carp;
  19 use Exporter;
  20 use IO::Select;
  21 use IO::Socket;
  22 use Net::Config;
  23
  24 our @ISA       = qw(Exporter);
  25 our @EXPORT_OK = qw(inet_time inet_daytime);
  26
  27 our $VERSION = "3.08";
  28
  29 our $TIMEOUT = 120;
  30
  31 sub _socket {
  32   my ($pname, $pnum, $host, $proto, $timeout) = @_;
  33
  34   $proto ||= 'udp';
  35
  36   my $port = (getservbyname($pname, $proto))[2] || $pnum;
  37
  38   my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
  39
  40   my $me;
  41
  42   foreach my $addr (@$hosts) {
  43     $me = IO::Socket::INET->new(
  44       PeerAddr => $addr,
  45       PeerPort => $port,
  46       Proto    => $proto
  47       )
  48       and last;
  49   }
  50
  51   return unless $me;
  52
  53   $me->send("\n")
  54     if $proto eq 'udp';
  55
  56   $timeout = $TIMEOUT
  57     unless defined $timeout;
  58
  59   IO::Select->new($me)->can_read($timeout)
  60     ? $me
  61     : undef;
  62 }
  63
  64
  65 sub inet_time {
  66   my $s      = _socket('time', 37, @_) || return;
  67   my $buf    = '';
  68   my $offset = 0 | 0;
  69
  70   return
  71     unless defined $s->recv($buf, length(pack("N", 0)));
  72
  73   # unpack, we | 0 to ensure we have an unsigned
  74   my $time = (unpack("N", $buf))[0] | 0;
  75
  76   # the time protocol return time in seconds since 1900, convert
  77   # it to a the required format
  78
  79   if ($^O eq "MacOS") {
  80
  81     # MacOS return seconds since 1904, 1900 was not a leap year.
  82     $offset = (4 * 31536000) | 0;
  83   }
  84   else {
  85
  86     # otherwise return seconds since 1972, there were 17 leap years between
  87     # 1900 and 1972
  88     $offset = (70 * 31536000 + 17 * 86400) | 0;
  89   }
  90
  91   $time - $offset;
  92 }
  93
  94
  95 sub inet_daytime {
  96   my $s   = _socket('daytime', 13, @_) || return;
  97   my $buf = '';
  98
  99   defined($s->recv($buf, 1024))
 100     ? $buf
 101     : undef;
 102 }
 103
 104 1;
 105
 106 __END__
 107
 108 =head1 NAME
 109
 110 Net::Time - time and daytime network client interface
 111
 112 =head1 SYNOPSIS
 113
 114     use Net::Time qw(inet_time inet_daytime);
 115
 116     print inet_time();          # use default host from Net::Config
 117     print inet_time('localhost');
 118     print inet_time('localhost', 'tcp');
 119
 120     print inet_daytime();       # use default host from Net::Config
 121     print inet_daytime('localhost');
 122     print inet_daytime('localhost', 'tcp');
 123
 124 =head1 DESCRIPTION
 125
 126 C<Net::Time> provides subroutines that obtain the time on a remote machine.
 127
 128 =over 4
 129
 130 =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
 131
 132 Obtain the time on C<HOST>, or some default host if C<HOST> is not given
 133 or not defined, using the protocol as defined in RFC868. The optional
 134 argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
 135 C<udp>. The result will be a time value in the same units as returned
 136 by time() or I<undef> upon failure.
 137
 138 =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
 139
 140 Obtain the time on C<HOST>, or some default host if C<HOST> is not given
 141 or not defined, using the protocol as defined in RFC867. The optional
 142 argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
 143 C<udp>. The result will be an ASCII string or I<undef> upon failure.
 144
 145 =back
 146
 147 =head1 AUTHOR
 148
 149 Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
 150
 151 Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
 152 1.22_02
 153
 154 =head1 COPYRIGHT
 155
 156 Versions up to 2.11 Copyright (c) 1995-2004 Graham Barr. All rights reserved.
 157 Changes in Version 2.11 onwards Copyright (C) 2014 Steve Hay.  All rights
 158 reserved.
 159
 160 This module is free software; you can redistribute it and/or modify it under the
 161 same terms as Perl itself, i.e. under the terms of either the GNU General Public
 162 License or the Artistic License, as specified in the F<LICENCE> file.
 163
 164 =cut