Commit | Line | Data |
---|---|---|
406c51ee JH |
1 | # Net::Time.pm |
2 | # | |
f92f3fcb | 3 | # Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. |
406c51ee JH |
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 | ||
f92f3fcb | 20 | $VERSION = "2.10"; |
406c51ee JH |
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 | |
f92f3fcb | 64 | unless defined $s->recv($buf, length(pack("N",0))); |
406c51ee JH |
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 | ||
f92f3fcb | 90 | defined($s->recv($buf, 1024)) ? $buf |
406c51ee JH |
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); | |
686337f3 | 105 | |
406c51ee JH |
106 | print inet_time(); # use default host from Net::Config |
107 | print inet_time('localhost'); | |
108 | print inet_time('localhost', 'tcp'); | |
686337f3 | 109 | |
406c51ee JH |
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 | ||
f92f3fcb | 143 | Copyright (c) 1995-2004 Graham Barr. All rights reserved. |
406c51ee JH |
144 | This program is free software; you can redistribute it and/or modify |
145 | it under the same terms as Perl itself. | |
146 | ||
147 | =cut |