| 1 | #! @PERL@ -w |
| 2 | |
| 3 | use autodie qw{:all}; |
| 4 | use strict; |
| 5 | |
| 6 | use DisOrder; |
| 7 | |
| 8 | (my $PROG = $0) =~ s:.*/::; |
| 9 | |
| 10 | sub grobble_dir (\@$$$); |
| 11 | |
| 12 | sub grobble_dir (\@$$$) { |
| 13 | my ($list, $sk, $root, $dir) = @_; |
| 14 | my @d; |
| 15 | |
| 16 | for my $f (send_command $sk, "files", "$root$dir") { |
| 17 | my ($tail) = $f =~ /\Q$root\E(.*)$/; |
| 18 | die "`$f' not under root `$root'" unless $tail; |
| 19 | push @$list, $tail; |
| 20 | } |
| 21 | |
| 22 | for my $d (send_command $sk, "dirs", "$root$dir") { |
| 23 | my ($tail) = $d =~ /\Q$root\E(.*)$/; |
| 24 | die "`$d' not under root `$root'" unless $tail; |
| 25 | push @d, $tail; |
| 26 | } |
| 27 | for my $d (@d) { grobble_dir @$list, $sk, $root, $d; } |
| 28 | } |
| 29 | |
| 30 | sub grobble_root ($) { |
| 31 | my ($sk) = @_; |
| 32 | my $root = undef; |
| 33 | my @list = (); |
| 34 | |
| 35 | for my $d (send_command $sk, "dirs", "") { |
| 36 | my ($pre, $tail) = $d =~ m{^(.*/)([^/]*)$}; |
| 37 | die "no root in `$_'?" unless $pre; |
| 38 | if (!defined $root) { $root = $pre; } |
| 39 | elsif ($root ne $pre) { die "root was `$root'; now it's `$pre'"; } |
| 40 | grobble_dir @list, $sk, $root, $tail; |
| 41 | } |
| 42 | return $root, \@list; |
| 43 | } |
| 44 | |
| 45 | sub trim_extension ($) { |
| 46 | my ($f) = @_; |
| 47 | $f =~ s/\.(flac|mp[23]|ogg|wav)$//; |
| 48 | return $f; |
| 49 | } |
| 50 | |
| 51 | sub die_usage () { |
| 52 | print STDERR <<EOF; |
| 53 | usage: |
| 54 | $PROG get CONFIG |
| 55 | $PROG set CONFIG [LIST] |
| 56 | EOF |
| 57 | exit 2; |
| 58 | } |
| 59 | |
| 60 | defined (my $op = shift @ARGV) or die_usage; |
| 61 | if ($op eq "get") { |
| 62 | defined (my $cf = shift @ARGV) or die_usage; |
| 63 | !@ARGV or die_usage; |
| 64 | my $conf = load_config $cf; |
| 65 | my $sk = connect_to_server %$conf; |
| 66 | my ($root, $list) = grobble_root $sk; |
| 67 | |
| 68 | for my $f (sort @$list) { |
| 69 | my $pick = send_command $sk, "get", "$root$f", "pick_at_random"; |
| 70 | if (($pick // 1) eq "0") { print trim_extension $f, "\n"; } |
| 71 | } |
| 72 | close $sk; |
| 73 | } else { |
| 74 | defined (my $cf = shift @ARGV) or die_usage; |
| 75 | my $fh; |
| 76 | if (defined (my $list = shift @ARGV)) { open $fh, "<", $list; } |
| 77 | else { $fh = \*STDIN; } |
| 78 | my %black = (); |
| 79 | while (<$fh>) { chomp; $black{$_} = 1; } |
| 80 | my $conf = load_config $cf; |
| 81 | my $sk = connect_to_server %$conf; |
| 82 | my ($root, $list) = grobble_root $sk; |
| 83 | |
| 84 | FILE: for my $f (sort @$list) { |
| 85 | my $pick = send_command $sk, "get", "$root$f", "pick_at_random"; |
| 86 | if (($pick // 1) eq "0") { |
| 87 | next FILE if $black{trim_extension $f}; |
| 88 | send_command $sk, "unset", "$root$f", "pick_at_random"; |
| 89 | print STDERR ";; reinstate <$f>\n"; |
| 90 | } else { |
| 91 | next FILE unless $black{trim_extension $f}; |
| 92 | send_command $sk, "set", "$root$f", "pick_at_random", 0; |
| 93 | print STDERR ";; blacklist <$f>\n"; |
| 94 | } |
| 95 | } |
| 96 | close $sk; |
| 97 | } |