1047f369cypackage NTP::Util;
2047f369cyuse strict;
3047f369cyuse warnings;
4047f369cyuse Exporter 'import';
5047f369cyuse Carp;
6047f369cyuse version 0.77;
7047f369cy
8047f369cyour @EXPORT_OK = qw(ntp_read_vars do_dns ntp_peers ntp_sntp_line);
9047f369cy
10047f369cymy $ntpq_path = 'ntpq';
11047f369cymy $sntp_path = 'sntp';
12047f369cy
13047f369cyour $IP_AGNOSTIC;
14047f369cy
15047f369cyBEGIN {
16047f369cy    require Socket;
17047f369cy    if (version->parse($Socket::VERSION) >= version->parse(1.94)) {
18047f369cy        Socket->import(qw(getaddrinfo getnameinfo SOCK_RAW AF_INET));
19047f369cy        $IP_AGNOSTIC = 1;
20047f369cy    }
21047f369cy    else {
22047f369cy        Socket->import(qw(inet_aton SOCK_RAW AF_INET));
23047f369cy    }
24047f369cy}
25047f369cy
26047f369cymy %obsolete_vars = (
27047f369cy    phase          => 'offset',
28047f369cy    rootdispersion => 'rootdisp',
29047f369cy);
30047f369cy
31047f369cysub ntp_read_vars {
32047f369cy    my ($peer, $vars, $host) = @_;
33047f369cy    my $do_all   = !@$vars;
34047f369cy    my %out_vars = map {; $_ => undef } @$vars;
35047f369cy
36047f369cy    $out_vars{status_line} = {} if $do_all;
37047f369cy
38047f369cy    my $cmd = "$ntpq_path -n -c 'rv $peer ".(join ',', @$vars)."'";
39047f369cy    $cmd .= " $host" if defined $host;
40047f369cy    $cmd .= " |";
41047f369cy
42047f369cy    open my $fh, $cmd or croak "Could not start ntpq: $!";
43047f369cy
44047f369cy    while (<$fh>) {
45047f369cy        return undef if /Connection refused/;
46047f369cy
47047f369cy        if (/^asso?c?id=0 status=(\S{4}) (\S+), (\S+),/gi) {
48047f369cy            $out_vars{status_line}{status} = $1;
49047f369cy            $out_vars{status_line}{leap}   = $2;
50047f369cy            $out_vars{status_line}{sync}   = $3;
51047f369cy        }
52047f369cy
53047f369cy        while (/(\w+)=([^,]+),?\s/g) {
54047f369cy            my ($var, $val) = ($1, $2);
55047f369cy            $val =~ s/^"([^"]+)"$/$1/;
56047f369cy            $var = $obsolete_vars{$var} if exists $obsolete_vars{$var};
57047f369cy            if ($do_all) {
58047f369cy                $out_vars{$var} = $val
59047f369cy            }
60047f369cy            else {
61047f369cy                $out_vars{$var} = $val if exists $out_vars{$var};
62047f369cy            }
63047f369cy        }
64047f369cy    }
65047f369cy
66047f369cy    close $fh or croak "running ntpq failed: $! (exit status $?)";
67047f369cy    return \%out_vars;
68047f369cy}
69047f369cy
70047f369cysub do_dns {
71047f369cy    my ($host) = @_;
72047f369cy
73047f369cy    if ($IP_AGNOSTIC) {
74047f369cy        my ($err, $res);
75047f369cy
76047f369cy        ($err, $res) = getaddrinfo($host, '', {socktype => SOCK_RAW});
77047f369cy        die "getaddrinfo failed: $err\n" if $err;
78047f369cy
79047f369cy        ($err, $res) = getnameinfo($res->{addr}, 0);
80047f369cy        die "getnameinfo failed: $err\n" if $err;
81047f369cy
82047f369cy        return $res;
83047f369cy    }
84047f369cy    # Too old perl, do only ipv4
85047f369cy    elsif ($host =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/) {
86047f369cy        return gethostbyaddr inet_aton($host), AF_INET;
87047f369cy    }
88047f369cy    else {
89047f369cy        return;
90047f369cy    }
91047f369cy}
92047f369cy
93047f369cysub ntp_peers {
94047f369cy    my ($host) = @_;
95047f369cy
96f63afe2cy    $host ||= '';
97f63afe2cy    my $cmd = "$ntpq_path -npw $host |";
98047f369cy
99047f369cy    open my $fh, $cmd or croak "Could not start ntpq: $!";
100047f369cy
101047f369cy    <$fh> for 1 .. 2;
102047f369cy
103f63afe2cy    my @columns = qw(tally host refid st t when poll reach delay offset jitter);
104047f369cy    my @peers;
105047f369cy    while (<$fh>) {
106f63afe2cy        if (/^([ x+#*o-])((?:[\w.*:-]+\s+){10}|([\w.*:-]+\s+))$/) {
107047f369cy            my $col = 0;
108f63afe2cy	    my @line = ($1, split /\s+/, $2);
109f63afe2cy	    if( @line == 2 ) {
110f63afe2cy		defined ($_ = <$fh>) or last;
111f63afe2cy		s/^\s+//;
112f63afe2cy		push @line, split /\s+/;
113f63afe2cy	    }
114f63afe2cy	    my $r = { map {; $columns[ $col++ ] => $_ } @line };
115f63afe2cy	    $r->{remote} = $r->{tally} . $r->{host};
116f63afe2cy            push @peers, $r;
117047f369cy        }
118047f369cy        else {
119047f369cy            #TODO return error (but not needed anywhere now)
120047f369cy            warn "ERROR: $_";
121047f369cy        }
122047f369cy    }
123047f369cy
124047f369cy    close $fh or croak "running ntpq failed: $! (exit status $?)";
125047f369cy    return \@peers;
126047f369cy}
127047f369cy
128047f369cy# TODO: we don't need this but it would be nice to have all the line parsed
129047f369cysub ntp_sntp_line {
130047f369cy    my ($host) = @_;
131047f369cy
132047f369cy    my $cmd = "$sntp_path $host |";
133047f369cy    open my $fh, $cmd or croak "Could not start sntp: $!";
134047f369cy
135047f369cy    my ($offset, $stratum);
136047f369cy    while (<$fh>) {
137047f369cy        next if !/^\d{4}-\d\d-\d\d/;
138047f369cy        chomp;
139047f369cy        my @output = split / /;
140047f369cy
141047f369cy        $offset = $output[3];
142aae1e7dglebius	if (0) {
143aae1e7dglebius	} elsif ($output[7] =~ /s(\d{1,2})/) {
144aae1e7dglebius		$stratum = $1;
145aae1e7dglebius		# warn "Found stratum at #7\n";
146aae1e7dglebius	} elsif ($output[8] =~ /s(\d{1,2})/) {
147aae1e7dglebius		$stratum = $1;
148aae1e7dglebius		# warn "Found stratum at #8\n";
149aae1e7dglebius	}
150047f369cy    }
151047f369cy    close $fh or croak "running sntp failed: $! (exit status $?)";
152047f369cy    return ($offset, $stratum);
153047f369cy}
154f63afe2cy
155f63afe2cy1;
156