Please visit our sponsor
<![CDATA[UNKNOWN
=**************************************
= Name: Set Windows clock from NTP server
= Description:This Perl script uses SNTP (Simple Network Time Protocol, RFC 2030)
to get the time from an NTP server and set the Windows clock.
It can be used interactively or from a scheduler, and can produce
output to a log file and/or the Windows NT Event log.
= By: Found on the World Wide Web
=
=
= Inputs:None
=
= Returns:None
=
=Assumes:None
=
=Side Effects:None
=**************************************
=head1 NAME
winsntp 0.34 - Simple Network Time Protocol client for Windows
=cut
# Check time on a time server, and optionally correct Windows time.
# Configuration can be in a separate file. See POD documentation at end
# This is Win32 only (not needed on Unix anyway, there are other tools)
# Milivoj Ivkovic <mi@alma.ch>, 10.9.99
my $VERSION = 0.34;
# variables defined in .cfg file
use vars qw(@timehosts
$interactive
$verbosity
$debug
$use_NT_Eventlog
$force_log
$logfile
$max_net_lag
$max_diff
$num_samples
$timeout
$max_errors
$set_time
);
use IO::Socket;
use Win32::API;
use Time::Local;
use strict;
$SIG{__DIE__} = \&Die;
$SIG{__WARN__} = \&Warn;
# get configuration
my $config_file;
if (@ARGV) {
# if we have an argument, it's a config file
$config_file = shift;
die "Configuration file '$config_file' not found. Aborting.\n" unless -f $config_file;
}
else {
$config_file = "$0.cfg";
}
my $got_config = eval {require $config_file};
# defaults for variables if not defined in config file, or no config file found
@timehosts = qw(swisstime.ethz.ch bernina.ethz.ch ntp.univ-lyon1.fr)
unless defined @timehosts;
$interactive = 1 unless defined $interactive;
$verbosity = 3 unless defined $verbosity;
$debug = 0 unless defined $debug;
$use_NT_Eventlog = 1 unless defined $use_NT_Eventlog;
$force_log = 0 unless defined $force_log; # if not $interactive, logs anyway. This forces log to file
$logfile = $0 . ".log" unless defined $logfile;
$max_net_lag = 1000 unless defined $max_net_lag; # max time of net round-trip in ms.
$max_diff = 86400 unless defined $max_diff; # max believable difference in seconds. (86400=1day)
$num_samples = 3 unless defined $num_samples; # how many time samples to get to choose from
$timeout = 2 unless defined $timeout; # in seconds
$max_errors = 10 unless defined $max_errors;
$set_time = 1 unless defined $set_time; # do set the time?
# Initialize Win32::API calls we will need, and other stuff
my $GetSystemTime = new Win32::API("kernel32", 'GetSystemTime', ['P'], 'V');
my $SetSystemTime = new Win32::API("kernel32", 'SetSystemTime', ['P'], 'N');
my $GetCurrentProcess = new Win32::API("kernel32", 'GetCurrentProcess', ['V'], 'N');
my $GetPriorityClass = new Win32::API("kernel32", 'GetPriorityClass', ['N'], 'N');
my $SetPriorityClass = new Win32::API("kernel32", 'SetPriorityClass', ['N', 'N'], 'N');
my $process = $GetCurrentProcess->Call() or die "Can't get process handle ($^E)\n";
my $priority = $GetPriorityClass->Call($process);
$use_NT_Eventlog &&= Win32::IsWinNT;
if ($use_NT_Eventlog) {
eval "use Win32::EventLog;";
$use_NT_Eventlog &&= !$@;
warn "Cannot use Win32::Eventlog ($@)\n" if $@;
}
my %EventInfo = ();
# define a few subs
sub Log {
my $level = shift;
if ($debug or ($verbosity + $interactive >= $level)) {
if ($interactive) {
print @_;
}
if ($force_log or not $interactive) {
open(LOG, ">>$logfile") || warn "Cannot open $logfile for writing ($!)\n";
print LOG scalar(localtime), " ", @_;
close LOG;
}
if ($use_NT_Eventlog) {
$EventInfo{'Strings'} .= join('', @_);
}
}
}
sub Warn {
if ($force_log or not $interactive) {
Log 0, "warning: ", @_;
} else {
warn @_;
}
if ($use_NT_Eventlog) {
$EventInfo{'Strings'} .= join('', @_);
eval '$EventInfo{"EventType"} = EVENTLOG_WARNING_TYPE;';
}
}
sub Die {
if (defined $^S) {
if ($force_log or not $interactive) {
Log 0, "Fatal error: ", @_, "\n";
}
if ($use_NT_Eventlog) {
$EventInfo{'Strings'} .= join('', @_);
eval '$EventInfo{"EventType"} = EVENTLOG_ERROR_TYPE;';
}
}
die @_, "-"x40, "\n";
}
# This does all the work to get one sample from one host
sub get_sample {
my $host = shift;
my ($ntp_msg, $sock, $rin, $rout, $eout);
my ($LIVNMode, $Stratum, $Poll, $Precision,
$RootDelay, $RootDispersion, $RefIdentifier,
$Reference, $ReferenceF, $Original, $OriginalF,
$Receive, $ReceiveF, $Transmit, $TransmitF);
my ($SetPriority);
my ($WT1, $WT2, $send_time, $win_time,
$year, $mon, $wday, $mday, $hour, $min, $sec, $ms);
sub bintofrac {
my @digits = split '', shift;
my $f = 0;
while ( @digits ) {
$f = ( $f + pop @digits)/2;
}
$f;
}
$WT1 = $WT2 = "\0" x 16; # initialize struct for Win. Get...Time
# initialize ntp message (ignoring Originate Timestamp)
$ntp_msg = pack("B8 C3 N11", '00001011', (0)x14);
Log 5, "Asking $host...\n";
$sock = IO::Socket::INET->new(Proto => 'udp', PeerPort => 123,
LocalPort => 123, PeerAddr => $host,
Timeout => $timeout)
or do {warn "Cannot contact $host\n"; return undef};
Log 7, "Raising priority from $priority to 128\n";
$SetPriority = $SetPriorityClass->Call($process, 128)
or die "Couldn't set priority ($^E)\n";
$GetSystemTime->Call($WT1);
$sock->send($ntp_msg) or return undef;
vec($rin, fileno($sock), 1) = 1;
select($rout=$rin, undef, $eout=$rin, $timeout)
or do {Log 6, "No answer from $host\n"; return undef};
$sock->recv($ntp_msg, length($ntp_msg))
or do {warn "Receive error from $host ($!)\n"; return undef};
$GetSystemTime->Call($WT2);
$SetPriority = $SetPriorityClass->Call($process, $priority)
or die "Couldn't set priority back to $priority ($^E)\n";
($LIVNMode, $Stratum, $Poll, $Precision,
$RootDelay, $RootDispersion, $RefIdentifier,
$Reference, $ReferenceF, $Original, $OriginalF,
$Receive, $ReceiveF, $Transmit, $TransmitF)
= unpack "a C3 N8 B32 N B32", $ntp_msg;
my $LI = vec($LIVNMode, 3, 2);
my $VN = unpack("C", $LIVNMode & "\x38") >> 3;
my $Mode = unpack("C", $LIVNMode & "\x07");
return undef if $LI > 2;
return undef unless $Transmit;
$Receive -= 2208988800;
$Receive += bintofrac($ReceiveF);
$Transmit -= 2208988800;
$Transmit += bintofrac($TransmitF);
($year, $mon, $wday, $mday, $hour, $min, $sec, $ms) = unpack "S8", $WT1;
$send_time = timegm($sec, $min, $hour, $mday, $mon-1, $year-1900) + $ms/1000;
Log 6, "Send time: (", sprintf("%.4f", $send_time), ") ", scalar(gmtime $send_time), " .$ms ms.\n";
($year, $mon, $wday, $mday, $hour, $min, $sec, $ms) = unpack "S8", $WT2;
$win_time = timegm($sec, $min, $hour, $mday, $mon-1, $year-1900) + $ms/1000;
#Log 4, "Win time : (", sprintf("%.4f", $win_time), ") ", scalar(gmtime $win_time), " .$ms ms.\n";
#Log 3, "net time : (", sprintf("%.4f", $Transmit), ") ", scalar(gmtime $Transmit), "\n";
Log 5, "Win time GMT: ", scalar(gmtime $win_time), " + $ms ms.\n";
Log 4, "Net time GMT: ", scalar(gmtime $Transmit), " + ",
1000*sprintf("%.4f", $Transmit - int($Transmit)), " ms. at $host\n";
my $net_delay = ($win_time - $send_time) - ($Transmit - $Receive);
if ($net_delay > $max_net_lag) {
warn "Connection to $host too slow (net lag = $net_delay)\n";
return undef;
}
my $diff = (($Receive - $send_time) + ($Transmit - $win_time)) / 2;
Log 3, "Offset: ", sprintf("%+.4f", $diff),
" Net delay: ", sprintf("%+.4f", $net_delay),
" host: $host\n";
return ($diff, $net_delay, $host);
}
# this gets a few time samples
sub gettime {
my @hosts = @timehosts;
my $host = shift @hosts || die "No time hosts defined\n";
my ($count, @samples, $errors);
for ($count=1; $count <= $num_samples; $count++) {
my @sample = get_sample($host);
if (@sample < 2) {
$errors++;
die "Too many errors ($errors)\n" if $errors > $max_errors;
$host = shift(@hosts) || last;
$count--;
next;
}
push @samples, [@sample];
} # end for $count (1..$num_samples)
return @samples;
} # end sub gettime
sub correct_time {
my $diff = shift;
# get current Windows time
my $WT1 = "\0" x 16; # initialize struct for GetLocalTime
my $SetPriority = $SetPriorityClass->Call($process, 128)
or die "Couldn't set priority ($^E)\n";
$GetSystemTime->Call($WT1);
# convert to localtime
my ($year, $mon, $wday, $mday, $hour, $min, $sec, $ms) = unpack "S8", $WT1;
my $time = timegm($sec, $min, $hour, $mday, $mon-1, $year-1900);
# add diff and convert back to system time
$time += $diff + $ms/1000;
($sec,$min,$hour,$mday,$mon,$year) = gmtime(int $time);
$WT1 = pack "S8", $year+1900, $mon+1, $wday, $mday, $hour, $min, $sec,
($time - int($time)) * 1000;
# set time
$SetSystemTime->Call($WT1)
|| do { warn "Couldn't set time! ($^E)\n(",
join('-', unpack("S8", $WT1)), "\n";
return undef;
};
$SetPriority = $SetPriorityClass->Call($process, $priority)
or die "Couldn't set priority back to $priority ($^E)\n";
return 1;
}
# *******************************************************************
# The script starts here
# *******************************************************************
Log 2, "Starting $0 version $VERSION\n";
if ($got_config) {
Log 2, "Configuration read from $config_file\n";
}
else {
Log 1, "$config_file file not found. Using default configuration\n";
}
my @samples = gettime();
unless (@samples) {
die "Couldn't synchronize time to any of your time host(s) (", join(', ', @timehosts), ")\n";
}
# select sample with the shortest round-trip delay
@samples = sort { ${$a}[1] <=> ${$b}[1] } @samples; # sort by net lag
my ($diff, $net_delay, $host) = @{shift @samples};
Log 3, "selected ", sprintf("%+.4f", $diff), " seconds at $host (net delay:",
sprintf("%.4f", $net_delay), ")\n";
if ($set_time) {
if (correct_time $diff) {
Log 1, "Corrected ", sprintf("%+.4f", $diff), " seconds using $host.\n";
Log 3, "I have now: ", scalar(localtime), "\n";
Log 1, "-"x40, "\n";
exit 0;
}
else {
die "Couldn't correct time (", sprintf("%+.4f", $diff), " seconds): $^E.\n";
}
}
else {
Log 1, sprintf("%+.4f", $diff), " seconds at $host. Time not corrected\n";
Log 3, "I have now: ", scalar(localtime), "\n";
Log 1, "-"x40, "\n";
exit 0;
}
END {
if ($use_NT_Eventlog) {
my $log = new Win32::EventLog $0;
unless ($log) {
$use_NT_Eventlog = 0;
die "Cannot open Eventlog ($^E)\n";
};
$EventInfo{'TimeGenerated'} = time();
$EventInfo{'Timewritten'} = time();
$EventInfo{'Strings'} =~ s/\r?\n/\r\n/g;
$log->Report(\%EventInfo);
}
}
__END__
=head1 DESCRIPTION
This Perl script uses SNTP (Simple Network Time Protocol, RFC 2030)
to get the time from an NTP server and set the Windows clock.
It can be used interactively or from a scheduler, and can produce
output to a log file and/or the Windows NT Event log.
=head2 Why yet another SNTP client?
Because I wanted something smaller and simpler than what I had found,
and wanted output to a log file when running from a scheduler.
=head2 Why in Perl, which is not as fast as a compiled program?
Because I like Perl, it was well suited to the task, and it turns out to be
fast enough: I seem to get a precision in the range of 50 ms. on a Pentium
150 with Windows 95.
=head2 Why for Windows only?
Because I only need it on Win32 (I use ntpdate on Linux), and because I
don't know how to get/set the time with sub-second precision on other
systems. If you need it on another system, and you know how to do it, let me know.
=head1 PREREQUISITES
This script needs the <win32::api> module, available on CPAN and through PPM.
=head1 BUGS
The Leap Indicator for a leap second in the last minute of the day is
ignored. Which means that you'll be off by 1 second on January the 1st of
the years following the occasional years ending with a 59 or 61 seconds
minute.
The code is not Y2.036K compliant :-). If you are still using this script
in 2036, read RFC 2030 and fix the code yourself, since I may not be
available any more to do it (unless I stop smoking, maybe?). (And send me
an e-mail with your fix, just in case I'm still alive after all).
Let me know about others...
=head1 CONFIGURATION
These configuration options can be placed in a configuration file. The file
name can be given as argument to the script. If there is no argument, a
file named script_file_name.cfg (like in "winsntp.pl.cfg") is tried. If the
file is not found, default values are supplied in the script.
The file is require'd in the script, so it's format is Perl, and it should
end with a true value (just put 1; at the end).
Here is a sample configuration file content:
@timehosts = qw( bernina.ethz.ch swisstime.ethz.ch);
$verbosity = 1;
$interactive = 1;
$debug = 0;
$use_NT_Eventlog = 1;
$force_log = 1;
$logfile = $0 . ".log";
$max_net_lag = 1000;
$max_diff = 86400;
$num_samples = 5;
$timeout = 2;
$set_time = 1;
1;
=head2 @timehosts
@timehosts = qw( swisstime.ethz.ch bernina.ethz.ch );
List of time hosts to use. The full lists are available at
http://www.eecis.udel.edu/~mills/ntp/servers.htm. If a host cannot
be reached, the next one is used etc...
Use stratum 2 hosts. Don't bother stratum 1 hosts for a precision you don't
need and won't get anyway.
=head2 $verbosity
How much is printed to the screen or log. 0: nothing. Normally set
to 1 or 2. Up to 7 for lots of progress messages.
=head2 $interactive
0 or 1. If not interactive, writes results to log file. If interactive,
writes to screen. Also writes a bit more stuff in interactive mode
($verbosity = $verbosity + $interactive). Set it to 0 when running from a
scheduler.
=head2 $debug
0 or 1. Set it to 1 if you have problems, and send me the results.
=head2 $use_NT_Eventlog
0 or 1. If on NT, also write results to Eventlog (even when run interactively).
Ignored on Win9x.
=head2 $force_log
0 or 1. Force writing also to logfile when $interactive is 1.
=head2 $logfile
Name of logfile. Default is $0 . ".log" (the script name with ".log"
appended to it).
=head2 $max_net_lag
Maximum milliseconds to get an answer from the time host. If it takes
longer, ignores the answer and tries again. Set it to 1000 for 1 second.
=head2 $max_diff
Maximum time difference in seconds. If the difference is greater, we don't
set the time, fearing there may have been some weird error. 86400 = 1 day.
Normal errors are caught by looking at the NTP message, as described in
RFC: LI is 3 or time is 0. But this will prevent setting the clock to
something dumb in February 2036 :-).
=head2 $num_samples
How many samples to get from host, so we can choose the best one (the one
with the shortest round trip delay). Probably unnecessary.
=head2 $timeout
Timeout waiting for answer, in seconds. Default is 2.
=head2 $set_time
0 or 1. If 0, only displays the difference, but doesn't correct the clock.
=head1 NOTES
You can use this freely.
I would appreciate a short (or long) e-mail note if you do.
And of course, bug-reports and/or improvements are welcome.
Last revision: 12.10.99. Latest version should be available at
http://alma.ch/perl and/or on CPAN under scripts.
=head1 SCRIPT CATEGORIES
Win32
=head1 OSNAMES
MSWin32
=head1 AUTHOR
Milivoj Ivkovic <mi@alma.ch> or <ivkovic@csi.com>
=head1 COPYRIGHT
Copyright Milivoj Ivkovic, 1999. Same license as Perl itself.
=head1 README
This Perl script uses SNTP (Simple Network Time Protocol, RFC 2030)
to get the time from an NTP server and set the Windows clock.
It can be used interactively or from a scheduler, and can produce
output to a log file and/or the Windows NT Event log.
=cut
]]>