IEC104.pm

package Net::IEC104;

use 5.008008;
use strict;
use warnings;
use Carp;
use IO::Socket::INET;
use Event::Lib;
use Date::Manip;
use Time::HiRes qw/ gettimeofday tv_interval /;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration use Net::IEC104 ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
    'all' => [
        qw(
          &connect &listen &send &main_loop &disconnect
          )
    ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.03';

###############################################################################

$| = 1;

our $debug         = 0;
our $MAX_ASDU_SIZE = 248;
our $MAX_S_QUEUE   = 100;

our %asdu_type = (

    # Infromation to control direction, ASDU: 1-44
    30 => {
        "size"     => 8,
        "name"     => "M_SP_TB_1",
        type       => "TS",
        "parse_cb" => \&parse_asdu_type_0_44,
        "write_cb" => \&send_asdu_type_0_44
    },
    35 => {
        "size"     => 10,
        "name"     => "M_ME_TE_1",
        type       => "TI",
        "parse_cb" => \&parse_asdu_type_0_44,
        "write_cb" => \&send_asdu_type_0_44
    },
    36 => {
        "size"     => 12,
        "name"     => "M_ME_TF_1",
        type       => "TI",
        "parse_cb" => \&parse_asdu_type_0_44,
        "write_cb" => \&send_asdu_type_0_44
    },
    37 => {
        "size"     => 12,
        "name"     => "M_IT_TB_1",
        type       => "TII",
        "parse_cb" => \&parse_asdu_type_0_44,
        "write_cb" => \&send_asdu_type_0_44
    },

    # System information to controlled direction, ASDU: 100-109
    100 => {
        "size"     => 1,
        "name"     => "C_IC_NA_1",
        type       => "",
        "parse_cb" => \&parse_asdu_type_100,
        "write_cb" => \&send_asdu_type_100
    },
    103 => {
        "size"     => 7,
        "name"     => "C_CS_NA_1",
        type       => "",
        "parse_cb" => \&parse_asdu_type_103,
        "write_cb" => \&send_asdu_type_103
    },
);

# Constructor
sub new {
    my $self  = shift;
    my %h     = @_;
    my $class = ref($self) || $self;
    croak "wrong type of Net::IEC104"
      if ( $h{type} ne "slave" and $h{type} ne "master" );

    $h{retry_timeout} = ( exists $h{retry_timeout} ) ? $h{retry_timeout} : 5;
    $h{ip}   = ( exists $h{ip} )   ? $h{ip}   : "0.0.0.0";
    $h{port} = ( exists $h{port} ) ? $h{port} : "2404";

    bless \%h, $class;
}

# Print debug messages
sub DEBUG {
    my $d = shift;
    if ( $debug >= $d ) {
        print @_;
        if ( $d < 0 ) {
            printf "<-- at %s:%s", (caller)[ 1, 2 ];
        }
        unless ( $_[$#_] =~ /\s$/ ) {
            print "\n";
        }
    }
}

# Pack ip-port pair as ID of connection
sub get_id {
    my $sock = shift;
    return pack( "C4S", split( /\./, $sock->peerhost ), $sock->peerport );
}

# Unpack ip-port pair to printable form
sub sid2hex {
    return join( ".", map { sprintf "%d", $_ } unpack( "C4S", shift ) );
}

# Print hex-codes of raw data
sub raw2hex {
    return join( ",", map { sprintf "%02X", $_ } unpack( "C*", shift ) );
}

# convert from cp56_2a format of time to gettimeofday
sub cp56_2a_2_time {
    my $data = shift;
    my @tm   = unpack( "SC5", $data );
    my $tm   = Date_SecsSince1970GMT(
        $tm[4] & 0xF,
        $tm[3] & 0x1F,
        2000 + ( $tm[5] & 0x7F ),
        $tm[2] & 0x1F,
        $tm[1] & 0x3F,
        int( $tm[0] / 1000 )
    );
    my $ms = ( $tm[0] % 1000 ) * 1000;
    return ( $tm, $ms );
}

# convert from gettimeofday format to cp56_2a
sub time_2_cp56_2a {
    my $tm = shift;
    my $ms = shift;
    $ms = int( $ms / 1000 );
    my @tm = localtime($tm);
    return pack( "SC5",
        ( $tm[0] * 1000 + $ms ),
        $tm[1],
        $tm[2] | ( $tm[8] << 7 ),
        $tm[3] | ( $tm[6] << 5 ),
        ++$tm[4], $tm[5] % 100 );
}

# debug info about connection
sub sidinfo {
    my $self = shift;
    my $sid  = shift;
    my $report;
    my $s = \%{ $self->{sids}{$sid} };

    $report =
        "=====================\n"
      . "TYPE:  "
      . $s->{type} . "\n"
      . sprintf( "IP:    %d.%d.%d.%d\n" . "PORT:  %d\n", unpack( "C4S", $sid ) )
      . "UFUNC: "
      . $s->{ufunc} . "\n"
      . "VS:    "
      . $s->{vs} . "\n"
      . "VR:    "
      . $s->{vr} . "\n"
      . "AS:    "
      . $s->{as} . "\n"
      . "AR:    "
      . $s->{ar} . "\n"
      . "s_queue: "
      . $#{ $s->{s_queue} } . "\n";
    foreach my $timer (
        "t0_timer", "t1_timer", "t2_timer", "t3_timer",
        "ci_timer", "sync_timer"
      )
    {
        $report .= $timer . ": ";
        if ( $s->{$timer}->pending ) {
            $report .= "pending\n";
        }
        else {
            $report .= "not started\n";
        }
    }
    return $report;
}

# public method listen()
# start IEC slave station (server)
sub listen {
    my $self = shift;
    my %h    = @_;
    carp "called without a reference" if ( !ref($self) );

    my $server = IO::Socket::INET->new(
        LocalAddr => $self->{ip},
        LocalPort => $self->{port},
        Proto     => 'tcp',
        ReuseAddr => SO_REUSEADDR,
        Listen    => 1,
        Blocking  => 0,
    ) or carp $@;
    return -1 unless ($server);
    &DEBUG( 1, "Listen on ", $self->{ip}, ":", $self->{port} );
    my $main =
      event_new( $server, EV_READ | EV_PERSIST, \&handle_incoming, $self );
    $main->add;
}

# public method connect()
# start IEC master session
sub connect {
    my $self = shift;
    carp "called without a reference" if ( !ref($self) );

    my $client = IO::Socket::INET->new(
        Proto    => 'tcp',
        PeerAddr => $self->{ip},
        PeerPort => $self->{port},
        Blocking => 0
    ) or carp $@;

    my $main = event_new( $client, EV_WRITE, \&on_connect, $self );
    $main->add(2);
}

sub on_connect {
    my ( $e, $type, $self ) = @_;
    my $error = 1;

    if ( $type == EV_TIMEOUT ) {
        &DEBUG( 0, "Can't connect to ",
            $self->{ip}, ":", $self->{port}, ", connection timeout" );
    }
    elsif ( $type == EV_WRITE ) {
        my $client = $e->fh;
        unless ( $client->connected ) {
            &DEBUG( 0, "Can't connect to ",
                $self->{ip}, ":", $self->{port}, ", connection rejected" );
        }
        else {
            $self->{retry_count} = 0;
            $error = 0;
            &DEBUG( 1, "connected to ", $self->{ip}, ":", $self->{port} );
            my $sid  = &get_id($client);
            my $main = event_new( $client, EV_READ | EV_PERSIST,
                \&handle_client, $self, $sid );
            $self->init_new_conn(
                sid   => $sid,
                event => $main,
                type  => "MASTER"
            );
            $main->add;

            $self->frame_u_send( $sid, "STARTDTACT" );
        }
    }

    if ( $error && $self->{persist} ) {
        my $timer = timer_new( \&reconnect, $self );
        $timer->add( $self->{retry_timeout} );
    }
}

# Main event loop
sub main_loop {
    event_mainloop;
}

# Sync time
sub sync_time {
    my ( $cause, $s, $data );
    my $self = shift;
    my $csid = undef;

    if ( $#_ != -1 && defined( $_[0] ) ) {
        $csid = shift;
    }

    if ( $self->{type} eq "master" ) {
        $cause = 6;    # activation
    }
    else {
        $cause = 3;    # sporadic
    }

    foreach my $sid ( keys %{ $self->{sids} } ) {
        next if ( defined($csid) && $csid ne $sid );
        $s = \%{ $self->{sids}{$sid} };
        &DEBUG( 2, "Sync time for CA: ",
            $s->{ca}, ", My current time: ", time() );
        $data =
          pack( "C2S3C", 103, 1, $cause, $s->{ca}, 1, 0 )
          . &time_2_cp56_2a(gettimeofday);
        $self->frame_i_send( $sid, $data );
    }
}

# handle incoming connections
sub handle_incoming {
    my $e      = shift;
    my $etype  = shift;
    my $self   = shift;
    my $h      = $e->fh;
    my $client = $h->accept or croak "$!";
    $client->blocking(0);
    &DEBUG( 1, "accept connection from ",
        $client->peerhost, ":", $client->peerport );

    my $sid = &get_id($client);

    # set up a new event that watches the client socket
    my $event =
      event_new( $client, EV_READ | EV_PERSIST, \&handle_client, $self, $sid );
    $self->init_new_conn(
        sid   => $sid,
        event => $event,
        type  => "SLAVE"
    );
    $event->add;
}

# init new structure for connection
sub init_new_conn {
    my $self = shift;
    my %h    = @_;
    my $sid  = $h{"sid"} or croak $@;

    $self->{sids}{$sid} = ();
    my $s = \%{ $self->{sids}{$sid} };

    $s->{type} = ( $h{type} ) ? $h{type} : "SLAVE";
    $s->{event} = $h{"event"} or croak $@;
    $s->{ufunc} = ( $self->{ufunc} ) ? $self->{ufunc} : "STOPDT";
    $s->{ca} = ( $self->{ca} ) ? $self->{ca} : 1;     # common address of asdu
    $s->{t0} = ( $self->{t0} ) ? $self->{t0} : 30;    # t0 timeout, sec
    $s->{t1} = ( $self->{t1} ) ? $self->{t1} : 15;    # t1 timeout, sec
    $s->{t2} = ( $self->{t2} ) ? $self->{t2} : 10;    # t2 timeout, sec
    $s->{t3} = ( $self->{t3} ) ? $self->{t3} : 20;    # t3 timeout, sec
    $s->{w}  = ( $self->{w} )  ? $self->{w}  : 8;     # w
    $s->{k}  = ( $self->{k} )  ? $self->{k}  : 12;    # k
    $s->{vs} = 0;                                     # Number S sended
    $s->{vr} = 0;                                     # Number S received
    $s->{as} = 0;                                     # Number S ack by me
    $s->{ar} = 0;                                     # Number S ack by peer

    $s->{rcb} =
      ( $self->{read_callback} ) ? $self->{read_callback} : \&default_read_cb;
    $s->{wcb} =
      ( $self->{write_callback} )
      ? $self->{write_callback}
      : \&default_write_cb;

    $s->{ts_fn}  = ( $self->{ts_func_num} )  ? $self->{ts_func_num}  : 30;
    $s->{ti_fn}  = ( $self->{ti_func_num} )  ? $self->{ti_func_num}  : 36;
    $s->{tii_fn} = ( $self->{tii_func_num} ) ? $self->{tii_func_num} : 37;

    $s->{s_queue} = [];       # Send queue
    $s->{r_buf}   = undef;    # Receive buffer

    $s->{t0_timer} = timer_new( \&t0_timer_run, $self, $sid );
    $s->{t1_timer} = timer_new( \&t1_timer_run, $self, $sid );
    $s->{t2_timer} = timer_new( \&t2_timer_run, $self, $sid );
    $s->{t3_timer} = timer_new( \&t3_timer_run, $self, $sid );

    $s->{ci_timeout} =
      ( $self->{ci_timeout} ) ? $self->{ci_timeout} : 5 * 60;  # CI timeout, sec
    $s->{sync_timeout} =
      ( $self->{sync_timeout} )
      ? $self->{sync_timeout}
      : 60 * 60;    # Sync timeout, sec
    $s->{ci_timer}   = timer_new( \&ci_timer_run,   $self, $sid );
    $s->{sync_timer} = timer_new( \&sync_timer_run, $self, $sid );

    $s->{time_diff} = 0;    # diff in time between kp and control station

    $s->{t0_timer}->add( $s->{t0} );    # timeout of init connection
}

# Invoked when the client's socket becomes readable
sub handle_client {
    my $data;

    my $e     = shift;
    my $etype = shift;
    my $self  = shift;
    my $sid   = shift;
    my $h     = $e->fh;
    my $s     = \%{ $self->{sids}{$sid} };

    unless ( $h->connected ) {
        &DEBUG( 9, "client disconnected" );
        $self->disconnect($sid);
        return;
    }
    if ( eof($h) ) {
        &DEBUG( 1, "connection not readable" );
        $self->disconnect($sid);
        return;
    }

    if ( defined( $self->{sids}{$sid}{r_buf} ) ) {
        $data = $s->{r_buf};
        $s->{r_buf} = undef;
    }

    while (<$h>) {
        $data .= $_;
    }

    my ( $start, $length, $bits ) = unpack( "C3", $data );
    while (1) {
        if ( $start != 0x68 || length($data) < 3 ) {

            #error in Net::IEC104 packet
            &DEBUG( 11, raw2hex($data) );
            &DEBUG(
                1,
                "error in Net::IEC104 chunk: START: ",
                $start,
                "; LENGTH: ",
                defined($length) ? $length : 0,
                "; DATA SIZE: ",
                length($data)
            );
            $self->disconnect($sid);
            return;
        }

        # retransmission (part of data will be received in next packet)
        # put data in receive buffer
        if ( $length > length($data) - 2 ) {
            &DEBUG( 2,
"receive fragmented packet, save data in buffer and wait next chunk"
            );
            &DEBUG( 2, "LENGTH: ", length($data) - 2,
                " of ", $length, " bytes" );
            $s->{r_buf} = $data;
            return;
        }
        my $curdata = substr( $data, 0, $length + 2 );
        &DEBUG( 11, raw2hex($curdata) );

        # Receiving packet of any type restart a T3 timer
        if ( $s->{t3_timer}->pending ) {
            $s->{t3_timer}->remove;
        }
        $s->{t3_timer}->add( $s->{t3} );

        if ( ( $bits & 1 ) == 0 ) {

            # frame type I
            $self->frame_i_recv( $sid, $curdata );
        }
        elsif ( ( $bits & 3 ) == 1 ) {

            # frame type S
            $self->frame_s_recv( $sid, $curdata );
        }
        elsif ( ( $bits & 3 ) == 3 ) {

            # frame type U
            $self->frame_u_recv( $sid, $curdata );
        }
        else {
            &DEBUG( 0, "unknown frame type" );
        }
        $data = substr( $data, $length + 2 );
        return unless ($data);
        ( $start, $length, $bits ) = unpack( "C3", $data );
    }
}

# public method disconnect()
# close client or server connection
sub disconnect {
    my $self = shift;
    my ( $e, $h );
    my $csid = undef;

    if ( $#_ != -1 && defined( $_[0] ) ) {
        $csid = shift;
    }

    foreach my $sid ( keys %{ $self->{sids} } ) {
        next if ( defined($csid) && $csid ne $sid );
        $e = $self->{sids}{$sid}{event};
        $h = $e->fh;
        &DEBUG( 1, "disconnected from ", &sid2hex($sid) );
        close $h;
        $e->remove;
        $self->{sids}{$sid}{t0_timer}->remove;
        $self->{sids}{$sid}{t1_timer}->remove;
        $self->{sids}{$sid}{t2_timer}->remove;
        $self->{sids}{$sid}{t3_timer}->remove;
        $self->{sids}{$sid}{ci_timer}->remove;
        $self->{sids}{$sid}{sync_timer}->remove;
        delete $self->{sids}{$sid};

        if ( $self->{type} eq "master" && $self->{persist} != 0 ) {
            &DEBUG( 11, "persist is true, reconnect..." );
            $self->connect();
        }
        else {
            &DEBUG( 11, "persist is not true, dont reconnect..." );
        }
    }
}

sub reconnect {
    my $e     = shift;
    my $etype = shift;
    my $self  = shift;
    my $timer;

    $self->{retry_count}++;
    &DEBUG(
        1, "reconnect to ",
        $self->{ip}, ":", $self->{port}, " after fail... Attempt: ",
        $self->{retry_count}
    );
    $self->connect;
}

# public method send()
# send spontaneous data to all client connections (only for SLAVE)
sub send {
    my $self = shift;
    my $ca   = shift;
    my %h    = @_;
    return if ( $self->{type} ne "slave" );
    foreach my $sid ( keys %{ $self->{sids} } ) {
        next
          if ( !defined( $self->{sids}{$sid} )
            || $self->{sids}{$sid}{ufunc} eq "STOPDT"
            || $self->{sids}{$sid}{ca} != $ca );
        if ( exists $h{"TI"} && $self->{sids}{$sid}{ti_fn} != 0 ) {
            &{ $asdu_type{ $self->{sids}{$sid}{ti_fn} }{write_cb} }( $self,
                $sid, 3, $self->{sids}{$sid}{ti_fn}, $h{"TI"} );
        }
        if ( exists $h{"TS"} && $self->{sids}{$sid}{ts_fn} != 0 ) {
            &{ $asdu_type{ $self->{sids}{$sid}{ts_fn} }{write_cb} }( $self,
                $sid, 3, $self->{sids}{$sid}{ts_fn}, $h{"TS"} );
        }
        if ( exists $h{"TII"} && $self->{sids}{$sid}{tii_fn} != 0 ) {
            &{ $asdu_type{ $self->{sids}{$sid}{tii_fn} }{write_cb} }( $self,
                $sid, 3, $self->{sids}{$sid}{tii_fn}, $h{"TII"} );
        }
    }
}

sub t0_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;

    &DEBUG( 1, "sid: ", &sid2hex($sid), ". t0 timer run" );
    $self->disconnect($sid);
}

sub t1_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;
    &DEBUG( 1, "sid: ", &sid2hex($sid), ". t1 timer run" );
    $self->disconnect($sid);
}

