SNTP,RFC,Perl,script,uses,Simple,Network,Time
Quick Search for:  in language:    
SNTP,RFC,Perl,script,uses,Simple,Network,Time
   Code/Articles » |  Newest/Best » |  Community » |  Jobs » |  Other » |  Goto » | 
CategoriesSearch Newest CodeCoding ContestCode of the DayAsk A ProJobsUpload
Perl Stats

 Code: 56,870 lines
 Jobs: 87 postings

 
Sponsored by:

 

You are in:

 
Login



Latest Code Ticker for Perl.
[[ A import of any database from any server to your site.
By Pamela RAI on 10/25


imgLeech
By Benjamin Tilley on 10/23


Even Odd Guessing Game
By Jason DeLuca on 10/15


Include Function
By -Oz on 10/13


Click here to put this ticker on your site!


Add this ticker to your desktop!


Daily Code Email
To join the 'Code of the Day' Mailing List click here!





Affiliate Sites



 
 
   

Set Windows clock from NTP server

Print
Email
 
VB icon
Submitted on: 7/30/2000 12:36:23 AM
By: Found on the World Wide Web 
Level: Intermediate
User Rating: By 2 Users
Compatibility:5.0 (all versions), 4.0 (all versions), 3.0 (all versions), Pre 3.0

Users have accessed this code 8028 times.
 
 
     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.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!

    =**************************************
    = Name: Set Windows clock from NTP serve
    =     r
    = 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
    =**************************************
    
    =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


Other 103 submission(s) by this author

 

 
Report Bad Submission
Use this form to notify us if this entry should be deleted (i.e contains no code, is a virus, etc.).
Reason:
 
Your Vote!

What do you think of this code(in the Intermediate category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor See Voting Log
 
Other User Comments
5/16/2002 10:33:45 AM:Mi
The current version is 0.35, available 
at 
http://alma.ch/perl/scripts/winsntp.pl
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
Add Your Feedback!
Note:Not only will your feedback be posted, but an email will be sent to the code's author in your name.

NOTICE: The author of this code has been kind enough to share it with you.  If you have a criticism, please state it politely or it will be deleted.

For feedback not related to this particular code, please click here.
 
Name:
Comment:

 

Categories | Articles and Tutorials | Advanced Search | Recommended Reading | Upload | Newest Code | Code of the Month | Code of the Day | All Time Hall of Fame | Coding Contest | Search for a job | Post a Job | Ask a Pro Discussion Forum | Live Chat | Feedback | Customize | Perl Home | Site Home | Other Sites | About the Site | Feedback | Link to the Site | Awards | Advertising | Privacy

Copyright© 1997 by Exhedra Solutions, Inc. All Rights Reserved.  By using this site you agree to its Terms and Conditions.  Planet Source Code (tm) and the phrase "Dream It. Code It" (tm) are trademarks of Exhedra Solutions, Inc.