marko/drs110m
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

add call exit

Browse Source
This commit is contained in:
Marko Oldenburg 2022-01-18 19:09:45 +01:00
parent c94340f92e
commit 1179c54af9
1 changed files with 136 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

199
lib/iec1107.pm
View File

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