sub t2_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;
    &DEBUG( 2, "t2 timer run" );
    $self->frame_s_send($sid);
}

sub t3_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;
    my $s    = \%{ $self->{sids}{$sid} };
    &DEBUG( 1, "sid: ", &sid2hex($sid), ". t3 timer run" );
    $self->frame_u_send( $sid, "TESTFRACT" );
    unless ( $s->{t1_timer}->pending ) {
        $s->{t1_timer}->add( $s->{t1} );
    }
}

sub ci_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;
    &DEBUG( 1, "sid: ", &sid2hex($sid), ". ci timer run" );
    $self->frame_i_send( $sid,
        pack( "C2S3C2", 100, 1, 6, $self->{sids}{$sid}{ca}, 0, 0, 20 ) );
}

sub sync_timer_run {
    my $e    = shift;
    my $type = shift;
    my $self = shift;
    my $sid  = shift;
    &DEBUG( 1, "sid: ", &sid2hex($sid), ". sync timer run" );
    $self->sync_time($sid);
}

# send frame type U
sub frame_u_send {
    my $self = shift;
    my $sid  = shift;
    my $func = shift;
    my $bits = 3;

    &DEBUG( 3, "send frame type U, function ", $func, ": " );
    if ( $func eq "STARTDTACT" ) {
        $bits |= 1 << 2;
    }
    elsif ( $func eq "STARTDTCON" ) {
        $bits |= 1 << 3;
    }
    elsif ( $func eq "STOPDTACT" ) {
        $bits |= 1 << 4;
    }
    elsif ( $func eq "STOPDTCON" ) {
        $bits |= 1 << 5;
    }
    elsif ( $func eq "TESTFRACT" ) {
        $bits |= 1 << 6;
    }
    elsif ( $func eq "TESTFRCON" ) {
        $bits |= 1 << 7;
    }

    return unless ( defined( $self->{sids}{$sid}{event} ) );
    my $sock = $self->{sids}{$sid}{event}->fh;
    my $data = pack( "C6", 0x68, 4, $bits, 0, 0, 0 );
    &DEBUG( 3, raw2hex($data) );
    print $sock $data;
}

