view release on metacpan or  search on metacpan

lib/POE/Component/Client/NTP.pm  view on Meta::CPAN

    my %hints = (socktype => SOCK_DGRAM, protocol => IPPROTO_UDP);
    my ($err, @res) = getaddrinfo($self->{host}, $self->{port}, \%hints);
    if ( $err ) {
      $self->{error} = $err;
      $kernel->yield('_dispatch');
      return;
    }
    $ai = shift @res;
  }
  my $client_localtime      = $self->{client_localtime} = time();
  my $client_adj_localtime  = $client_localtime + NTP_ADJ;
  my $client_frac_localtime = $frac2bin->($client_adj_localtime);

  my $ntp_msg =
    pack( "B8 C3 N10 B32", '00011011', (0) x 12, int($client_localtime),
    $client_frac_localtime );

  $socket->socket( $ai->{family}, $ai->{socktype}, $ai->{protocol} );
  unless ( send( $socket, $ntp_msg, 0, $ai->{addr} ) == length($ntp_msg) ) {
    $self->{error} = $!;
    $kernel->yield('_dispatch');
    return;
  }
  $kernel->select_read( $socket, '_get_datagram' );
  $kernel->delay( '_timeout', ( $self->{timeout} || 60 ), $socket );
  return;
}

sub _timeout {
  my ($kernel,$self,$socket) = @_[KERNEL,OBJECT,ARG0];
  $kernel->select_read( $socket );
  $self->{error} = 'Socket timeout';
  $kernel->yield('_dispatch');
  return;
}

sub _get_datagram {
  my ($kernel,$self,$socket) = @_[KERNEL,OBJECT,ARG0];
  $kernel->delay( '_timeout' );
  $kernel->select_read( $socket );
  my $remote_address = recv( $socket, my $data = '', 960, 0 );
  unless ( defined $remote_address ) {
    $self->{error} = $!;
    $kernel->yield('_dispatch');
    return;
  }
  my $client_localtime = $self->{client_localtime};
  my $client_recvtime = time;
  my %tmp_pkt;
  my %packet;
  my @ntp_fields = qw/byte1 stratum poll precision/;
  push @ntp_fields, qw/delay delay_fb disp disp_fb ident/;
  push @ntp_fields, qw/ref_time ref_time_fb/;
  push @ntp_fields, qw/org_time org_time_fb/;
  push @ntp_fields, qw/recv_time recv_time_fb/;
  push @ntp_fields, qw/trans_time trans_time_fb/;

  @tmp_pkt{@ntp_fields} =
      unpack( "a C3   n B16 n B16 H8   N B32 N B32   N B32 N B32", $data );

  $packet{hex_ref_time} = sprintf '%x.%x', $tmp_pkt{ref_time}, substr +( split m!\.!, $bin2frac->($tmp_pkt{ref_time_fb}) )[1], 0, 9;
  $packet{hex_org_time} = sprintf '%x.%x', ( $tmp_pkt{org_time} + NTP_ADJ ), substr +( split m!\.!, $bin2frac->($tmp_pkt{org_time_fb}) )[1], 0, 9;
  $packet{hex_trans_time} = sprintf '%x.%x', $tmp_pkt{trans_time}, substr +( split m!\.!, $bin2frac->($tmp_pkt{trans_time_fb}) )[1], 0, 9;

  @packet{@ntp_packet_fields} = (
        (unpack( "C", $tmp_pkt{byte1} & "\xC0" ) >> 6),
        (unpack( "C", $tmp_pkt{byte1} & "\x38" ) >> 3),
        (unpack( "C", $tmp_pkt{byte1} & "\x07" )),
        $tmp_pkt{stratum},
        (sprintf("%0.4f", $tmp_pkt{poll})),
        $tmp_pkt{precision} - 255,
        ($bin2frac->($tmp_pkt{delay_fb})),
        (sprintf("%0.4f", $tmp_pkt{disp})),
        $unpack_ip->($tmp_pkt{stratum}, $tmp_pkt{ident}),
        (($tmp_pkt{ref_time} += $bin2frac->($tmp_pkt{ref_time_fb})) -= NTP_ADJ),
        (($tmp_pkt{org_time} += $bin2frac->($tmp_pkt{org_time_fb})) ),
      (($tmp_pkt{recv_time} += $bin2frac->($tmp_pkt{recv_time_fb})) -= NTP_ADJ),
     (($tmp_pkt{trans_time} += $bin2frac->($tmp_pkt{trans_time_fb})) -= NTP_ADJ)
  );

  my $dest_org   = sprintf "%0.5f", (($client_recvtime - $client_localtime));
  my $recv_trans = sprintf "%0.5f", ($packet{'Receive Timestamp'} - $packet{'Transmit Timestamp'});
  my $delay      = sprintf "%0.5f", ($dest_org + $recv_trans);

  my $recv_org   = $packet{'Receive Timestamp'} - $client_recvtime;
  my $trans_dest = $packet{'Transmit Timestamp'} - $client_localtime;
  my $offset     = ($recv_org + $trans_dest) / 2;

  # Calculated offset / delay
  $packet{Offset} = $offset;
  $packet{Delay}  = $delay;

  $self->{response} = \%packet;
  $kernel->yield('_dispatch');
  return;
}

sub _dispatch {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  my $data = { };
  $data->{$_} = $self->{$_} for grep { defined $self->{$_} } qw(response error context host);
  $kernel->post( $self->{sender_id}, $self->{event}, $data );
  $kernel->refcount_decrement( $self->{sender_id}, __PACKAGE__ );
  return;
}

}

'What is the time, Mr Wolf?';

__END__

=pod

=encoding UTF-8

=head1 NAME

POE::Component::Client::NTP - A POE Component to query NTP servers

=head1 VERSION

version 0.14