7 use Socket
qw{:DEFAULT
:addrinfo
};
11 (my $PROG = $0) =~ s
:.*/::;
13 sub get_response
($) {
15 (my $st, my $r) = split ' ', (readline $sk), 2;
17 my $c = $st%10; $st = int($st/10);
18 my $b = $st%10; $st = int($st/10);
22 if ($c == 5) { return undef; }
23 else { die "server error: $r"; }
25 elsif ($a != 2) { die "unexpected status code $a"; }
26 elsif ($c == 0 || $c == 9) { return undef; }
27 elsif ($c == 1 || $c == 2) { return $r; }
31 chomp (my $line = readline $sk);
32 last LINE
if $line eq ".";
37 } else { die "unexpected format code $c"; }
40 sub send_command
($@
) {
45 if ($f eq "" || $f =~ /[\\"'\s]/) {
46 $f =~ s/([\\"])/\\$1/g;
52 #print STDERR ";; <$t>\n";
54 return get_response
$sk;
57 sub split_fields
($) {
65 if ($l =~ /^(["'])/) {
67 ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
70 ($f, $l) = split ' ', $l, 2; $l //= "";
77 sub connect_to_server
($) {
79 my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
82 open my $fh, "<", $conf;
85 next LINE
unless /^\s*[^\s#]/;
86 (my $k, my @f) = split;
90 for my $i (qw{ username password
})
91 { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
94 my @a = $conf{connect}->@
*;
95 die "empty address" unless @a;
96 if ($a[0] eq "-unix") { $af = AF_UNIX
; shift @a; }
97 elsif ($a[0] eq "-4") { $af = AF_INET
; shift @a; }
98 elsif ($a[0] eq "-6") { $af = AF_INET6
; shift @a; }
99 elsif ($a[0] eq "-") { shift @a; }
100 die "empty address" unless @a;
104 if ($af == AF_UNIX
|| ($af == AF_UNSPEC
&& $a[0] =~ m{^/})) {
105 @i = ({ family
=> AF_UNIX
, addr
=> pack_sockaddr_un
($a[0]) });
108 die "missing port" unless @a >= 2;
109 (my $e, @i) = getaddrinfo
$a[0], $a[1],
110 { family
=> $af, socktype
=> SOCK_STREAM
};
111 die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
114 die "junk in address" if @a;
118 ADDR
: for my $i (@i) {
120 socket $sk, $i->{family
}, SOCK_STREAM
, 0;
121 connect $sk, $i->{addr
};
124 close $sk if defined $sk;
129 unless (defined $sk) {
130 print STDERR
"failed to connect!\n";
131 for (my $i = 0; $i < @i; $i++) {
132 if ($i[$i]{family
} == AF_UNIX
)
133 { $a = unpack_sockaddr_un
$i[$i]{addr
}; }
135 my ($e, $host, $svc) = getnameinfo
$i[$i]{addr
},
136 NI_NUMERICHOST
| NI_NUMERICSERV
;
137 die "getnameinfo: $e" if $e;
138 $a = $host . ":" . $svc;
140 print STDERR
"\t$a: $e[$i]\n";
146 @f = split_fields get_response
$sk;
147 die "expected version 2" unless $f[0] eq "2";
148 my $h = Digest
::SHA
->new($f[1]);
149 $h->add($conf{password
}[0], pack "H*", $f[2]);
150 my $d = $h->hexdigest;
151 send_command
$sk, "user", $conf{username
}[0], $d;
156 sub grobble_dir
(\@
$$$);
158 sub grobble_dir
(\@
$$$) {
159 my ($list, $sk, $root, $dir) = @_;
162 for my $f (send_command
$sk, "files", "$root$dir") {
163 my ($tail) = $f =~ /\Q$root\E(.*)$/;
164 die "`$f' not under root `$root'" unless $tail;
168 for my $d (send_command
$sk, "dirs", "$root$dir") {
169 my ($tail) = $d =~ /\Q$root\E(.*)$/;
170 die "`$d' not under root `$root'" unless $tail;
173 for my $d (@d) { grobble_dir @
$list, $sk, $root, $d; }
176 sub grobble_root
($) {
181 for my $d (send_command
$sk, "dirs", "") {
182 my ($pre, $tail) = $d =~ m{^(.*/)([^/]*)$};
183 die "no root in `$_'?" unless $pre;
184 if (!defined $root) { $root = $pre; }
185 elsif ($root ne $pre) { die "root was `$root'; now it's `$pre'"; }
186 grobble_dir
@list, $sk, $root, $tail;
188 return $root, \
@list;
191 sub trim_extension
($) {
193 $f =~ s/\.(flac|mp[23]|ogg|wav)$//;
197 if (@ARGV != 2) { die "usage: $PROG FROM TO\n"; }
198 my ($from, $to) = @ARGV;
200 my $sk = connect_to_server
$from;
201 my ($root0, $list) = grobble_root
$sk;
204 my $pick = send_command
$sk, "get", "$root0$f", "pick_at_random";
205 if (($pick // 1) eq "0") { $black{trim_extension
$f} = 1; }
209 $sk = connect_to_server
$to;
210 (my $root1, $list) = grobble_root
$sk;
211 FILE
: for my $f (@
$list) {
212 my $pick = send_command
$sk, "get", "$root1$f", "pick_at_random";
213 if (($pick // 1) eq "0") {
214 next FILE
if $black{trim_extension
$f};
215 send_command
$sk, "unset", "$root1$f", "pick_at_random";
216 print STDERR
";; reinstate <$f>\n";
218 next FILE
unless $black{trim_extension
$f};
219 send_command
$sk, "set", "$root1$f", "pick_at_random", 0;
220 print STDERR
";; blacklist <$f>\n";