sub frame_u_recv {
    my $self = shift;
    my $sid  = shift;
    my $data = shift;

    my ($bits) = ( unpack( "C3", $data ) )[2];
    &DEBUG( 3, "received frame type U, function " );

    if ( $bits & 1 << 2 ) {

        # STARTDT ACT
        &DEBUG( 3, "STARTDTACT" );
        if ( $self->{sids}{$sid}{type} ne "SLAVE" ) {
            &DEBUG( 0, "master receive STARTDT ACT" );
            return -1;
        }

        # T0 timer removed after init
        $self->{sids}{$sid}{t0_timer}->remove;
        $self->{sids}{$sid}{ufunc} = "STARTDT";
        $self->frame_u_send( $sid, "STARTDTCON" );
    }
    elsif ( $bits & 1 << 3 ) {

        # STARTDT CON
        &DEBUG( 3, "STARTDTCON" );
        if ( $self->{sids}{$sid}{type} ne "MASTER" ) {
            return -1;
        }

        # Slave answer on init -> remove T0 timer
        $self->{sids}{$sid}{t0_timer}->remove;

        $self->{sids}{$sid}{ufunc} = "STARTDT";

        # Connection activated.
        # Sync time
        $self->sync_time($sid);

        # Start common interogation
        $self->frame_i_send( $sid,
            pack( "C2S3C2", 100, 1, 6, $self->{sids}{$sid}{ca}, 0, 0, 20 ) );

    }
    elsif ( $bits & 1 << 4 ) {

        # STOPDT ACT
        &DEBUG( 3, "STOPDTACT" );
        if ( $self->{sids}{$sid}{type} ne "SLAVE" ) {
            return -1;
        }
        $self->{sids}{$sid}{ufunc} = "STOPDT";
        $self->frame_u_send( $sid, "STOPDTCON" );
    }
    elsif ( $bits & 1 << 5 ) {

        # STOPDT CON
        &DEBUG( 3, "STOPDTCON" );
        if ( $self->{sids}{$sid}{type} ne "MASTER" ) {
            return -1;
        }
        $self->{sids}{$sid}{ufunc} = "STOPDT";
    }
    elsif ( $bits & 1 << 6 ) {

        # TESTFR ACT
        &DEBUG( 3, "TESTFRACT" );
        $self->frame_u_send( $sid, "TESTFRCON" );
    }
    elsif ( $bits & 1 << 7 ) {

        # TESTFR CON
        &DEBUG( 3, "TESTFRCON" );
        $self->{sids}{$sid}{t1_timer}->remove;
    }
    else {
        &DEBUG( 3, "unknown" );
        &DEBUG( 0, "Error in received U frame: unknown type" );
    }
}

