隠居日録

隠居日録

2016年(世にいう平成28年)、発作的に会社を辞め、隠居生活に入る。日々を読書と散歩に費やす

perlとchromecast その2

perlとchromecast その1 - 隠居日録の続き。

fetchがNet::DNS::Resolverでqueryしているのだが、mDSNでqueryしないと、応答が帰ってくるはずがない。そこが問題なのだが、fetchの中で普通のDNSとmDNSの両方を扱うのは面倒なので、mfetchを新たに追加して、状況に応じて呼び出す先を変えることにした。

sub discover {
        my $self = shift;

        my @list;
        my $ptrs = [];
        my $multi;

        if ( $self->domain(@_) eq 'local' ) {
                $multi = 1;
                @list = $self->mdns_refresh;
        } else {
                $multi = 0;
                @list = $self->dns_refresh;
        }

        foreach my $x ( 0..$#list ) {
                my $host = Net::Bonjour::Entry->new($list[$x]);
                $host->dns_server($self->{'_dns_server'});
                $host->dns_port($self->{'_dns_port'});
                if ($multi) {
                        $host->mfetch ();
                } else {
                        $host->fetch ();

でmfetchは元ものとfetchをほぼコピーした。SRV、A、TXTと連続してもqueryしているけれど、chromecastの応答のadditionalに既に情報が入っているので、やみくもにqueryするのは無駄たと思うのだが、とりあえずそのままにしている。

sub mfetch {
        my $self = shift;

        my ($name, $protocol, $ipType) = split(/(?<!\\)\./, $self->fqdn,3);

        $self->{'_name'} = $name;
        $self->type($protocol, $ipType);

        my $srv = $self->mcast_query ($self->fqdn, 'SRV') || return;
        my $srvrr = ($srv->answer)[0];

        $self->priority($srvrr->priority);
        $self->weight($srvrr->weight);
        $self->port($srvrr->port);
        $self->hostname($srvrr->target);

        if ($srv->additional) {
                foreach my $additional ($srv->additional) {
                        $self->{'_' . uc($additional->type)} = $additional->address;
                }
        } else {
                my $aquery = $self->mcast_query($srvrr->target, 'A');
                my $arr = ($aquery->answer)[0];
                if ( $arr->type eq 'A' ) {
                         $self->{'_' . uc($arr->type)} = $arr->address;
                }
        }

        my $txt = $self->mcast_query($self->fqdn, 'TXT');

        # Text::Parsewords, which is called by Net::DNS::RR::TXT can spew
        if ( $txt ) {
                local $^W = 0;
                my $txti = 0;

                foreach my $txtrr ( $txt->answer ) {
                        $self->txtdata([$txtrr->char_str_list ]);
                        $self->index($txti++);
                        foreach my $txtln ( $txtrr->char_str_list ) {
                                my ($key,$val) = split(/=/,$txtln,2);
                                $self->attribute($key, $val);
                        }
                        $txti++;
                }
        }

        $self->text($txt);

        return;
}

sub mcast_query {
        my ($self, $name, $type) = @_;

        my $query = Net::DNS::Packet->new ($name, $type);
        my $dist = $self->{'_dns_server'}[0] . ":" . $self->{'_dns_port'};
        my $dns = IO::Socket::Multicast->new(Proto => 'udp', LocalPort => $self->{'_dns_port'}) or die "Can't create socket: $!\n";
        $dns->mcast_add ($self->{'_dns_server'}[0]) or die "Can't mcast_add: $!\n";
        $dns->mcast_loopback (0) or die "Can't disable loopback: $!\n";
        $dns->sockopt (SO_RCVTIMEO, pack ("qq", 1, 0)) or die "Can't set timeout: $!\n";
        $dns->mcast_send ($query->data, $dist);

        my $data;
        my $ans = undef;
        $dns->recv ($data, 1024);
        if (length ($data) > 0) {

                $ans = Net::DNS::Packet->new(\$data, $self->{'_debug'});
        }
        return $ans;
}

この修正でchromecastの検出はできるようになった。でも、検出できるようになっただけで、何もできないので、この先は、以下のページでもう少し勉強する必要がある。

github.com

perlとchromecast その1

今の所chromecastのメインの使い方はメディアサーバーにRygelを使い、SenderアプリとしてAndroidタブレットでBubbleUPnPを使って、ファイルを再生している。しかし、chromecastを買った当初から、もっと簡単な方法はないのだろうかと探している。pythonとかnode.jsにはあるようなのだが、環境の設定が面倒なのと、pythonjavascriptもよく判らないので、二の足を踏んでいる。perlで何かないかと思って探してみると、以下のようなものがあった

GitHub - amgorb/simple-DLNA-remote-controller: Perl script to mass control TVs and other DLNA devices

当然動かない。問題の一番の部分はNet::UPnPがもうメンテナンスされていなく、多数のバグが残っていることだ。それと、いつのまにかchromecastはUPnPでは検出できなくなっている。一応応答を返してくるのだが、frendlynameもdeviceTypeも返してこない。

f:id:prozorec:20170601214629p:plain

f:id:prozorec:20170601214824p:plain

調べてみるとchromecastのプロトコルはv1とv2があって、v1はUPnPで検出できるが、v2はmDNSということだ。どっかの時点で、v2しかサポートしなくなったのだろうか。以前はUPnPで検出できていた記憶がある。しかたがないので、mDNSで検出できないかと、perlモジュールを調べると、Net::Bonjourというのがあるのがわかった。さっそく、debianのパッケージを入れて、試そうと思ったのだが、どう検出してよいかわからない。newの引数に何を渡せばいいのか、さっぱり見当がつかない。

Net::Bonjour->new (<service>, <protocol>, <domain>);

考えていてもわからないので、検索していると、http://qiita.com/vanx2/items/3c20bf8e4111da9eb68dで、

nameが_googlecast._tcp.localなPTRレコードをリクエストするクエリ投げるスクリプト書いてー

と書いてあって、わかったようなわからないような感じだ。それで、イーサーパケットをキャプチャしながら、いろいろ試してみると、以下のコードで、それっぽいパケットが出て、応答が帰ってくることが分かった。

use strict;
use Net::Bonjour;

my @services = qw(googlecast);
foreach my $service (@services) {
  print "Trying $service\n";
  my $res = Net::Bonjour->new($service, 'tcp', 'local');

  foreach my $entry ( $res->entries ) {
      printf "%s %s:%s\n", $entry->name, $entry->address, $entry->port;
  }
}

f:id:prozorec:20170601220447p:plain

ところがである。perlではパケットが受信できないのだ。Net::Bonjourも更新が止まっているので、涸れて安定しているか、放置されているかのどちらかだろう。どうやら、後者のようだ。検索しても、Net::Bonjourの関連ページがヒットしない。現状の動作としては、パケットは受信できないし、どこかで無限待ちになっているようだ。いろいろ調べてみると、mdns_refreshに問題がありそうなことが分かった。キャプチャしたパケットをよく見ると、chromecastからのパケットも224.0.0.251に送信されているので、普通に受信しようと思ってもできないはずだ。それに、タイムアウトも設定していないので、いつまでも待ち続けるわけだ。

sub mdns_refresh {
        my $self = shift;

        my $query = Net::DNS::Packet->new($self->fqdn, 'PTR');

        socket DNS, PF_INET, SOCK_DGRAM, scalar(getprotobyname('udp'));
        bind DNS, sockaddr_in(0,inet_aton('0.0.0.0'));
        send DNS, $query->data, 0, sockaddr_in($self->{'_dns_port'}, inet_aton($
self->{'_dns_server'}[0]));

        my $rout = '';
        my $rin  = '';
        my %list;

        vec($rin, fileno(DNS), 1) = 1;

        while ( select($rout = $rin, undef, undef, 1.0) ) {
                my $data;
                recv(DNS, $data, 1000, 0);

マルチキャストの受信にしなければ、受信できないだろうという想定のもと、インストールしたdebianのパッケージを削除して、cpanからNet::Bonjourをダウンロードして、以下のように修正してみた。

sub mdns_refresh {
        my $self = shift;

        my $query = Net::DNS::Packet->new($self->fqdn, 'PTR');
        my $dist = $self->{'_dns_server'}[0] . ":" . $self->{'_dns_port'};
        my $dns = IO::Socket::Multicast->new(Proto => 'udp', LocalPort => $self-
>{'_dns_port'}) or die "Can't create socket: $!\n";
        $dns->mcast_add ($self->{'_dns_server'}[0]) or die "Can't mcast_add: $!\
n";
        $dns->mcast_loopback (0) or die "Can't disable loopback: $!\n";
        my $timeout = pack ("qq", 1, 0);
        $dns->sockopt (SO_RCVTIMEO, $timeout) or die "Can't set timeout: $!\n";

        $dns->mcast_send ($query->data, $dist);

        my %list;
        my $data = "";
        while (1) {
                $dns->recv ($data, 1024);
                last if (length ($data) <= 0);

これだと、受信はうまくいってmdns_refreshで検出できるところまではいったのだが、まだこれでも想定した通り動かない。別なところで、無限待ちになっているのだ。それは、Net::Bonjour::Entryのfetchの問題だというのまではわかったのだが、さてどのように修正するのがいいのか、考えてしまう。