maybe perl receiver for chinese thermometers

1 files changed, 186 insertions, 0 deletions

diff --git a/atc-therm-receiver/test.pl b/atc-therm-receiver/test.pl
new file mode 100644
index 0000000..fb03ec8
--- /dev/null
+++ b/atc-therm-receiver/test.pl
@@ -0,0 +1,186 @@
+#!/usr/bin/env perl
+use v5.38;
+use experimental qw(for_list try);
+use Net::DBus;
+use Net::DBus::Reactor;
+use Net::DBus::Annotation qw(:call);
+use Data::Dumper;
+
+package Monitor {
+    use v5.38;
+    use Net::DBus qw(:typing);
+    use Net::DBus::Exporter qw(org.bluez.AdvertisementMonitor1);
+    use parent qw(Net::DBus::Object);
+
+    dbus_method('Activate',[],[],'org.bluez.AdvertisementMonitor1');
+    sub Activate($self) { say "activated" }
+    dbus_method('Release',[],[],'org.bluez.AdvertisementMonitor1');
+    sub Release($self) { say "released" }
+
+    dbus_method('DeviceFound',['objectpath'],[],'org.bluez.AdvertisementMonitor1',{param_names=>['device']});
+    sub DeviceFound($self,$dev) { say "found $dev" }
+    dbus_method('DeviceLost',['objectpath'],[],'org.bluez.AdvertisementMonitor1',{param_names=>['device']});
+    sub DeviceLost($self,$dev) { say "lost $dev" }
+
+    dbus_property('Type','string','read','org.bluez.AdvertisementMonitor1');
+    sub Type($self) { return 'or_patterns' }
+
+    dbus_property('Patterns',['array',['struct','byte','byte',['array','byte']]],'read','org.bluez.AdvertisementMonitor1');
+    sub Patterns($self) { return [dbus_struct([dbus_byte(0),dbus_byte(0x16),dbus_array([dbus_byte(0x1a),dbus_byte(0x18)])])] }
+
+    sub get_props($self) {
+        return {
+            'org.freedesktop.DBus.Introspectable' => {},
+            'org.bluez.AdvertisementMonitor1' => {
+                'Type' => Monitor->Type,
+                'Patterns' => Monitor->Patterns,
+            },
+        };
+    }
+}
+
+package MonitorApp {
+    use v5.38;
+    use Net::DBus qw(:typing);
+    use Net::DBus::Exporter qw(org.freedesktop.DBus.ObjectManager);
+    use parent qw(Net::DBus::Object);
+
+    dbus_signal('InterfacesAdded',['objectpath',['dict','string',['dict','string',['variant']]]]);
+    dbus_signal('InterfacesRemoved',['objectpath',['array','string']]);
+
+    dbus_method('GetManagedObjects',[],[['dict','objectpath',['dict','string',['dict','string',['variant']]]]]);
+    sub GetManagedObjects($self) {
+        say 'MonitorApp GetManagedObjects';
+        return {
+            '/net/thenautilus/monitor' => Monitor->get_props,
+        };
+    }
+}
+
+my $PATH='/org/bluez/hci0';
+
+my $reactor = Net::DBus::Reactor->main();
+my $bus = Net::DBus->system;
+my $bluez = $bus->get_service('org.bluez');
+my $bluez_root = $bluez->get_object('/');
+my $adapter = $bluez->get_object($PATH);
+
+sub maybe_handle_data($path,$interfaces) {
+    my $dev = $interfaces->{'org.bluez.Device1'}
+        or return;
+
+    my $service_data = $dev->{ServiceData}
+        or return;
+
+    my ($key) = keys $service_data->%*
+        or return;
+
+    $key =~ /^0000181a-/ or return;
+
+    my @data = $service_data->{$key}->@*;
+    my $temp = ($data[7]*256 + $data[6])/100;
+    my $hum = ($data[9]*256 + $data[8])/100;
+    my $bat_v = ($data[11]*256 + $data[10])/1000;
+    my $bat_pc = $data[12];
+
+    say "$path Data = @data";
+    say "  ",join(':',map { sprintf('%02x',$_) } @data);
+    say "  $temp C - $hum %h - $bat_v V - $bat_pc %";
+
+    return 1;
+}
+
+sub look_at_device($path,$interfaces) {
+    maybe_handle_data($path,$interfaces)
+        or return;
+
+    my $new_obj = $bluez->get_object($path);
+
+    # I don't know how to tell bluez to keep these objects around ☹
+    $new_obj->Set('org.bluez.Device1','Trusted',Net::DBus::dbus_boolean(1));
+
+    $new_obj->connect_to_signal(
+        'PropertiesChanged',
+        sub($interface,$props,@) {
+            maybe_handle_data($path,{$interface=>$props})
+                or return;
+        }
+    );
+
+    my $timer;
+    $timer = $reactor->add_timeout(
+        5_000,
+        sub {
+            try {
+                my $raw_data = $new_obj->Get(
+                    'org.bluez.Device1',
+                    'ServiceData'
+                ) or die 'no data';
+
+                maybe_handle_data($path,{'org.bluez.Device1',{ServiceData=>$raw_data}})
+                    or die 'bad data';
+            }
+            catch ($e) {
+                warn "$path - error - $e\n";
+                $reactor->remove_timeout($timer);
+            }
+        }
+    );
+}
+
+say 'connect_to_signal';
+$bluez_root->connect_to_signal(
+    'InterfacesAdded',
+    sub ($path,$interfaces) {
+        look_at_device($path,$interfaces);
+    },
+);
+say 'GetManagedObjects';
+my $objects = $bluez_root->GetManagedObjects();
+for my ($path,$interfaces) ($objects->%*) {
+    look_at_device($path,$interfaces);
+}
+
+# I don't think this is any use when listening to advertisements
+say 'SetDiscoveryFilter';
+$adapter->SetDiscoveryFilter({
+    Transport => 'le',
+    Discoverable => Net::DBus::dbus_boolean(0),
+#    Pattern => 'A4:C1:38:',
+    DuplicateData => Net::DBus::dbus_boolean(1),
+});
+
+# say 'StartDiscovery';
+# $adapter->StartDiscovery();
+
+say 'registering monitor';
+my $session_bus = Net::DBus->session;
+# we need to expose our monitors on the system bus, but we can't claim
+# ownership of any actual service there, so we build the anonymous
+# service and export objects through that, they'll be identified by the connection id
+my $monitor_service = $bus->export_service();
+my $monitor_app = MonitorApp->new($monitor_service,'/net/thenautilus');
+my $monitor = Monitor->new($monitor_app,'monitor');
+
+my $hook;
+$hook = $reactor->add_hook(
+    sub {
+        say 'actually register';
+        $adapter->RegisterMonitor(dbus_call_async,'/net/thenautilus')->set_notify(
+            sub($reply) {
+                say 'RegisterMonitor reply';
+                try {
+                    say 'ok(',$reply->get_result,')';
+                } catch ($e) {
+                    warn "error: $e";
+                }
+            }
+        );
+        say 'registered';
+        $reactor->remove_hook($hook);
+    }
+);
+
+say 'run';
+$reactor->run();
+