# send frame type S
sub frame_s_send {
    my $self = shift;
    my $sid  = shift;
    if ( $self->{sids}{$sid}{as} == $self->{sids}{$sid}{vr} ) {
        &DEBUG(
            2,
            "not sending frame type S, AS=VR (",
            $self->{sids}{$sid}{as},
            "=", $self->{sids}{$sid}{vr}, ")"
        );
        return;
    }
    &DEBUG( 3, "send frame type S(", $self->{sids}{$sid}{vr}, ")" );
    my $sock = $self->{sids}{$sid}{event}->fh;
    print $sock pack( "C4S", 0x68, 4, 1, 0, $self->{sids}{$sid}{vr} << 1 );
    $self->{sids}{$sid}{as} = $self->{sids}{$sid}{vr};
}

# receive frame type S
sub frame_s_recv {
    my $self = shift;
    my $sid  = shift;
    my $data = shift;

    my ($nr) = ( unpack( "C2S2", $data ) )[3];
    $nr >>= 1;
    if ( ( ( $self->{sids}{$sid}{vs} - $nr + 32768 ) % 32768 ) >
        $self->{sids}{$sid}{k} )
    {
        &DEBUG(
            0, "wrong N(R) number in S-ack received: ",
            $nr,
            ". Current N(S) = ",
            $self->{sids}{$sid}{vs}
        );
        $self->disconnect($sid);
        return;
    }
    &DEBUG( 3, "received frame type S(", $nr, ")" );
    $self->{sids}{$sid}{ar} = $nr;
    $self->{sids}{$sid}{t1_timer}->remove;

    $self->flush_send_queue($sid);
}

