Never been one to let the carrier drop

Charger amps

#!/usr/bin/perl

use Device::Modbus::TCP::Client;
my $client = Device::Modbus::TCP::Client->new(

         host => ‘put your GX ip or name here’

);
$config = 1 if(“config” ~~ @ARGV);

$chargers = [ 223, 224, 226, 238, 239 ]; # devices
if($config) {

        print “graph_title charger amps\n”;

        print “graph_category victron\n”;

        foreach $charger (@{$chargers}) {

                print $charger . “_amps.label Amps\n”;

        }

} else {

        foreach $charger (@{$chargers}) {

                my $req = $client->read_holding_registers( unit => $charger, address => 772, quantity => 1 );

                $client->send_request($req) || die “Send error: $!”;

                my $response = $client->receive_response;

                print $charger . “_amps.value ” . uint16_to_int( @{$response->{‘message’}->{‘values’}}[0]) / 10 . “\n”;
        }

}
sub uint16_to_int {

    my $uint16 = shift;

    return $uint16 > 0x7FFF ? $uint16 – 0x10000 : $uint16;

}

Charger overall power

#!/usr/bin/perl

use Device::Modbus::TCP::Client;
my $client = Device::Modbus::TCP::Client->new(

         host => ‘put your GX ip or name here’

);
$config = 1 if(“config” ~~ @ARGV);
$chargers = [ 223, 224, 226, 238, 239 ]; # adjust with your actual list. See Settings -> Services -> Modbus for a list
if($config) {

        print “graph_title charger total watts\n”;

        print “graph_category victron\n”;

        print “total_watts.label watts\n”;

} else {

        my $total = 0;
        foreach $charger (@{$chargers}) {

                my $req = $client->read_holding_registers( unit => $charger, address => 789, quantity => 1 );

                $client->send_request($req) || die “Send error: $!”;

                my $response = $client->receive_response;

                $total += uint16_to_int( @{$response->{‘message’}->{‘values’}}[0]) / 10;

        }
        print “total_watts.value $total\n”;

}
sub uint16_to_int {

    my $uint16 = shift;

    return $uint16 > 0x7FFF ? $uint16 – 0x10000 : $uint16;

}

Charger individual power

#!/usr/bin/perl

use Device::Modbus::TCP::Client;
my $client = Device::Modbus::TCP::Client->new(

         host => ‘put your GX name or IP here’

);
$config = 1 if(“config” ~~ @ARGV);
$chargers = [ 223, 224, 226, 238, 239 ];
if($config) {

        print “graph_title charger watts\n”;

        print “graph_category victron\n”;

        foreach $charger (@{$chargers}) {

                print $charger . “_watts.label Amps\n”;

        }

} else {

        foreach $charger (@{$chargers}) {

                my $req = $client->read_holding_registers( unit => $charger, address => 789, quantity => 1 );

                $client->send_request($req) || die “Send error: $!”;

                my $response = $client->receive_response;

                print $charger . “_watts.value ” . uint16_to_int( @{$response->{‘message’}->{‘values’}}[0]) / 10 . “\n”;
        }

}
sub uint16_to_int {

    my $uint16 = shift;

    return $uint16 > 0x7FFF ? $uint16 – 0x10000 : $uint16;

}

inverter state of charge

#!/usr/bin/perl

use Device::Modbus::TCP::Client;
my $client = Device::Modbus::TCP::Client->new(

         host => ‘put your GX name or IP here’

);
$config = 1 if(“config” ~~ @ARGV);
my $req = $client->read_holding_registers( unit => 227, address => 30, quantity => 1 );
$client->send_request($req) || die “Send error: $!”;

my $response = $client->receive_response;
if($config) {

        print “graph_title state of charge\n”;

        print “graph_category victron\n”;

        print “inv_soc.label SOC\n”;

} else {

        print “inv_soc.value ” . uint16_to_int( @{$response->{‘message’}->{‘values’}}[0]) / 10 . “\n”;

}
sub uint16_to_int {

    my $uint16 = shift;

    return $uint16 > 0x7FFF ? $uint16 – 0x10000 : $uint16;

}

Inverter bus voltage

#!/usr/bin/perl

use Device::Modbus::TCP::Client;

