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

[profile] / bin / disorder-propagate-autoplay

diff --git a/bin/disorder-propagate-autoplay b/bin/disorder-propagate-autoplay
index e70bb6a..be38510 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 (\@$$$) {