Merge branch 'main' into dev
style code
This commit is contained in:
316
iec1107.pm
316
iec1107.pm
@@ -1,316 +0,0 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# perl module for accessing a IEC1107 device
|
||||
# This is my first my perl module and these resources were a good kickstart
|
||||
# https://learn.perl.org/books/beginning-perl/
|
||||
# https://wiki.volkszaehler.org/hardware/channels/meters/power/eastron_drs155m
|
||||
# Menschel (C) 2020-2021
|
||||
|
||||
package iec1107; # we name our package iec1107 as this is the original protocol name
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
use Device::SerialPort;
|
||||
|
||||
#for time conversion
|
||||
use DateTime::Format::Strptime qw( strptime );
|
||||
use DateTime;
|
||||
|
||||
#constants
|
||||
our $SOH = chr(0x01);
|
||||
our $STX = chr(0x02);
|
||||
our $ETX = chr(0x03);
|
||||
our $EOT = chr(0x04);
|
||||
|
||||
our $ACK = chr(0x06);
|
||||
our $NACK = chr(0x15);
|
||||
|
||||
our $CRLF = "\r\n";
|
||||
our $STARTCHARACTER = "/";
|
||||
our $TRANSMISSIONREQUESTCOMMAND = "?";
|
||||
our $ENDCHARACTER = "!";
|
||||
|
||||
our %drs110m_values = (
|
||||
#'<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'],
|
||||
'Active Power' =>[ 3, \&_scale_mul_by_10, 'W'],
|
||||
'Reactive Power'=>[ 4, \&_scale_mul_by_10,'VAr'],
|
||||
'Apparent Power'=>[ 5, \&_scale_mul_by_10, 'VA'],
|
||||
'Active Energy' =>[10, \&_scale_1_to_1, 'Wh'],
|
||||
'Time' =>[31, \&_scale_raw_time_to_datetime, ''],
|
||||
'Temperature' =>[32, \&_scale_to_temp, '°C'],
|
||||
);
|
||||
#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
|
||||
# {"port"=>$port, #perl automatically converts this to a reference
|
||||
# "id"=>$id,
|
||||
# "passwd"=>$passwd,
|
||||
#}
|
||||
my $class = shift;
|
||||
my $self = {@_};
|
||||
bless($self,$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));
|
||||
#Note: There is an automatic sleep from the serial timeout, so we don't sleep here
|
||||
if (!$res){
|
||||
#a second wakeup call is not required every time, only when the device was asleep.
|
||||
$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(_generate_r1_msg("reg"=>$drs110m_values{$measurement}[0]));
|
||||
($addr,$val) = _interpret_r1_msg($res);
|
||||
if (defined($addr)){
|
||||
if ($addr == $drs110m_values{$measurement}[0]){
|
||||
$val = &{$drs110m_values{$measurement}[1]}($val);
|
||||
$unit = $drs110m_values{$measurement}[2];
|
||||
$valstr = sprintf("%s %s",$val,$unit);
|
||||
$self->{regs}{$measurement}=$valstr;
|
||||
}
|
||||
else{
|
||||
die("Found $addr but expected $drs110m_values{$measurement}[0]");
|
||||
};
|
||||
}
|
||||
else {
|
||||
die("No Response for $measurement");
|
||||
};
|
||||
}
|
||||
|
||||
return $self;
|
||||
};
|
||||
|
||||
sub log_off() {
|
||||
my $self = shift;
|
||||
my $res;
|
||||
unless (ref $self){croak "call with an object, not a class";}
|
||||
$res = $self->_xfer(_generate_b0_msg());
|
||||
return $self;
|
||||
};
|
||||
|
||||
sub write_reg($$) {
|
||||
my $self = shift;
|
||||
my ($reg, $val) = @_;
|
||||
unless (ref $self){croak "call with an object, not a class";}
|
||||
|
||||
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() {
|
||||
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() {
|
||||
my $self = shift;
|
||||
my $res;
|
||||
unless (ref $self){croak "call with an object, not a class";}
|
||||
$self->start_communication()->start_programming_mode();
|
||||
$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() {
|
||||
my $self = shift;
|
||||
my $res;
|
||||
unless (ref $self){croak "call with an object, not a class";}
|
||||
$self->start_communication()->start_programming_mode();
|
||||
$res = $self->write_reg(0x40, "00000000");
|
||||
# this function does not reliably return an ACK, to be checked
|
||||
$self->log_off();
|
||||
return $self;
|
||||
};
|
||||
|
||||
sub _xfer {
|
||||
my $self = shift;
|
||||
my ($cmd) = @_;
|
||||
my $count;
|
||||
my $res;
|
||||
$self->port->lookclear;
|
||||
$self->port->write( $cmd );
|
||||
($count,$res)=$self->port->read(32);
|
||||
return $res;
|
||||
};
|
||||
|
||||
|
||||
# Object accessor methods
|
||||
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} }
|
||||
|
||||
|
||||
|
||||
|
||||
#basic non-object functions
|
||||
sub _interpret_r1_msg($){
|
||||
my ($str) = @_;
|
||||
my $val;
|
||||
my $addr;
|
||||
if($str =~ m/\((\S+)\)/) {
|
||||
$val = $1;
|
||||
if($str =~ m/(\d+)\(/) {
|
||||
$addr = $1;
|
||||
};
|
||||
};
|
||||
return $addr,$val;
|
||||
};
|
||||
|
||||
|
||||
sub _scale_div_by_10($){
|
||||
my ($val) = @_;
|
||||
return $val/10;
|
||||
};
|
||||
|
||||
sub _scale_mul_by_10($){
|
||||
my ($val) = @_;
|
||||
return $val*10;
|
||||
};
|
||||
|
||||
sub _scale_1_to_1($){
|
||||
my ($val) = @_;
|
||||
return $val;
|
||||
};
|
||||
|
||||
sub _scale_raw_time_to_datetime($){
|
||||
my ($str) = @_;
|
||||
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);
|
||||
return $str;
|
||||
};
|
||||
|
||||
sub _scale_to_temp($){
|
||||
my ($val) = @_;
|
||||
my $hex = "";
|
||||
foreach (split '',$val){
|
||||
$hex .= sprintf("%X", ord($_)-0x30);
|
||||
};
|
||||
return hex($hex);
|
||||
};
|
||||
|
||||
sub _calc_bcc($){
|
||||
my ($val) = @_;
|
||||
my $bcc = 0;
|
||||
foreach (split'',substr($val,1)){
|
||||
$bcc ^= ord($_);
|
||||
}
|
||||
return $bcc;
|
||||
};
|
||||
|
||||
sub _generate_r1_msg(%){
|
||||
my %args = @_;
|
||||
my $reg = $args{reg};
|
||||
my $regstr = sprintf("%08d()",$reg);
|
||||
my $msg=_generate_programming_command_message("command"=>"R","commandtype"=>1,"data"=>$regstr);
|
||||
return $msg;
|
||||
};
|
||||
|
||||
|
||||
sub _generate_w1_msg(%){
|
||||
my %args = @_;
|
||||
my $reg = $args{reg};
|
||||
my $val = $args{val};
|
||||
my $regstr = sprintf("%08d(%d)",$reg,$val);
|
||||
my $msg=_generate_programming_command_message("command"=>"W","commandtype"=>1,"data"=>$regstr);
|
||||
return $msg;
|
||||
};
|
||||
|
||||
|
||||
sub _generate_p1_msg(%){
|
||||
my %args = @_;
|
||||
my $passwd = $args{password};
|
||||
my $passwdstr = sprintf("(%08d)",$passwd);
|
||||
my $msg=_generate_programming_command_message("command"=>"P","commandtype"=>1,"data"=>$passwdstr);
|
||||
return $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 = @_;
|
||||
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;
|
||||
$msg .= chr(_calc_bcc($msg));
|
||||
return $msg;
|
||||
};
|
||||
|
||||
sub _generate_ack_optionselect_msg(%){
|
||||
my %args = @_;
|
||||
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 = @_;
|
||||
my $serialnumber = $args{serialnumber};
|
||||
my $snstr = sprintf("%012d",$serialnumber);
|
||||
my $msg = $STARTCHARACTER.$TRANSMISSIONREQUESTCOMMAND.$snstr.$ENDCHARACTER.$CRLF;
|
||||
return $msg;
|
||||
};
|
||||
|
||||
|
||||
1;
|
||||
@@ -13,12 +13,6 @@ my $workdir = getcwd;
|
||||
|
||||
push @INC, "$workdir/lib";
|
||||
|
||||
# sub BEGIN {
|
||||
# push @INC, "$workdir/lib";
|
||||
|
||||
# return;
|
||||
# }
|
||||
|
||||
require iec1107;
|
||||
|
||||
my $port = Device::SerialPort->new(
|
||||
|
||||
Reference in New Issue
Block a user