my $client = Device::Modbus::TCP::Client->new(

         host => ‘your GX device goes here’

);
$config = 1 if(“config” ~~ @ARGV);
my $req = $client->read_holding_registers( unit => 227, address => 26, quantity => 2 );
$client->send_request($req) || die “Send error: $!”;

my $response = $client->receive_response;
if($config) {

        print “graph_title battery volts\n”;

        print “graph_category victron\n”;

        print “inv_volts.label Volts\n”;

} else {

        print “inv_volts.value ” . @{$response->{‘message’}->{‘values’}}[0] /100 . “\n”;

}

So, I’ve been maintaining several very large projects in perl – I can enumerate them at a later date – and one of them in perl and XS. Interestingly, the one in perl and XS is the first to have significant memory leaks – but they’re not all from XS!

I’ve identified three types of memory leaks

#1) Scalers leaving XS without being made mortal and given a reasonable refcount. A useful tool for looking for these is Devel::Leak
#2) Circular references that are not weakened and therefore can never be reaped. A useful tool for looking for these is Devel::Cycle
#3) Scalers gaining a refcount that is not being cleared. A useful tool for looking for these is also Devel::Leak

I now need to go through all the major subsystems and make sure that they aren’t leaking one of these ways. If I find new ways to leak I will add them to this document. Comment below if you’d like a more comprehensive document on how to find these things.

So, one of the big problems I’m having with kt3 is memory leaks. This is probably no surprise to anyone who has done XS programming before.

I found one particularly pernicious one by using Devel::Leak.. this is in the log handler.

Originally I had this, which I’m fairly sure I got from the internet somewhere:


static void _kt_log_callback(int iLogLevel, char *log_subsystem, char *msg)
{
dTHX;
dSP;

call_pv("KittenTrader::KittenBrain::Log", G_DISCARD);
}


This worked well enough – it created a hash ref and passed it to the function – but the hash ref kept leaking.

Eventually – after much digging through the documentation – I figured out that what I needed to do on the XPUSHs was this:


XPUSHs(sv_2mortal(newRV((SV *)rv)));


If anyone is curious how I debugged.. I used this relatively simple function to invoke the callback:


my $count = Devel::Leak::NoteSV($handle);
for($i=0;$i<1000;$i++) { KittenTrader::KittenBrain::testLog(4, "THIS IS A MESSAGE"); } my $count2 = Devel::Leak::NoteSV($handle); Devel::Leak::CheckSV($handle); print "Count: $count\n"; print "Count2: $count2\n";

This gave me a count of SVs, which I could clearly see my leaking SVs in.

Then I added returns everywhere along the path until I could isolate the leaking SV to a few lines of code. In particular I could definitely see that as soon as I created the hash, I was leaking a SV, but not if I destroyed it before passing it in. I realized the problem was that the callee didn't realize that the SV was mortal - I had made the hash mortal but not the *reference* to the hash. ANd of course the hash could never be destroyed until the reference to it was.

This is a perl script that can be used to pull all the files from a DA-6400 and automatically divide them into folders based on their timestamps

#!/usr/bin/perl

$|=1;

$targetbase = “~/DownloadLocation”;

$host = “tascam”;
use Net::FTP;

use Time::Local qw ( timelocal );
use Data::Dumper;
print “Creating FTP object\n”;
$ftp = Net::FTP->new($host, Debug => 0) || die “Can’t connect to tascam”;

print “Logging in\n”;
$ftp->login(“DA-6400″,”DA-6400”) || die “Can’t login ” , $ftp->message;

print “CWD\n”;

$ftp->cwd(“/ssd/DA Files”) || die “Cannot CWD: ” . $ftp->message;

print “BIN\n”;

$ftp->binary() || die “Cannot set to bin mode: ” . $ftp->message;
my $list = $ftp->ls();
my $maxtime = 0;

my $timestamps = {};
# determine newest date

foreach $file (@{$list}) {

        next if($file eq “.”);

        next if($file eq “..”);

        next if(!($file =~ /.*.wav/));
        my $unixtime = getFileTimestamp($file);

        my $ts = getTimestamp($unixtime);
        print “file: [$file] ts: $ts\n”;

        $maxtime = $unixtime if($unixtime > $maxtime);

        $timestamps->{$unixtime} = 1;

}

