pl/DisOrder.pm: Extract and enhance the DisOrder protocol machinery.

diff --git a/Makefile b/Makefile
index 4742ad60c6bef1b1f3d194275df38097cb0aa8ec..95d0a45d637fd0eea5e792279920188b1c2abe8d 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -220,6 +220,8 @@ DOTLINKS            += .tclshrc .wishrc
 .wishrc_SRC             = tclshrc
 
 ## Jukebox things.
+MISCLINKS              += lib/perl/DisOrder.pm
+lib/perl/DisOrder.pm_SRC = pl/DisOrder.pm
 SCRIPTLINKS            += disorder-switch-config
 SCRIPTLINKS            += disorder-propagate-autoplay
 

diff --git a/bin/disorder-propagate-autoplay b/bin/disorder-propagate-autoplay
index e70bb6a1c5737cf12c38fc24b64997791d24e774..be38510304e6f91f14780089ec111f9f97189735 100755 (executable)
--- a/bin/disorder-propagate-autoplay
+++ b/bin/disorder-propagate-autoplay
@@ -3,156 +3,10 @@
 use autodie qw{:all};
 use strict;
 
-use Digest::SHA;
-use Socket qw{:DEFAULT :addrinfo};
-
-use Data::Dumper;
+use DisOrder;
 
 (my $PROG = $0) =~ s:.*/::;
 
