From 1179c54af9ea2b5b6afba5cf40d6455f51f46a6e Mon Sep 17 00:00:00 2001 From: Marko Oldenburg Date: Tue, 18 Jan 2022 19:09:45 +0100 Subject: [PATCH] add call exit --- lib/iec1107.pm | 199 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 136 insertions(+), 63 deletions(-) diff --git a/lib/iec1107.pm b/lib/iec1107.pm index 82e8a7b..c40906f 100755 --- a/lib/iec1107.pm +++ b/lib/iec1107.pm @@ -33,9 +33,8 @@ our $STARTCHARACTER = "/"; our $TRANSMISSIONREQUESTCOMMAND = "?"; our $ENDCHARACTER = "!"; -our %drs110m_values = ( - - #''=>[
,,''], +our %drs110m_values = ( ## no critic (Package variable declared or used) + #''=>[
,,''], 'Voltage' => [ 0, \&_scale_div_by_10, 'V' ], 'Current' => [ 1, \&_scale_div_by_10, 'A' ], 'Frequency' => [ 2, \&_scale_div_by_10, 'Hz' ], @@ -46,32 +45,45 @@ our %drs110m_values = ( 'Time' => [ 31, \&_scale_raw_time_to_datetime, '' ], 'Temperature' => [ 32, \&_scale_to_temp, '°C' ], ); +## use critic #actually there are more registers, but who cares about cosphi for example?! -sub new(\$$$) { - -#we expect a HASH consisting of a reference to a valid and correctly set up port, an ID and a password +=head1 METHODS + +=head2 Constructor new + +# we expect a HASH consisting of a reference to a valid and correctly set up port, an ID and a password # {"port"=>$port, #perl automatically converts this to a reference # "id"=>$id, # "passwd"=>$passwd, -#} - my $class = shift; - my $self = {@_}; - bless( $self, $class ); +# } + +=cut + +sub new { ## no critic (always unpack @_ first) + my $class = shift; + my @options = @_ ? $_[0] =~ /ARRAY/ ? @{ $_[0] } : @_ : (); + + my $self = bless {@options} => $class; $self->_init; + return $self; + } sub _init { my $self = shift; + $self->{"regs"} = (); + return; } sub start_communication { my $self = shift; unless ( ref $self ) { croak "call with an object, not a class"; } + my $res; $res = $self->_xfer( _generate_request_message( "serialnumber" => $self->id ) ); @@ -83,27 +95,32 @@ sub start_communication { $res = $self->_xfer( _generate_request_message( "serialnumber" => $self->id ) ); } + return $self; } sub start_programming_mode { my $self = shift; unless ( ref $self ) { croak "call with an object, not a class"; } + my $res; $res = $self->_xfer( _generate_ack_optionselect_msg( "protocol" => 0, "mode" => 1 ) ); #note: mode 1 is programming mode, obviously privileges are needed for register access $res = $self->_xfer( _generate_p1_msg( "password" => $self->passwd ) ); + return $self; } sub update_values { my $self = shift; unless ( ref $self ) { croak "call with an object, not a class"; } + my $res; my $valstr; my $unit; + my ( $addr, $val ); while ( my ( $measurement, $vals ) = each(%drs110m_values) ) { $res = $self->_xfer( @@ -117,11 +134,15 @@ sub update_values { $self->{regs}{$measurement} = $valstr; } else { - warn("Found $addr but expected $drs110m_values{$measurement}[0]" + ## no critic (warn used instead of carp) + warn( + "Found $addr but expected $drs110m_values{$measurement}[0]" + ); } } else { + ## no critic (warn used instead of carp) warn("No Response for $measurement"); } } @@ -129,215 +150,267 @@ sub update_values { return $self; } -sub log_off() { +sub log_off { my $self = shift; - my $res; unless ( ref $self ) { croak "call with an object, not a class"; } + + my $res; $res = $self->_xfer( _generate_b0_msg() ); + return $self; } -sub write_reg($$) { +sub write_reg { ## no critic (always unpack @_ first) my $self = shift; - my ( $reg, $val ) = @_; unless ( ref $self ) { croak "call with an object, not a class"; } + my ( $reg, $val ) = @_; my $res = $self->_xfer( _generate_w1_msg( "reg" => $reg, "val" => $val ) ); + if ( $res ne $ACK ) { print("No Ack for write operation $reg : $val \n"); } + return $self; } -sub get_values() { +sub get_values { my $self = shift; - my $res; unless ( ref $self ) { croak "call with an object, not a class"; } + $self->start_communication()->start_programming_mode()->update_values() ->log_off(); + return $self->regs; } -sub set_clock() { +sub set_clock { my $self = shift; - my $res; unless ( ref $self ) { croak "call with an object, not a class"; } + $self->start_communication()->start_programming_mode(); + + my $res; $res = $self->write_reg( 31, _scale_datetime_to_raw_time( DateTime->now() ) ); # this function reliably returns an ACK $self->log_off(); + return $self; } -sub reset_energy() { +sub reset_energy { my $self = shift; - my $res; unless ( ref $self ) { croak "call with an object, not a class"; } + $self->start_communication()->start_programming_mode(); + + my $res; $res = $self->write_reg( 0x40, "00000000" ); # this function does not reliably return an ACK, to be checked $self->log_off(); + return $self; } -sub _xfer { +sub _xfer { ## no critic (always unpack @_ first) my $self = shift; - my ($cmd) = @_; + my $cmd = @_; + my $count; my $res; + $self->port->lookclear; $self->port->write($cmd); + ( $count, $res ) = $self->port->read(32); + return $res; } # Object accessor methods +## no critic (no return in subs) sub port { $_[0]->{port} = $_[1] if defined $_[1]; $_[0]->{port} } sub id { $_[0]->{id} = $_[1] if defined $_[1]; $_[0]->{id} } sub passwd { $_[0]->{passwd} = $_[1] if defined $_[1]; $_[0]->{passwd} } sub regs { $_[0]->{regs} = $_[1] if defined $_[1]; $_[0]->{regs} } +## use critic #basic non-object functions -sub _interpret_r1_msg($) { - my ($str) = @_; +sub _interpret_r1_msg { + my $str = shift; + my $val; my $addr; - if ( $str =~ m/\((\S+)\)/ ) { + + if ( $str =~ m/\((\S+)\)/x ) { $val = $1; - if ( $str =~ m/(\d+)\(/ ) { + if ( $str =~ m/(\d+)\(/x ) { $addr = $1; } } + return $addr, $val; } -sub _scale_div_by_10($) { - my ($val) = @_; +sub _scale_div_by_10 { + my $val = shift; + return $val / 10; } -sub _scale_mul_by_10($) { - my ($val) = @_; +sub _scale_mul_by_10 { + my $val = shift; + return $val * 10; } -sub _scale_1_to_1($) { - my ($val) = @_; +sub _scale_1_to_1 { + my $val = shift; + return $val; } -sub _scale_raw_time_to_datetime($) { - my ($str) = @_; - my $fmt = "%y%m%d%w%H%M%S"; - my $dt = strptime( $fmt, $str ); +sub _scale_raw_time_to_datetime { + my $str = shift; + + my $fmt = "%y%m%d%w%H%M%S"; + my $dt = strptime( $fmt, $str ); + return $dt; } -sub _scale_datetime_to_raw_time($) { - my ($dt) = @_; - my $fmt = "%y%m%d0%w%H%M%S"; - my $str = $dt->strftime($fmt); +sub _scale_datetime_to_raw_time { + my $dt = shift; + + my $fmt = "%y%m%d0%w%H%M%S"; + my $str = $dt->strftime($fmt); + return $str; } -sub _scale_to_temp($) { - my ($val) = @_; +sub _scale_to_temp { + my $val = shift; + my $hex = ""; foreach ( split '', $val ) { $hex .= sprintf( "%X", ord($_) - 0x30 ); } + return hex($hex); } -sub _calc_bcc($) { - my ($val) = @_; +sub _calc_bcc { + my $val = shift; my $bcc = 0; + foreach ( split '', substr( $val, 1 ) ) { $bcc ^= ord($_); } + return $bcc; } -sub _generate_r1_msg(%) { - my %args = @_; +sub _generate_r1_msg { + my %args = shift; + my $reg = $args{reg}; my $regstr = sprintf( "%08d()", $reg ); - my $msg = _generate_programming_command_message( + + my $msg = _generate_programming_command_message( "command" => "R", "commandtype" => 1, "data" => $regstr ); + return $msg; } -sub _generate_w1_msg(%) { - my %args = @_; +sub _generate_w1_msg { + my %args = shift; + my $reg = $args{reg}; my $val = $args{val}; my $regstr = sprintf( "%08d(%d)", $reg, $val ); - my $msg = _generate_programming_command_message( + + my $msg = _generate_programming_command_message( "command" => "W", "commandtype" => 1, "data" => $regstr ); + return $msg; } -sub _generate_p1_msg(%) { - my %args = @_; +sub _generate_p1_msg { + my %args = shift; + my $passwd = $args{password}; my $passwdstr = sprintf( "(%08d)", $passwd ); - my $msg = _generate_programming_command_message( + + my $msg = _generate_programming_command_message( "command" => "P", "commandtype" => 1, "data" => $passwdstr ); + return $msg; } -sub _generate_b0_msg() { +sub _generate_b0_msg { my $msg = _generate_programming_command_message( "command" => "B", "commandtype" => 0, "data" => "" ); + return $msg; } -sub _generate_programming_command_message(%) { - my %args = @_; +sub _generate_programming_command_message { + my %args = shift; + my $command = $args{command}; my $commandtype = $args{commandtype}; my $data = $args{data}; - my $cmdstr = sprintf( "%s%d", $command, $commandtype ); - my $msg = $SOH . $cmdstr . $STX . $data . $ETX; + + my $cmdstr = sprintf( "%s%d", $command, $commandtype ); + my $msg = $SOH . $cmdstr . $STX . $data . $ETX; + $msg .= chr( _calc_bcc($msg) ); + return $msg; } -sub _generate_ack_optionselect_msg(%) { - my %args = @_; +sub _generate_ack_optionselect_msg { + my %args = shift; + my $protocol = $args{protocol}; my $mode = $args{mode}; + my $msgstr = sprintf( "%d:%d", $protocol, $mode ); #the ':' is the baudrate identifier + my $msg = $ACK . $msgstr . $CRLF; + return $msg; } -sub _generate_request_message(%) { - my %args = @_; +sub _generate_request_message { + my %args = shift; + my $serialnumber = $args{serialnumber}; my $snstr = sprintf( "%012d", $serialnumber ); + my $msg = $STARTCHARACTER . $TRANSMISSIONREQUESTCOMMAND . $snstr . $ENDCHARACTER . $CRLF; + return $msg; }