foreach $ts (keys %{$timestamps}) {
        $targetstub = getTargetDir($ts);

        $targetdir = $targetbase . ‘/’ . $targetstub;

        if(! -d $targetdir) {

                mkdir $targetdir;

        } else {

                next;

        }
        $targetdir .= “/ftp”;

        if(! -d $targetdir) {

                mkdir $targetdir;

        }
        chdir $targetdir;

        print “$ts – Writing to $targetdir\n”;
        foreach $file (@{$list}) {

                next if($file eq “.”);

                next if($file eq “..”);

                next if(!($file =~ /.*.wav/));
                my $unixtime = getFileTimestamp($file);

                if($unixtime == $ts) {

                        print “Fetching $file ..”;

                        $ftp->get($file);

                        print (-s $file);

                        print “\n”;

                }

        }

}
sub getTargetDir

{

        my $time = shift;

        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);

        return sprintf(“%02d%02d%04d”,$mon+1,$mday,$year+1900);

}
sub getTimestamp

{

        my $time = shift || time();
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);

        return sprintf(“%02d/%02d/%04d-%02d:%02d:%02d”,$mon+1,$mday,$year+1900,$hour,$min,$sec);

}
sub getFileTimestamp

{

        my $file = shift;

        my ($prefix, $datetime, $take, $channel, $name) = split(/_/, $file);
        print “Datetime: [$datetime]\n” if($main::debug);
        my ($date, $time) = split(/-/, $datetime);

        print “Date: [$date]\n” if($main::debug);
        my ($yy, $MM, $dd) = $date =~ /(\d{4})(\d{2})(\d{2})/;

        my ($hh, $mm, $ss) = $time =~ /(\d{2})(\d{2})(\d{2})/;
        print “yy: [$yy] mm: $mm dd: $dd\n” if($main::debug);
        $MM -= 1;

        $yy -= 1900;
        my $unixtime = timelocal($ss, $mm, $hh, $dd, $MM, $yy);
        return $unixtime;

}

So, I found a major lack of documentation for Device::Hue, and chatGPT had some information that I would describe as whimsically wrong.

Here’s what I ended up doing to get a working perl setup controlling my hue lights:

1) Put a valid URL in /etc/environment for the key HUE_BRIDGE
2) Put a key in /etc/environment for the key HUE_KEY
3) The following code sets lights 17 and 19 to red:

my $bridge = Device::Hue->new();

$bridge->config();

foreach $light_id (17, 19) {

   my $light = $bridge->light($light_id);

   $light->set_state( { hue => 0, sat => 254 });

   $light->commit();

}

Just a heads up that hopefully google will index and save someone else from the several hours of digging I’ve just had to do. the perl module IPC::Shareable sets SIG{CHLD} to ignore any time you include it. You can set it back to the default behavior, but until you do, waitpid() is going to return -1 and $? will contain -1 for any pid-waiting you do.

I had a couple of notes on using Net::Bluetooth from a raspberry pi to talk to a Bluetooth serial port because I couldn’t get the example code given with Net::Bluetooth to work.

The following will connect to a mac address and send and receive data from it (in this particular example, a ESP32):

#!/usr/bin/perl

use Net::Bluetooth;

use Data::Dumper;

use IO::Handle;

my $obj = Net::Bluetooth->newsocket(“RFCOMM”);
$addr = ‘C4:4F:33:58:B6:FB’;

$port = 1;
if($obj->connect($addr, $port) != 0) {

     die “connect error: $!\n”;

}
my $fh = $obj->perlfh();

$fh->autoflush(1);
sleep(1);
print “sending \n”;
print $fh “V\n”;

print “receiving\n”;
$buf = readline($fh);

print “Fetchhost: $buf\n”;

I use this a lot when writing a simple perl script that I want to take args like –flag and –database=this and –comment=”This is a comment with spaces”

while($arg = shift) { 
        if(($s1,$s2) = $arg =~ /–(.*)=(.*)/) {

                $l1 = lc $s1;

                $s2 = $a if(($a) = $s2 =~ /^\”(.*)\”$/);

                $arg{$l1} = $s2;

        } elsif(($s1) = $arg =~ /–(.*)/) {

                $l1 = lc $s1;

                $arg{$l1} = 1;

        }

}

Stick it in the top of the script, and you can then just use

if($arg{‘flag’}) {

}

$comment = $arg{‘comment’};

and so on and so forth.