-sub get_response ($) {
-  my ($sk) = @_;
-  (my $st, my $r) = split ' ', (readline $sk), 2;
-  chomp $r;
-  my $c = $st%10; $st = int($st/10);
-  my $b = $st%10; $st = int($st/10);
-  my $a = $st;
-
-  if ($a == 5) {
-    if ($c == 5) { return undef; }
-    else { die "server error: $r"; }
-  }
-  elsif ($a != 2) { die "unexpected status code $a"; }
-  elsif ($c == 0 || $c == 9) { return undef; }
-  elsif ($c == 1 || $c == 2) { return $r; }
-  elsif ($c == 3) {
-    my @r = ();
-    LINE: for (;;) {
-      chomp (my $line = readline $sk);
-      last LINE if $line eq ".";
-      $line =~ s/^\.//;
-      push @r, $line;
-    }
-    return @r;
-  } else { die "unexpected format code $c"; }
-}
-
-sub send_command ($@) {
-  my ($sk, @f) = @_;
-
-  my $t = "";
-  for my $f (@f) {
-    if ($f eq "" || $f =~ /[\\"'\s]/) {
-      $f =~ s/([\\"])/\\$1/g;
-      $f = '"' . $f . '"';
-    }
-    $t .= " " if $t;
-    $t .= $f;
-  }
-#print STDERR ";; <$t>\n";
-  print $sk "$t\n";
-  return get_response $sk;
-}
-
-sub split_fields ($) {
-  my ($l) = @_;
-  my @f = ();
-  my $f;
-
-  FIELD: for (;;) {
-    $l =~ s/^\s*//;
-    last FIELD unless $l;
-    if ($l =~ /^(["'])/) {
-      my $q = $1;
-      ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
-      $f =~ s/\\(.)/$1/g;
-    } else {
-      ($f, $l) = split ' ', $l, 2; $l //= "";
-    }
-    push @f, $f;
-  }
-  return @f;
-}
-
-sub connect_to_server ($) {
-  my ($conf) = @_;
-  my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
-  my @f;
-
-  open my $fh, "<", $conf;
-  LINE: while (<$fh>) {
-    chomp;
-    next LINE unless /^\s*[^\s#]/;
-    (my $k, my @f) = split;
-    $conf{$k} = \@f;
-  }
-  close $fh;
-  for my $i (qw{ username password })
-    { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
-
-  my $af = AF_UNSPEC;
-  my @a = $conf{connect}->@*;
-  die "empty address" unless @a;
-  if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
-  elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
-  elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
-  elsif ($a[0] eq "-") { shift @a; }
-  die "empty address" unless @a;
-
-  my $a;
-  my @i;
-  if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
-    @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
-    shift @a;
-  } else {
-    die "missing port" unless @a >= 2;
-    (my $e, @i) = getaddrinfo $a[0], $a[1],
-      { family => $af, socktype => SOCK_STREAM };
-    die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
-    splice @a, 0, 2;
-  }
-  die "junk in address" if @a;
-
-  my $sk;
-  my @e;
-  ADDR: for my $i (@i) {
-    eval {
-      socket $sk, $i->{family}, SOCK_STREAM, 0;
-      connect $sk, $i->{addr};
-    };
-    last ADDR unless $@;
-    close $sk if defined $sk;
-    push @e, $@->errno;
-    $sk = undef;
-  }
-
-  unless (defined $sk) {
-    print STDERR "failed to connect!\n";
-    for (my $i = 0; $i < @i; $i++) {
-      if ($i[$i]{family} == AF_UNIX)
-       { $a = unpack_sockaddr_un $i[$i]{addr}; }
-      else {
-       my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
-         NI_NUMERICHOST | NI_NUMERICSERV;
-       die "getnameinfo: $e" if $e;
-       $a = $host . ":" . $svc;
-      }
-      print STDERR "\t$a: $e[$i]\n";
-    }
-    die "giving up";
-  }
-  autoflush $sk 1;
-
-  @f = split_fields get_response $sk;
-  die "expected version 2" unless $f[0] eq "2";
-  my $h = Digest::SHA->new($f[1]);
-  $h->add($conf{password}[0], pack "H*", $f[2]);
-  my $d = $h->hexdigest;
-  send_command $sk, "user", $conf{username}[0], $d;
-
-  return $sk;
-}
-
 sub grobble_dir (\@$$$);
 
 sub grobble_dir (\@$$$) {

diff --git a/pl/DisOrder.pm b/pl/DisOrder.pm
new file mode 100644 (file)
index 0000000..5f72131
--- /dev/null
+++ b/pl/DisOrder.pm
@@ -0,0 +1,185 @@
+### -*-perl-*-
+
+use autodie qw{:all};
+use strict;
+
+use Digest::SHA;
+use Exporter qw{import};
+use Socket qw{:DEFAULT :addrinfo};
+
+our @EXPORT_OK = qw{get_response0 decode_response get_response
+                   send_command0 send_command
+                   split_fields
+                   connect_to_server};
+
+use Data::Dumper;
+
+sub split_response_code ($) {
+  my ($st) = @_;
+  my $c = $st%10; $st = int($st/10);
+  my $b = $st%10; $st = int($st/10);
+  my $a = $st;
+  return ($a, $b, $c);
+}
+
+sub get_response0 ($) {
+  my ($sk) = @_;
+  (my $st, my $r) = split ' ', (readline $sk), 2;
+  chomp $r;
+
+  my ($a, $b, $c) = split_response_code $st;
+  if ($a == 5) {
+    if ($c == 5) { return $st, undef; }
+    else { die "server error: $r"; }
+  }
+  elsif ($a != 2) { die "unexpected status code $a"; }
+  else { return $st, $r; }
+}
+
+sub decode_response ($$$) {
+  my ($sk, $st, $r) = @_;
+  my ($a, $b, $c) = split_response_code $st;
+
+  if ($c == 0 || $c == 5 || $c == 9) { return undef; }
+  elsif ($c == 1 || $c == 2) { return $r; }
+  elsif ($c == 3) {
+    my @r = ();
+    LINE: for (;;) {
+      chomp (my $line = readline $sk);
+      last LINE if $line eq ".";
+      $line =~ s/^\.//;
+      push @r, $line;
+    }
+    return @r;
+  } else { die "unexpected format code $c in $st"; }
+}
+
+sub get_response ($) {
+  my ($sk) = @_;
+  my ($st, $r) = get_response0 $sk;
+  return decode_response $sk, $st, $r;
+}
+
+sub send_command0 ($@) {
+  my ($sk, @f) = @_;
+
+  my $t = "";
+  for my $f (@f) {
+    if ($f eq "" || $f =~ /[\\"'\s]/) {
+      $f =~ s/([\\"])/\\$1/g;
+      $f = '"' . $f . '"';
+    }
+    $t .= " " if $t;
+    $t .= $f;
+  }
+  print $sk "$t\n";
+  return get_response0 $sk;
+}
+
+sub send_command ($@) {
+  my ($sk, @f) = @_;
+  my ($st, $r) = send_command0 $sk, @f;
+  return decode_response $sk, $st, $r;
+}
+
+sub split_fields ($) {
+  my ($l) = @_;
+  my @f = ();
+  my $f;
+
+  FIELD: for (;;) {
+    $l =~ s/^\s*//;
+    last FIELD if $l eq "";
+    if ($l =~ /^(["'])/) {
+      my $q = $1;
+      ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
+      $f =~ s/\\(.)/$1/g;
+    } else {
+      ($f, $l) = split ' ', $l, 2; $l //= "";
+    }
+    push @f, $f;
+  }
+  return @f;
+}
+
+sub connect_to_server ($;$) {
+  my ($conf, $quietp) = @_;
+  my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
+  my @f;
+
+  open my $fh, "<", $conf;
+  LINE: while (<$fh>) {
+    chomp;
+    next LINE unless /^\s*[^\s#]/;
+    (my $k, my @f) = split;
+    $conf{$k} = \@f;
+  }
+  close $fh;
+  for my $i (qw{ username password })
+    { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
+
+  my $af = AF_UNSPEC;
+  my @a = $conf{connect}->@*;
+  die "empty address" unless @a;
+  if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
+  elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
+  elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
+  elsif ($a[0] eq "-") { shift @a; }
+  die "empty address" unless @a;
+
+  my $a;
+  my @i;
+  if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
+    @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
+    shift @a;
+  } else {
+    die "missing port" unless @a >= 2;
+    (my $e, @i) = getaddrinfo $a[0], $a[1],
+      { family => $af, socktype => SOCK_STREAM };
+    die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
+    splice @a, 0, 2;
+  }
+  die "junk in address" if @a;
+
+  my $sk;
+  my @e;
+  ADDR: for my $i (@i) {
+    eval {
+      socket $sk, $i->{family}, SOCK_STREAM, 0;
+      connect $sk, $i->{addr};
+    };
+    last ADDR unless $@;
+    close $sk if defined $sk;
+    push @e, $@->errno;
+    $sk = undef;
+  }
+
+  unless (defined $sk) {
+    die "failed to connect" if $quietp;
+    print STDERR "failed to connect!\n";
+    for (my $i = 0; $i < @i; $i++) {
+      if ($i[$i]{family} == AF_UNIX)
+       { $a = unpack_sockaddr_un $i[$i]{addr}; }
+      else {
+       my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
+         NI_NUMERICHOST | NI_NUMERICSERV;
+       die "getnameinfo: $e" if $e;
+       $a = $host . ":" . $svc;
+      }
+      print STDERR "\t$a: $e[$i]\n";
+    }
+    die "giving up";
+  }
+  autoflush $sk 1;
+
+  @f = split_fields get_response $sk;
+  die "expected version 2" unless $f[0] eq "2";
+  my $h = Digest::SHA->new($f[1]);
+  $h->add($conf{password}[0], pack "H*", $f[2]);
+  my $d = $h->hexdigest;
+  send_command $sk, "user", $conf{username}[0], $d;
+
+  return $sk;
+}
+
+1;