add call exit
This commit is contained in:
parent
c94340f92e
commit
1179c54af9
199
lib/iec1107.pm
199
lib/iec1107.pm
@ -33,9 +33,8 @@ our $STARTCHARACTER = "/";
|
||||
our $TRANSMISSIONREQUESTCOMMAND = "?";
|
||||
our $ENDCHARACTER = "!";
|
||||
|
||||
our %drs110m_values = (
|
||||
|
||||
#'<measurement>'=>[<address>,<scalingfunction>,'<unit>'],
|
||||
our %drs110m_values = ( ## no critic (Package variable declared or used)
|
||||
#'<measurement>'=>[<address>,<scalingfunction>,'<unit>'],
|
||||
'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;
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user