+### -*-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;