Commit | Line | Data |
---|---|---|
406c51ee JH |
1 | # Net::Time.pm |
2 | # | |
2e173144 CBW |
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. | |
a4f8ff46 SH |
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. | |
406c51ee JH |
10 | |
11 | package Net::Time; | |
12 | ||
2e173144 CBW |
13 | use 5.008001; |
14 | ||
406c51ee | 15 | use strict; |
2e173144 CBW |
16 | use warnings; |
17 | ||
406c51ee | 18 | use Carp; |
2e173144 CBW |
19 | use Exporter; |
20 | use IO::Select; | |
406c51ee | 21 | use IO::Socket; |
406c51ee | 22 | use Net::Config; |
406c51ee | 23 | |
2e173144 CBW |
24 | our @ISA = qw(Exporter); |
25 | our @EXPORT_OK = qw(inet_time inet_daytime); | |
406c51ee | 26 | |
db956464 | 27 | our $VERSION = "3.07"; |
406c51ee | 28 | |
2e173144 | 29 | our $TIMEOUT = 120; |
406c51ee | 30 | |
b3f6f6a6 RGS |
31 | sub _socket { |
32 | my ($pname, $pnum, $host, $proto, $timeout) = @_; | |
406c51ee | 33 | |
b3f6f6a6 | 34 | $proto ||= 'udp'; |
406c51ee | 35 | |
b3f6f6a6 | 36 | my $port = (getservbyname($pname, $proto))[2] || $pnum; |
406c51ee | 37 | |
b3f6f6a6 | 38 | my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'}; |
406c51ee | 39 | |
b3f6f6a6 RGS |
40 | my $me; |
41 | ||
2e173144 | 42 | foreach my $addr (@$hosts) { |
b3f6f6a6 | 43 | $me = IO::Socket::INET->new( |
2e173144 | 44 | PeerAddr => $addr, |
b3f6f6a6 RGS |
45 | PeerPort => $port, |
46 | Proto => $proto | |
47 | ) | |
48 | and last; | |
406c51ee JH |
49 | } |
50 | ||
b3f6f6a6 | 51 | return unless $me; |
406c51ee | 52 | |
b3f6f6a6 RGS |
53 | $me->send("\n") |
54 | if $proto eq 'udp'; | |
406c51ee | 55 | |
b3f6f6a6 RGS |
56 | $timeout = $TIMEOUT |
57 | unless defined $timeout; | |
406c51ee | 58 | |
b3f6f6a6 RGS |
59 | IO::Select->new($me)->can_read($timeout) |
60 | ? $me | |
61 | : undef; | |
406c51ee JH |
62 | } |
63 | ||
406c51ee | 64 | |
b3f6f6a6 | 65 | sub inet_time { |
2e173144 | 66 | my $s = _socket('time', 37, @_) || return; |
b3f6f6a6 RGS |
67 | my $buf = ''; |
68 | my $offset = 0 | 0; | |
69 | ||
2e173144 | 70 | return |
b3f6f6a6 | 71 | unless defined $s->recv($buf, length(pack("N", 0))); |
406c51ee | 72 | |
b3f6f6a6 RGS |
73 | # unpack, we | 0 to ensure we have an unsigned |
74 | my $time = (unpack("N", $buf))[0] | 0; | |
406c51ee | 75 | |
b3f6f6a6 RGS |
76 | # the time protocol return time in seconds since 1900, convert |
77 | # it to a the required format | |
406c51ee | 78 | |
b3f6f6a6 RGS |
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 { | |
406c51ee | 85 | |
b3f6f6a6 RGS |
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; | |
406c51ee JH |
92 | } |
93 | ||
406c51ee | 94 | |
b3f6f6a6 | 95 | sub inet_daytime { |
2e173144 | 96 | my $s = _socket('daytime', 13, @_) || return; |
b3f6f6a6 RGS |
97 | my $buf = ''; |
98 | ||
99 | defined($s->recv($buf, 1024)) | |
100 | ? $buf | |
101 | : undef; | |
406c51ee JH |
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); | |
686337f3 | 115 | |
5abafd4c | 116 | print inet_time(); # use default host from Net::Config |
406c51ee JH |
117 | print inet_time('localhost'); |
118 | print inet_time('localhost', 'tcp'); | |
686337f3 | 119 | |
5abafd4c | 120 | print inet_daytime(); # use default host from Net::Config |
406c51ee JH |
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 | ||
2e173144 CBW |
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 | |
406c51ee JH |
153 | |
154 | =head1 COPYRIGHT | |
155 | ||
2e173144 CBW |
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 | ||
a4f8ff46 SH |
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. | |
406c51ee JH |
163 | |
164 | =cut |