sub flush_send_queue {
    my $ret;
    my $self = shift;
    my $sid  = shift;

    #return if ($#{$self->{sids}{$sid}{s_queue}} == -1);
    #for my $i (0 .. $#{$self->{sids}{$sid}{s_queue}}) {
    #$ret = $self->frame_i_send($sid,undef);
    #last if ($ret != 0);
    #}
    while ( $#{ $self->{sids}{$sid}{s_queue} } != -1 ) {
        last if ( $self->frame_i_send( $sid, undef ) );
    }
}

sub frame_i_send {
    my $self = shift;
    my $sid  = shift;
    my $asdu = shift;

    unless ( exists( $self->{sids}{$sid} ) ) {
        &DEBUG( 0, "frame_i_send(): error, connection ",
            &sid2hex($sid), " already dead\n" );
        for my $j ( 0 .. 3 ) {
            &DEBUG( 0, join( "->", ( caller($j) )[ 0, 1, 2, 3 ] ) );
        }
        return -1;
    }
    if ( $self->{sids}{$sid}{vs} ==
        ( $self->{sids}{$sid}{ar} + $self->{sids}{$sid}{k} ) % 32768 )
    {
        &DEBUG( 2, "reached k, no frames will be sent" );
        if ( $#{ $self->{sids}{$sid}{s_queue} } + 1 > $MAX_S_QUEUE ) {
            &DEBUG( 0, $self->sidinfo($sid) );
            &DEBUG( 0, "send queue overloaded, asdu dropped" );
            $self->disconnect($sid);
            return 2;
        }
        elsif ( defined($asdu) ) {
            push @{ $self->{sids}{$sid}{s_queue} }, $asdu;
            if (   $self->{sids}{$sid}{type} eq "SLAVE"
                && $#{ $self->{sids}{$sid}{s_queue} } > $MAX_S_QUEUE * 0.9 )
            {
                &DEBUG(
                    0, &sid2hex($sid),
                    ", queue increased: ",
                    ( $#{ $self->{sids}{$sid}{s_queue} } + 1 )
                );
            }
            &DEBUG(
                2,
                "asdu queued (No:",
                $#{ $self->{sids}{$sid}{s_queue} } + 1, ")"
            );
        }
        return 1;
    }
    unless ( defined($asdu) ) {
        $asdu = shift( @{ $self->{sids}{$sid}{s_queue} } )
          if ( $#{ $self->{sids}{$sid}{s_queue} } >= 0 );
        unless ( defined($asdu) ) {
            &DEBUG( 0, "Error: empty asdu" );
            return 3;
        }
        else {
            if (   $self->{sids}{$sid}{type} eq "SLAVE"
                && $#{ $self->{sids}{$sid}{s_queue} } > $MAX_S_QUEUE * 0.9 )
            {
                &DEBUG(
                    0, &sid2hex($sid),
                    ", queue reduced: ",
                    ( $#{ $self->{sids}{$sid}{s_queue} } + 1 )
                );
            }
            &DEBUG( 3, "send frame type I from queue: " );
        }
    }
    else {
        &DEBUG( 3, "send frame type I: " );
    }

    $self->{sids}{$sid}{t1_timer}->remove;
    $self->{sids}{$sid}{t1_timer}->add( $self->{sids}{$sid}{t1} );

    my $ns   = $self->{sids}{$sid}{vs} << 1;
    my $nr   = $self->{sids}{$sid}{vr} << 1;
    my $sock = $self->{sids}{$sid}{event}->fh;
    my $data = pack( "C2S2", 0x68, 4 + length($asdu), $ns, $nr ) . $asdu;
    DEBUG( 3, raw2hex($data) );
    print $sock $data;

    $self->{sids}{$sid}{vs} = ( $self->{sids}{$sid}{vs} + 1 ) % 32768;
    return 0;
}

sub frame_i_recv {
    my $self = shift;
    my $sid  = shift;
    my $data = shift;
    DEBUG( 3, "received frame type I " );
    if ( $self->{sids}{$sid}{ufunc} ne "STARTDT" ) {
        DEBUG( 0, "Error: no STARTDT in current connection" );
        return -1;
    }

    my ( $ns, $nr ) = ( unpack( "C2S2", $data ) )[ 2, 3 ];
    $ns >>= 1;
    $nr >>= 1;
    DEBUG( 3, "NS=$ns,NR=$nr" );
    if ( $ns != $self->{sids}{$sid}{vr} ) {
        &DEBUG(
            0,
            "Error: Expect N(S)=",
            $self->{sids}{$sid}{vr},
            ", but receive: ",
            $ns, ". Packet lost or reordered"
        );
        return -1;
    }
    if (   ( $nr != $self->{sids}{$sid}{ar} )
        && ( ( $nr - $self->{sids}{$sid}{ar} + 32768 ) % 32768 ) <=
        $self->{sids}{$sid}{k}
        && ( ( $self->{sids}{$sid}{vs} - $nr + 32768 ) % 32768 ) <=
        $self->{sids}{$sid}{k} )
    {
        $self->{sids}{$sid}{ar} = $nr;
        $self->{sids}{$sid}{t1_timer}->remove;
    }

    $self->{sids}{$sid}{t2_timer}->remove();
    $self->{sids}{$sid}{t2_timer}->add( $self->{sids}{$sid}{t2} );

    $self->{sids}{$sid}{vr} = ( $ns + 1 ) % 32768;
    if (
        ( $self->{sids}{$sid}{vr} - $self->{sids}{$sid}{as} + 32768 ) % 32768 ==
        $self->{sids}{$sid}{w} )
    {
        $self->frame_s_send($sid);
    }

    $self->parse_asdu( $sid, substr( $data, 6 ) );
}

sub parse_asdu {
    my $self = shift;
    my $sid  = shift;
    my $asdu = shift;

    my $i = \%{ $self->{sids}{$sid}{i} };
    my $kps;

    &DEBUG( 12, "parse_asdu(): ", raw2hex($asdu) );
    ( $i->{id}, $kps, $i->{cause}, $i->{ca} ) = unpack( "C2S2", $asdu );
    $i->{sq}   = ( $kps & 1 << 7 ) >> 7;
    $i->{nobj} = $kps & 0x7F;
    $i->{cause} &= 0xFF;
    &DEBUG( 3, "ID: ", sprintf( "%02X", $i->{id} ), ", " );
    &DEBUG( 3, "SQ: ", $i->{sq}, ", " );
    &DEBUG( 3, "NObj: ",  sprintf( "%02X", $i->{nobj} ),  ", " );
    &DEBUG( 3, "Cause: ", sprintf( "%02X", $i->{cause} ), ", " );
    &DEBUG( 3, "C.Addr ASDU: ", sprintf( "%02X", $i->{ca} ) );

    unless ( exists $asdu_type{ $i->{id} } ) {
        &DEBUG( -1, "not implemented type ", $i->{id} );
        return;
    }

    if ( $i->{sq} == 0 ) {

        # Numerous information objects
        for my $j ( 1 .. $i->{nobj} ) {
            my $k = ( $j - 1 ) * ( 3 + $asdu_type{ $i->{id} }{size} );
            ( $i->{obj}{$j}{ioa}, $i->{obj}{$j}{ioa2} ) =
              unpack( "SC", substr( $asdu, 6 + $k, 3 ) );
            $i->{obj}{$j}{data} =
              substr( $asdu, 6 + 3 + $k, $asdu_type{ $i->{id} }{size} );
        }
    }
    else {

        # One object, numerous elements
        # <{TODO}>
        &DEBUG( -1, "not implemented code" );
    }
    &{ $asdu_type{ $i->{id} }{parse_cb} }( $self, $sid );
}

sub default_read_cb {
    DEBUG( 1, "default_read_cb()" );
}

sub default_write_cb {
    DEBUG( 1, "default_write_cb()" );
    return ( "TS" => { "1" => [ "0", gettimeofday ] } );
}

sub parse_asdu_type_100 {
    my $self = shift;
    my $sid  = shift;
    my $s    = \%{ $self->{sids}{$sid} };
    my $i    = \%{ $s->{i} };
    if ( $i->{cause} == 6 ) {
        &DEBUG( 0, &sid2hex($sid), " [100] activation" );

        # drop outgoing queue
        if ( $#{ $self->{sids}{$sid}{s_queue} } >= 0 ) {
            &DEBUG(
                0, &sid2hex($sid), " drop ",
                ( $#{ $self->{sids}{$sid}{s_queue} } + 1 ),
                " asdu from queue because of activation"
            );
            $self->{sids}{$sid}{s_queue} = [];
        }

        # send accept
        $s->{ca} = $i->{ca};
        my $data = pack( "C2S3C",
            100, 1, 7, $i->{ca},
            $i->{obj}{1}{ioa},
            $i->{obj}{1}{ioa2} )
          . $i->{obj}{1}{data};
        $self->frame_i_send( $sid, $data );

        # 1. Send whole database
        my %h = &{ $s->{wcb} }( $self, $s->{ca} );

        if ( exists $h{"TI"} && $s->{ti_fn} != 0 ) {
            &{ $asdu_type{ $s->{ti_fn} }{write_cb} }( $self, $sid, 3,
                $s->{ti_fn}, $h{"TI"} );
        }
        if ( exists $h{"TS"} && $s->{ts_fn} != 0 ) {
            &{ $asdu_type{ $s->{ts_fn} }{write_cb} }( $self, $sid, 3,
                $s->{ts_fn}, $h{"TS"} );
        }
        if ( exists $h{"TII"} && $s->{tii_fn} != 0 ) {
            &{ $asdu_type{ $s->{tii_fn} }{write_cb} }( $self, $sid, 3,
                $s->{tii_fn}, $h{"TII"} );
        }
    }
    elsif ( $i->{cause} == 8 ) {
        &DEBUG( 0, &sid2hex($sid), " [100] deactivation" );

        # <{TODO}>
    }
    elsif ( $i->{cause} == 7 ) {
        &DEBUG( 2, &sid2hex($sid), " [100] accept of activation" );

        $s->{t1_timer}->remove;

        # Start timer Common Interogation
        $s->{ci_timer}->remove;
        $s->{ci_timer}->add( $s->{ci_timeout} );

        # <{TODO}>
    }
    elsif ( $i->{cause} == 9 ) {
        &DEBUG( 2, "[100] accept of deactivation" );

        # <{TODO}>
    }
    elsif ( $i->{cause} == 10 ) {
        &DEBUG( 2, &sid2hex($sid), " [100] close activation" );

        # <{TODO}>
    }
    else {
        &DEBUG( 2, "[100] unknown cause: ", $i->{cause} );
    }
}

sub parse_asdu_type_103 {
    my $self = shift;
    my $sid  = shift;
    my $s    = \%{ $self->{sids}{$sid} };
    my $i    = \%{ $s->{i} };
    if ( $i->{cause} == 6 ) {
        &DEBUG( 2, "[103] activation" );

        # send accept and current time
        $s->{ca} = $i->{ca};
        my $data = pack( "C2S3C",
            103, 1, 7, $i->{ca},
            $i->{obj}{1}{ioa},
            $i->{obj}{1}{ioa2} )
          . &time_2_cp56_2a(gettimeofday);
        $self->frame_i_send( $sid, $data );
    }
    elsif ( $i->{cause} == 3 ) {
        &DEBUG( 2, "[103] sporadic" );

        # Start timer of Sync
        $s->{sync_timer}->remove;
        $s->{sync_timer}->add( $s->{sync_timeout} );
    }
    elsif ( $i->{cause} == 7 ) {
        &DEBUG( 2, "[103] accept of activation" );
        my ( $tm, $ms ) = &cp56_2a_2_time( $i->{obj}{1}{data} );
        my $time_diff = tv_interval( [ $tm, $ms ] );
        &DEBUG( 1, "CA: ", $i->{ca}, "; KP unix time: ",
            $tm, ", Diff: ", $time_diff );
        $s->{time_diff} = $time_diff;

        # Start timer of Sync
        $s->{sync_timer}->remove;
        $s->{sync_timer}->add( $s->{sync_timeout} );
    }
    else {
        &DEBUG( 2, "[103] unknown cause: ", $i->{cause} );
    }
}

sub parse_asdu_type_0_44 {
    my ( $addr, $value, $tm, $ms );
    my $self = shift;
    my $sid  = shift;

    my $s    = \%{ $self->{sids}{$sid} };
    my $i    = \%{ $s->{i} };
    my $type = $asdu_type{ $i->{id} }{type};

    my %result = ( $type => {} );
    for my $j ( 1 .. $i->{nobj} ) {
        if ( $i->{id} == 30 ) {
            $value = unpack( "C", $i->{obj}{$j}{data} );
            $value &= 1;
            ( $tm, $ms ) =
              cp56_2a_2_time( substr( $i->{obj}{$j}{data}, 1, 7 ) );
        }
        elsif ( $i->{id} == 35 ) {
            $value = unpack( "s", $i->{obj}{$j}{data} );
            ( $tm, $ms ) =
              cp56_2a_2_time( substr( $i->{obj}{$j}{data}, 3, 7 ) );
        }
        elsif ( $i->{id} == 36 ) {
            $value = unpack( "f", $i->{obj}{$j}{data} );
            ( $tm, $ms ) =
              cp56_2a_2_time( substr( $i->{obj}{$j}{data}, 5, 7 ) );
        }
        elsif ( $i->{id} == 37 ) {
            $value = unpack( "L", $i->{obj}{$j}{data} );
            ( $tm, $ms ) =
              cp56_2a_2_time( substr( $i->{obj}{$j}{data}, 5, 7 ) );
        }
        $tm += int( $s->{time_diff} );
        $ms += int( ( $s->{time_diff} - int( $s->{time_diff} ) ) * 1000000 );
        if ( $ms > 1000000 ) {
            $ms -= 1000000;
            $tm++;
        }
        elsif ( $ms < 0 ) {
            $ms += 1000000;
            $tm--;
        }
        $addr = $i->{obj}{$j}{ioa} + 65536 * $i->{obj}{$j}{ioa2};

        $result{$type}->{$addr} = [ $value, $tm, $ms ];
        &DEBUG( 8, "ioa: ", $addr, ", val: ", $value, " time: ",
            scalar localtime($tm), ";" );
    }
    &{ $s->{rcb} }( $self, %result );
}

sub send_asdu_type_0_44 {
    my ( $data, $cnt );
    my $self  = shift;
    my $sid   = shift;
    my $cause = shift;
    my $id    = shift;
    my $d     = shift;
    my $ca    = $self->{sids}{$sid}{ca};

    &DEBUG( 3, "send_asdu_type_0_44(): send ", scalar( keys %{$d} ),
        " row(s)" );
    foreach my $key ( keys %{$d} ) {
        $cnt++;
        if ( $id == 30 ) {
            $data .= pack( "SC2",
                ( $key % 65536 ),
                int( $key / 65536 ),
                $d->{$key}->[0] & 1 )
              . &time_2_cp56_2a( $d->{$key}->[1], $d->{$key}->[2] );
        }
        elsif ( $id == 35 ) {
            $data .= pack( "SCSC",
                ( $key % 65536 ),
                int( $key / 65536 ),
                $d->{$key}->[0], 0 )
              . &time_2_cp56_2a( $d->{$key}->[1], $d->{$key}->[2] );
        }
        elsif ( $id == 36 ) {
            $data .= pack( "SCfC",
                ( $key % 65536 ),
                int( $key / 65536 ),
                $d->{$key}->[0], 0 )
              . &time_2_cp56_2a( $d->{$key}->[1], $d->{$key}->[2] );
        }
        elsif ( $id == 37 ) {
            $data .= pack( "SCLC",
                ( $key % 65536 ),
                int( $key / 65536 ),
                $d->{$key}->[0], 0 )
              . &time_2_cp56_2a( $d->{$key}->[1], $d->{$key}->[2] );
        }
        &DEBUG(
            5,               "$cnt|--> IOA:",
            $key,            ", VALUE:",
            $d->{$key}->[0], ", TIME:",
            $d->{$key}->[1], " size of pack: ",
            length($data)
        );
        if ( length($data) >= $MAX_ASDU_SIZE - 6 - 3 - $asdu_type{$id}{size} ) {
            $self->frame_i_send( $sid,
                pack( "C2S2", $id, $cnt, $cause, $ca ) . $data );
            $cnt  = 0;
            $data = "";
        }
    }
    if ($data) {
        $self->frame_i_send( $sid,
            pack( "C2S2", $id, $cnt, $cause, $ca ) . $data );
    }
}

1;

__END__

=head1 NAME

Net::IEC104 - Perl implementation of IEC 60870-5-104 standard (server and client)

=head1 SYNOPSIS

    use Net::IEC104;
    use Time::HiRes;

    sub send_all_data {
        my $self = shift;
        my %DATA = (TI=>{},TS=>{},TII=>{});

        $DATA{TI}->{1}  = [12.34,gettimeofday]; # Tele Information (real value of physical measurement)
        $DATA{TS}->{2}  = [0,gettimeofday];     # Tele Signalization (boolean value)
        $DATA{TII}->{3} = [34567,gettimeofday]; # Tele Information Integral (32-bit counter)

        return %DATA;
    }

    my $srvr_sock = Net::IEC104->new(
        type=>"slave",
        ip=>"127.0.0.1",
        port=>"2404",
        write_callback=>\&send_all_data
    );

    $srvr_sock->listen;
    Net::IEC104::main_loop;

=head1 DESCRIPTION

This module implement IEC 60870-5-104 standard (also known as IEC 870-5-104).
IEC 870-5-104 is a network access for IEC 60870-5-101 using standard transport profiles (TCP/IP),
its application layer is based on IEC 60870-5-101. IEC 60870-5-104 enables communication between
control station and substation via a standard TCP/IP network. The TCP protocol is used for
connection-oriented secure data transmission.

Current implementation supports only ASDU NN 30,35,36,37,100,103. Its enough for now.

=head2 CONSTRUCTOR

Net::IEC104->new(...) accept following variables:

* type - type of station, must be one of "slave" (controlled station) or "master" (control station). Default "slave"

* ip   - ip address to listen on (for slave) or connect to (for master). Default "0.0.0.0"

* port - port of connection. Default 2404

* ca   - common address. Default 1

* write_callback - (slave only) ref to callback function, that returns a list with two vars: reference to class and hash with data. Hash format is as following: %HASH = ("TI" =>  { address=>[value,timestamp,microseconds], ... },"TS" => { address=>[value,timestamp,microseconds], ... },"TII" => { address=>[value,timestamp,microseconds], ... }); This function called when slave receive common interogation request from master (ASDU=100).

* read_callback - (master only) ref to callback function, that receive a list (same format as for write_callback)

* w    - W constant (default  8)

* k    - K constant (default 12)

* ts_func_num  - (slave only) ASDU number used for TS data,  default 30. If 0 - TS  never send

* ti_func_num  - (slave only) ASDU number used for TI data,  default 36. If 0 - TI  never send

* tii_func_num - (slave only) ASDU number used for TII data, default 37. If 0 - TII never send

* t0   - t0 timeout constant (30 sec)

* t1   - t1 timeout constant (15 sec)

* t2   - t2 timeout constant (10 sec)

* t3   - t3 timeout constant (20 sec)

* persist - (master only) 0 - do not reconnect after disconection, 1 - reconnect after disconnection

=head2 METHODS

connect()   - master only method. Connect to slave. After succeful connection, its activate transmission (STARTDT)
    and send common interogation request to slave (ASDU=100).

listen()    - slave only method. Start listen for masters connections.

send(CA,%HASH) - slave only method. Send spontaneous data to all masters connected to server with common address CA. %HASH format same as for write_callback function.

main_loop() - start event cycle. ( stub that call Lib::Event::even_mainloop() )

=head2 EXPORT

None by default.

=head1 EXAMPLES

=head2 client

    use Net::IEC104;

    # Print to stdout all received data;
    sub take_data_cb {
        my $self = shift;
        my %hash = @_;
        foreach my $key (keys %hash) {
            print $key,"\n";
            foreach my $addr (keys %{$hash{$key}}) {
                print "\t";
                print "address:\t",      $addr, "\n\t";
                print "value:\t",        $hash{$key}->{$addr}->[0], "\n\t";
                print "seconds:\t",      $hash{$key}->{$addr}->[1], "\n";
                print "microseconds:\t", $hash{$key}->{$addr}->[2], "\n";
            }
        }
    }

    my $master = Net::IEC104->new(
                type => "master",
                ip   => "127.0.0.1",
                port => 2404,
                ca   => 1,
                w    => 8,
                k    => 12,
                persist => 1,
                read_callback => \&take_data_cb,
    );
  
    $master->connect();
    Net::IEC104::main_loop();

=head1 SEE ALSO

Idea and design of implementation of library based on OpenMRTS project (http://sourceforge.net/projects/mrts/) written by Sitkarev Grigoriy.

=head1 AUTHOR

Vladimir Lettiev, E<lt>thecrux@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008-2011 by Vladimir Lettiev

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut