changed to oop approach with perl module
This commit is contained in:
Patrick Menschel
parent
649d1bd82a
commit
44dd191cf0
305
iec1107.pm
Executable file
305
iec1107.pm
Executable file
@ -0,0 +1,305 @@
|
|||||||
|
#!/usr/bin/perl
|
||||||
|
#
|
||||||
|
# This is actually my first attempt with perl.
|
||||||
|
# This script borrows parts of https://wiki.volkszaehler.org/hardware/channels/meters/power/eastron_drs155m
|
||||||
|
# which itself borrows parts of http://www.ip-symcon.de/forum/threads/21407-Stromz%C3%A4hler-mit-RS485/page2
|
||||||
|
# The general functions have been developed in python3, see https://github.com/menschel/pyehz
|
||||||
|
# Use and copy as you wish.
|
||||||
|
# Menschel (C) 2020
|
||||||
|
|
||||||
|
package iec1107; # we name our package iec1107 as this is the original protocol name
|
||||||
|
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
use Carp; #TODO: this is for the "ref" check
|
||||||
|
|
||||||
|
use Device::SerialPort;
|
||||||
|
|
||||||
|
#for time conversion
|
||||||
|
use POSIX::strptime qw( strptime );
|
||||||
|
use POSIX qw{strftime};
|
||||||
|
|
||||||
|
#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 = "!";
|
||||||
|
|
||||||
|
#function prototypes
|
||||||
|
|
||||||
|
#serial transfer function
|
||||||
|
#sub _xfer($);
|
||||||
|
|
||||||
|
#read 1 message data interpretation
|
||||||
|
#sub _interpret_r1_msg($);
|
||||||
|
|
||||||
|
#scaling functions
|
||||||
|
#sub _scale_div_by_10($);
|
||||||
|
#sub _scale_mul_by_10($);
|
||||||
|
#sub _scale_1_to_1($);
|
||||||
|
#sub _scale_to_time($);
|
||||||
|
#sub _scale_to_temp($);
|
||||||
|
|
||||||
|
#calculate message checksum
|
||||||
|
#sub _calc_bcc($);
|
||||||
|
|
||||||
|
|
||||||
|
#message generation functions
|
||||||
|
#sub _generate_r1_msg(%);
|
||||||
|
#sub _generate_p1_msg(%);
|
||||||
|
#sub _generate_b0_msg();
|
||||||
|
#sub _generate_programming_command_message(%);
|
||||||
|
#sub _generate_ack_optionselect_msg(%);
|
||||||
|
#sub _generate_request_message(%);
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
my %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_to_time, ''],
|
||||||
|
'Temperature' =>[32, \&_scale_to_temp, '°C'],
|
||||||
|
);
|
||||||
|
|
||||||
|
|
||||||
|
sub new(\$$$){
|
||||||
|
#we expect a HASH consisting of a reference to a valid port, an ID and a password
|
||||||
|
# {"port"=>\$port,
|
||||||
|
# "serialID"=>$id,
|
||||||
|
# "passwd"=>$passwd,
|
||||||
|
#}
|
||||||
|
my $class = shift;
|
||||||
|
my $self = {@_};#creates reference to HASH
|
||||||
|
bless($self,$class);#changes class of $object to "drs110m"
|
||||||
|
$self->_init;
|
||||||
|
return $self;
|
||||||
|
};
|
||||||
|
|
||||||
|
sub _init {
|
||||||
|
my $self = shift;
|
||||||
|
#we expect $self->port to be setup correctly so nothing to do here
|
||||||
|
|
||||||
|
#for whatever reason _init() does not return anything in the LEARN PERL Examples
|
||||||
|
return;
|
||||||
|
};
|
||||||
|
|
||||||
|
sub start_communication {
|
||||||
|
my $self = shift;
|
||||||
|
my $res;
|
||||||
|
$res = $self->_xfer(_generate_request_message("serialnumber"=>$self->{serialID}));
|
||||||
|
#there is an automatic sleep from the serial timeout
|
||||||
|
if (!$res){
|
||||||
|
#a second wakeup call is not required every time but when the device was asleep.
|
||||||
|
$res = $self->_xfer(_generate_request_message("serialnumber"=>$self->{serialID}));
|
||||||
|
};
|
||||||
|
return $self; #utility functions should return self according to LEARN PERL examples
|
||||||
|
};
|
||||||
|
|
||||||
|
sub start_programming_mode {
|
||||||
|
my $self = shift;
|
||||||
|
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; #utility functions should return self according to LEARN PERL examples
|
||||||
|
};
|
||||||
|
|
||||||
|
|
||||||
|
sub update_values {
|
||||||
|
my $self = shift;
|
||||||
|
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)){#sanity check
|
||||||
|
if ($addr == $drs110m_values{$measurement}[0]){#paranoia check
|
||||||
|
$val = &{$drs110m_values{$measurement}[1]}($val);
|
||||||
|
$unit = $drs110m_values{$measurement}[2];
|
||||||
|
$valstr = sprintf("%15s : %s %s\n",$measurement,$val,$unit);
|
||||||
|
print($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;
|
||||||
|
$res = $self->_xfer(_generate_b0_msg());
|
||||||
|
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;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
#TODO: we have to include this obj class check with "ref" later
|
||||||
|
#sub do_something() {
|
||||||
|
# my $self = shift;
|
||||||
|
# unless (ref $self){"croak Should call surname() with an object, not a class";}
|
||||||
|
# return $self->{surname}
|
||||||
|
#}
|
||||||
|
|
||||||
|
#TODO: we need object accessor methodes later
|
||||||
|
# Object accessor methods
|
||||||
|
# interesting function that writes if there is an input, apparently
|
||||||
|
#sub address { $_[0]->{address }=$_[1] if defined $_[1]; $_[0]->{address } }
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#basic 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_to_time($){
|
||||||
|
#"19112703192714" => 2019-11-27 19:27:14
|
||||||
|
my ($str) = @_;
|
||||||
|
#print("$str \n");
|
||||||
|
my $fmt = "%y%m%d0%w%H%M%S";
|
||||||
|
my @time = (POSIX::strptime($str,$fmt))[0..7];
|
||||||
|
if (wantarray){
|
||||||
|
return @time;
|
||||||
|
}
|
||||||
|
else{
|
||||||
|
return strftime("%Y-%m-%d %H:%M:%S",@time);
|
||||||
|
};
|
||||||
|
};
|
||||||
|
|
||||||
|
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_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;#Todo: make the special characters nicely, note there is no bcc for this msg type
|
||||||
|
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;#for whatever reason
|
||||||
272
test_drs110m.pl
Executable file → Normal file
272
test_drs110m.pl
Executable file → Normal file
@ -1,21 +1,15 @@
|
|||||||
#!/usr/bin/perl
|
#!/usr/bin/perl
|
||||||
#
|
#
|
||||||
# This is actually my first attempt with perl.
|
|
||||||
# This script borrows parts of https://wiki.volkszaehler.org/hardware/channels/meters/power/eastron_drs155m
|
|
||||||
# which itself borrows parts of http://www.ip-symcon.de/forum/threads/21407-Stromz%C3%A4hler-mit-RS485/page2
|
|
||||||
# The general functions have been developed in python3, see https://github.com/menschel/pyehz
|
|
||||||
# Use and copy as you wish.
|
|
||||||
# Menschel (C) 2020
|
|
||||||
|
|
||||||
use strict;
|
use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
|
|
||||||
use Device::SerialPort;
|
|
||||||
|
|
||||||
#for time conversion
|
sub BEGIN {
|
||||||
use POSIX::strptime qw( strptime );
|
push @INC, ".";#how long did we take for this absolute simple path include ?!
|
||||||
use POSIX qw{strftime};
|
}
|
||||||
|
|
||||||
|
|
||||||
|
use iec1107;
|
||||||
|
|
||||||
my $port = Device::SerialPort->new("/dev/ttyUSB0") || die $!;
|
my $port = Device::SerialPort->new("/dev/ttyUSB0") || die $!;
|
||||||
$port->baudrate(9600);
|
$port->baudrate(9600);
|
||||||
$port->databits(7);
|
$port->databits(7);
|
||||||
@ -26,252 +20,26 @@ $port->write_settings;
|
|||||||
|
|
||||||
$port->purge_all();
|
$port->purge_all();
|
||||||
$port->read_char_time(0); # don't wait for each character
|
$port->read_char_time(0); # don't wait for each character
|
||||||
$port->read_const_time(100); # 100 millisecond per unfulfilled "read" call
|
$port->read_const_time(150); # 100 millisecond per unfulfilled "read" call - this was too short and lead into race conditions
|
||||||
|
|
||||||
my $serialID = "001613300153"; # The serial number of the specific device 12-digits long.
|
my @serialIDs = (1613300152,1613300153);
|
||||||
# It is possible to find out the device id of a single device on RS-485 9600@7E1 by sending "/?!\r\n"
|
# It is possible to find out the device id of a single device on RS-485 9600@7E1 by sending "/?!\r\n"
|
||||||
my $password = "00000000"; # Standard password 0 over 8-digits
|
my $password = "00000000"; # Standard password 0 over 8-digits
|
||||||
|
|
||||||
|
|
||||||
#constants
|
|
||||||
my $SOH = chr(0x01);
|
|
||||||
my $STX = chr(0x02);
|
|
||||||
my $ETX = chr(0x03);
|
|
||||||
my $EOT = chr(0x04);
|
|
||||||
|
|
||||||
my $ACK = chr(0x06);
|
for my $serialID (@serialIDs) {
|
||||||
my $NACK = chr(0x15);
|
my $drs110m = iec1107->new("port"=>$port,"serialID"=>$serialID,"passwd"=>$password);
|
||||||
|
|
||||||
my $CRLF = "\r\n";
|
|
||||||
my $STARTCHARACTER = "/";
|
|
||||||
my $TRANSMISSIONREQUESTCOMMAND = "?";
|
|
||||||
my $ENDCHARACTER = "!";
|
|
||||||
|
|
||||||
#function prototypes
|
|
||||||
|
|
||||||
#serial transfer function
|
|
||||||
sub xfer($);
|
|
||||||
|
|
||||||
#read 1 message data interpretation
|
|
||||||
sub interpret_r1_msg($);
|
|
||||||
|
|
||||||
#scaling functions
|
|
||||||
sub scale_div_by_10($);
|
|
||||||
sub scale_mul_by_10($);
|
|
||||||
sub scale_1_to_1($);
|
|
||||||
sub scale_to_time($);
|
|
||||||
sub scale_to_temp($);
|
|
||||||
|
|
||||||
#calculate message checksum
|
|
||||||
sub calc_bcc($);
|
|
||||||
|
|
||||||
|
|
||||||
#message generation functions
|
|
||||||
sub generate_r1_msg(%);
|
|
||||||
sub generate_p1_msg(%);
|
|
||||||
sub generate_b0_msg();
|
|
||||||
sub generate_programming_command_message(%);
|
|
||||||
sub generate_ack_optionselect_msg(%);
|
|
||||||
sub generate_request_message(%);
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#main() starts here
|
|
||||||
|
|
||||||
my %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_to_time, ''],
|
|
||||||
'Temperature' =>[32, \&scale_to_temp, '°C'],
|
|
||||||
);
|
|
||||||
#generate messages first and only once for a run
|
|
||||||
my %msgs = ();
|
|
||||||
while ( my ($measurement, $vals) = each(%drs110m_values) ) {
|
|
||||||
$msgs{$measurement} = generate_r1_msg("reg"=>$drs110m_values{$measurement}[0]);
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#communication part starts here
|
|
||||||
my $res;
|
|
||||||
|
|
||||||
$res = xfer(generate_request_message("serialnumber"=>$serialID));
|
|
||||||
#there is an automatic sleep from the serial timeout
|
|
||||||
if (!$res){
|
|
||||||
#a second wakeup call is not required every time but when the device was asleep.
|
|
||||||
$res = xfer(generate_request_message("serialnumber"=>$serialID));
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
$res = xfer(generate_ack_optionselect_msg("protocol"=>0,"mode"=>1));#note: mode 1 is programming mode, obviously privileges are needed for register access
|
|
||||||
$res = xfer(generate_p1_msg("password"=>$password));
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
my $valstr;
|
|
||||||
my $unit;
|
|
||||||
my ($addr,$val);
|
|
||||||
while ( my ($measurement, $vals) = each(%drs110m_values) ) {
|
|
||||||
$res = xfer( $msgs{$measurement} );
|
|
||||||
($addr,$val) = interpret_r1_msg($res);
|
|
||||||
if (defined($addr)){#sanity check
|
|
||||||
if ($addr == $drs110m_values{$measurement}[0]){#paranoia check
|
|
||||||
$val = &{$drs110m_values{$measurement}[1]}($val);
|
|
||||||
$unit = $drs110m_values{$measurement}[2];
|
|
||||||
$valstr = sprintf("%15s : %s %s\n",$measurement,$val,$unit);
|
|
||||||
print($valstr);
|
|
||||||
}
|
|
||||||
else{
|
|
||||||
die("Found $addr but expected $drs110m_values{$measurement}[0]");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
die("No Response for $measurement");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
#print("start communication to $serialID\n");
|
||||||
|
print("Meter: $serialID\n");
|
||||||
|
$drs110m->start_communication();
|
||||||
|
#print("start programming mode\n");
|
||||||
|
$drs110m->start_programming_mode();
|
||||||
|
#print("update values\n");
|
||||||
|
$drs110m->update_values();
|
||||||
|
#print("log off from $serialID\n");
|
||||||
|
$drs110m->log_off();
|
||||||
}
|
}
|
||||||
|
|
||||||
#log off
|
|
||||||
$res = xfer(generate_b0_msg());
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#functions
|
|
||||||
sub xfer($){
|
|
||||||
my ($cmd) = @_;
|
|
||||||
my $count;
|
|
||||||
my $res;
|
|
||||||
|
|
||||||
$port->lookclear;
|
|
||||||
$port->write( $cmd );
|
|
||||||
|
|
||||||
($count,$res)=$port->read(32);
|
|
||||||
|
|
||||||
return $res;
|
|
||||||
}
|
|
||||||
|
|
||||||
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_to_time($){
|
|
||||||
#"19112703192714" => 2019-11-27 19:27:14
|
|
||||||
my ($str) = @_;
|
|
||||||
#print("$str \n");
|
|
||||||
my $fmt = "%y%m%d0%w%H%M%S";
|
|
||||||
my @time = (POSIX::strptime($str,$fmt))[0..7];
|
|
||||||
if (wantarray){
|
|
||||||
return @time;
|
|
||||||
}
|
|
||||||
else{
|
|
||||||
return strftime("%Y-%m-%d %H:%M:%S",@time);
|
|
||||||
};
|
|
||||||
};
|
|
||||||
|
|
||||||
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_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;#Todo: make the special characters nicely, note there is no bcc for this msg type
|
|
||||||
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;
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user