--- /dev/null
+/Makefile.in
+/autom4te.cache/
+/aclocal.m4
+/config/
+/configure
--- /dev/null
+### -*-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
+ load_config 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 load_config ($) {
+ my ($conf) = @_;
+ my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
+
+ 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}; }
+ return \%conf;
+}
+
+sub connect_to_server (\%;$) {
+ my ($conf, $quietp) = @_;
+ my @f;
+
+ 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;
--- /dev/null
+### -*-makefile-*-
+
+perldir = $(libdir)/site_perl
+
+EXTRA_DIST =
+CLEANFILES =
+bin_SCRIPTS =
+perl_DATA =
+
+perl_DATA += DisOrder.pm
+
+V_SUBST = $(V_SUBST_@AM_V@)
+V_SUBST_ = $(V_SUBST_@AM_DEFAULT_V@)
+V_SUBST_0 = @echo " SUBST $@";
+
+bin_SCRIPTS += disorder-autoplay
+EXTRA_DIST += disorder-autoplay.in
+CLEANFILES += disorder-autoplay
+disorder-autoplay: disorder-autoplay.in
+ $(V_SUBST)sed 's#@''PERL@#$(PERL)#g' \
+ <$(srcdir)/disorder-autoplay.in >disorder-autoplay.new && \
+ chmod +x disorder-autoplay.new && \
+ mv disorder-autoplay.new disorder-autoplay
+
+bin_SCRIPTS += disorder-notify
+EXTRA_DIST += disorder-notify.in
+CLEANFILES += disorder-notify
+disorder-notify: disorder-notify.in
+ $(V_SUBST)sed 's#@''PERL@#$(PERL)#g' \
+ <$(srcdir)/disorder-notify.in >disorder-notify.new && \
+ chmod +x disorder-notify.new && \
+ mv disorder-notify.new disorder-notify
+
+bin_SCRIPTS += disorder-ondemand
+EXTRA_DIST += disorder-ondemand.in
+CLEANFILES += disorder-ondemand
+disorder-ondemand: disorder-ondemand.in
+ $(V_SUBST)sed 's#@''PERL@#$(PERL)#g' \
+ <$(srcdir)/disorder-ondemand.in >disorder-ondemand.new && \
+ chmod +x disorder-ondemand.new && \
+ mv disorder-ondemand.new disorder-ondemand
+
+bin_SCRIPTS += disorder-switch-config
--- /dev/null
+dnl -*-autoconf-*-
+
+AC_INIT([disorder-toys], [1.0], [mdw@distorted.org.uk])
+AC_CONFIG_AUX_DIR([config])
+AM_INIT_AUTOMAKE([foreign])
+AM_SILENT_RULES([yes])
+
+AC_PATH_PROG([PERL], [perl perl5], [nil])
+case $PERL in nil) AC_MSG_ERROR([can't find perl]) ;; esac
+
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#! @PERL@ -w
+
+use autodie qw{:all};
+use strict;
+
+use DisOrder;
+
+(my $PROG = $0) =~ s:.*/::;
+
+sub grobble_dir (\@$$$);
+
+sub grobble_dir (\@$$$) {
+ my ($list, $sk, $root, $dir) = @_;
+ my @d;
+
+ for my $f (send_command $sk, "files", "$root$dir") {
+ my ($tail) = $f =~ /\Q$root\E(.*)$/;
+ die "`$f' not under root `$root'" unless $tail;
+ push @$list, $tail;
+ }
+
+ for my $d (send_command $sk, "dirs", "$root$dir") {
+ my ($tail) = $d =~ /\Q$root\E(.*)$/;
+ die "`$d' not under root `$root'" unless $tail;
+ push @d, $tail;
+ }
+ for my $d (@d) { grobble_dir @$list, $sk, $root, $d; }
+}
+
+sub grobble_root ($) {
+ my ($sk) = @_;
+ my $root = undef;
+ my @list = ();
+
+ for my $d (send_command $sk, "dirs", "") {
+ my ($pre, $tail) = $d =~ m{^(.*/)([^/]*)$};
+ die "no root in `$_'?" unless $pre;
+ if (!defined $root) { $root = $pre; }
+ elsif ($root ne $pre) { die "root was `$root'; now it's `$pre'"; }
+ grobble_dir @list, $sk, $root, $tail;
+ }
+ return $root, \@list;
+}
+
+sub trim_extension ($) {
+ my ($f) = @_;
+ $f =~ s/\.(flac|mp[23]|ogg|wav)$//;
+ return $f;
+}
+
+sub die_usage () {
+ print STDERR <<EOF;
+usage:
+ $PROG get CONFIG
+ $PROG set CONFIG [LIST]
+EOF
+ exit 2;
+}
+
+defined (my $op = shift @ARGV) or die_usage;
+if ($op eq "get") {
+ defined (my $cf = shift @ARGV) or die_usage;
+ !@ARGV or die_usage;
+ my $conf = load_config $cf;
+ my $sk = connect_to_server %$conf;
+ my ($root, $list) = grobble_root $sk;
+
+ for my $f (sort @$list) {
+ my $pick = send_command $sk, "get", "$root$f", "pick_at_random";
+ if (($pick // 1) eq "0") { print trim_extension $f, "\n"; }
+ }
+ close $sk;
+} else {
+ defined (my $cf = shift @ARGV) or die_usage;
+ my $fh;
+ if (defined (my $list = shift @ARGV)) { open $fh, "<", $list; }
+ else { $fh = \*STDIN; }
+ my %black = ();
+ while (<$fh>) { chomp; $black{$_} = 1; }
+ my $conf = load_config $cf;
+ my $sk = connect_to_server %$conf;
+ my ($root, $list) = grobble_root $sk;
+
+ FILE: for my $f (sort @$list) {
+ my $pick = send_command $sk, "get", "$root$f", "pick_at_random";
+ if (($pick // 1) eq "0") {
+ next FILE if $black{trim_extension $f};
+ send_command $sk, "unset", "$root$f", "pick_at_random";
+ print STDERR ";; reinstate <$f>\n";
+ } else {
+ next FILE unless $black{trim_extension $f};
+ send_command $sk, "set", "$root$f", "pick_at_random", 0;
+ print STDERR ";; blacklist <$f>\n";
+ }
+ }
+ close $sk;
+}
--- /dev/null
+#! @PERL@ -w
+
+use autodie qw{:all};
+use strict;
+
+use DisOrder;
+use File::FcntlLock;
+use Getopt::Long qw{:config gnu_compat bundling
+ require_order no_getopt_compat};
+use POSIX qw{:errno_h :fcntl_h};
+
+###--------------------------------------------------------------------------
+### Configuration.
+
+my %C = (config => "$ENV{HOME}/.disorder/passwd",
+ lockdir => "$ENV{HOME}/.disorder/",
+ mixer => "Master,0");
+
+(my $PROG = $0) =~ s:^.*/::;
+my $TITLE = "DisOrder";
+my $VARIANT = "default";
+if (-l $C{config} && (my $t = readlink $C{config}) =~ /^passwd\.(.*)$/)
+ { $VARIANT = $1; $TITLE .= " ($1)"; }
+
+###--------------------------------------------------------------------------
+### Random utilities.
+
+sub run_discard_output (@) {
+ my $kid = fork();
+ if (!$kid) {
+ open STDOUT, ">/dev/null" or die "open /dev/null: $!";
+ exec @_;
+ }
+ waitpid $kid, 0;
+ if ($?) {
+ my $st;
+ if ($? >= 256) { $st = sprintf "rc = %d", $? >> 8; }
+ else { $st = sprintf "signal %d", $?; }
+ die "$_[0] failed ($st)";
+ }
+}
+
+sub notify ($$) {
+ my ($head, $body) = @_;
+
+ $body =~ s:\&:&:g;
+ $body =~ s:\<:<:g;
+ $body =~ s:\>:>:g;
+
+ ##print "****************\n$head\n\n$body\n"; return;
+
+ run_discard_output "notify-send",
+ "-c", "DisOrder", "-i", "audio-volume-high", "-t", "5000",
+ $head, $body;
+}
+
+sub try_unlink ($) {
+ my ($f) = @_;
+ eval { unlink $f; };
+ die $@ if $@ and $@->errno != ENOENT;
+}
+
+###--------------------------------------------------------------------------
+### Locking protocol.
+
+my $LKFILE = "$C{lockdir}/disorder-notify-$VARIANT.lock";
+my $LKFH;
+
+sub locked_by () {
+
+ ## Try to open the lock file. If it's not there, then obviously it's not
+ ## locked.
+ my $fh;
+ eval { open $fh, "<", $LKFILE; };
+ if ($@) {
+ return undef if $@->errno == ENOENT;
+ die $@;
+ }
+
+ ## Take out a non-exclusive lock on the lock file.
+ my $lk = new File::FcntlLock;
+ $lk->l_type(F_RDLCK); $lk->l_whence(SEEK_SET);
+ $lk->l_start(0); $lk->l_len(0);
+ if ($lk->lock($fh, F_SETLK)) { close $fh; return undef; }
+
+ ## Read the pid of the current lock-holder.
+ chomp (my $pid = (readline $fh) // "<unknown>");
+ close $fh;
+ return $pid;
+}
+
+sub claim_lock () {
+ sysopen my $fh, $LKFILE, O_CREAT | O_WRONLY;
+
+ my $lk = new File::FcntlLock;
+ $lk->l_type(F_WRLCK); $lk->l_whence(SEEK_SET);
+ $lk->l_start(0); $lk->l_len(0);
+ if (!$lk->lock($fh, F_SETLK)) {
+ return undef if $! == EAGAIN;
+ die "failed to lock `$LKFILE': $!";
+ }
+
+ truncate $fh, 0;
+ print $fh "$$\n";
+ flush $fh;
+ $LKFH = $fh;
+ 1;
+}
+
+###--------------------------------------------------------------------------
+### DisOrder utilities.
+
+sub get_state0 ($) {
+ my ($sk) = @_;
+ my %st = ();
+
+ LINE: for (;;) {
+ my @f = split_fields readline $sk;
+ if ($f[1] ne "state") { last LINE; }
+ elsif ($f[2] eq "enable_random") { $st{random} = 1; }
+ elsif ($f[2] eq "disable_random") { $st{random} = 0; }
+ elsif ($f[2] eq "enable_play") { $st{play} = 1; }
+ elsif ($f[2] eq "disable_play") { $st{play} = 0; }
+ elsif ($f[2] eq "resume") { $st{pause} = 0; }
+ elsif ($f[2] eq "pause") { $st{pause} = 1; }
+ }
+ return \%st;
+}
+
+my $CONF = undef;
+
+sub configured_connection (;$) {
+ my ($quietp) = @_;
+ $CONF //= load_config $C{config};
+ return connect_to_server %$CONF, $quietp // 0;
+}
+
+sub get_state () {
+ my $sk = configured_connection;
+ send_command0 $sk, "log";
+ my $st = get_state0 $sk;
+ close $sk;
+ return $st;
+}
+
+sub decode_track_name ($\%) {
+ my ($sk, $info) = @_;
+ return unless exists $info->{track};
+ my $track = $info->{track};
+ for my $i ("artist", "album", "title") {
+ my @f = split_fields send_command $sk, "part", $track, "display", "$i";
+ $info->{$i} = $f[0];
+ }
+}
+
+sub fmt_duration ($) {
+ my ($n) = @_;
+ return sprintf "%d:%02d", int $n/60, $n%60;
+}
+
+sub get_now_playing ($) {
+ my ($sk) = @_;
+ my $r = send_command $sk, "playing";
+ defined $r or return {};
+ my %info = split_fields $r;
+ decode_track_name $sk, %info;
+ exists $info{sofar} and
+ $info{length} = send_command $sk, "length", $info{track};
+ return \%info;
+}
+
+sub format_now_playing (;\%) {
+ my ($info) = @_;
+ unless (defined $info) {
+ my $sk = configured_connection;
+ $info = get_now_playing $sk;
+ close $sk;
+ }
+ exists $info->{track} or return "Nothing.";
+ my $r = "$info->{artist}: ‘$info->{title}’";
+ $r .= ", from ‘$info->{album}’" if $info->{album};
+ exists $info->{sofar} && exists $info->{length} and
+ $r .= sprintf " (%s/%s)",
+ fmt_duration $info->{sofar}, fmt_duration $info->{length};
+ $r .= "\n(chosen by $info->{submitter})" if exists $info->{submitter};
+ return $r;
+}
+
+sub watch_and_notify0 ($) {
+ my ($now_playing) = @_;
+
+ my $sk = configured_connection 1;
+ my $sk_log = configured_connection 1;
+
+ send_command0 $sk_log, "log";
+ my $st = get_state0 $sk_log;
+ my $msg = "playing " . ($st->{play} ? "enabled" : "disabled");
+ $msg .= "; random play " . ($st->{random} ? "enabled" : "disabled");
+ $msg .= "; " . ($st->{pause} ? "paused" : "playing");
+ notify "$TITLE state", "Connected: $msg";
+ if ($st->{play} && $now_playing) {
+ my $info = get_now_playing $sk;
+ notify "$TITLE: Now playing", format_now_playing %$info;
+ }
+
+ fcntl $sk_log, F_SETFL, (fcntl $sk_log, F_GETFL, 0) | O_NONBLOCK;
+ my $buffer = "";
+ my @lines = ();
+ my $rdin = ""; vec($rdin, (fileno $sk_log), 1) = 1;
+ my $loss;
+
+ WATCH: for (;;) {
+ for my $line (@lines) {
+ my @f = split_fields $line;
+ if ($f[1] eq "state") {
+ my $msg = undef;
+ if ($f[2] eq "disable_random")
+ { $st->{random} = 0; $msg = "Random play disabled"; }
+ elsif ($f[2] eq "enable_random")
+ { $st->{random} = 1; $msg = "Random play enabled"; }
+ elsif ($f[2] eq "disable_play")
+ { $st->{play} = 0; $msg = "Playing disabled"; }
+ elsif ($f[2] eq "enable_play")
+ { $st->{play} = 1; $msg = "Playing enabled"; }
+ elsif ($f[2] eq "pause")
+ { $st->{pause} = 1; $msg = "Paused"; }
+ elsif ($f[2] eq "resume")
+ { $st->{pause} = 0; $msg = "Playing"; }
+ notify "$TITLE state", $msg if defined $msg;
+ } elsif ($f[1] eq "playing") {
+ my %info;
+ $info{track} = $f[2];
+ $info{submitter} = $f[3] if @f > 3;
+ decode_track_name $sk, %info;
+ notify "$TITLE: Now playing", format_now_playing %info;
+ } elsif ($f[1] eq "scratched") {
+ my %info;
+ $info{track} = $f[2];
+ decode_track_name $sk, %info;
+ notify "$TITLE: Scratched by $f[3]", format_now_playing %info;
+ } elsif ($f[1] eq "completed" && !$st->{play}) {
+ notify "$TITLE state", "Stopped";
+ }
+ }
+
+ if (!$sk_log) { $loss = "EOF from server"; last WATCH; }
+ my $nfd = select my $rdout = $rdin, undef, undef, 60;
+ if (!$nfd) {
+ eval { print $sk_log "."; flush $sk_log; };
+ if ($@) { $loss = "error from write: " . $@->errno; last WATCH; }
+ @lines = ();
+ } else {
+ READ: for (;;) {
+ my ($b, $n);
+ eval { $n = sysread $sk_log, $b, 4096; };
+ if ($@ && $@->errno == EAGAIN) { last READ; }
+ elsif ($@) { $loss = "error from read: " . $@->errno; last WATCH; }
+ elsif (!$n) { close $sk_log; $sk_log = undef; last READ; }
+ else { $buffer .= $b; }
+ }
+
+ @lines = split /\n/, $buffer, -1;
+ $buffer = pop @lines;
+ }
+ }
+
+ notify "$TITLE state", "Lost connection: $loss";
+
+ close $sk;
+ close $sk_log if defined $sk_log;
+}
+
+sub watch_and_notify ($) {
+ my ($now_playing) = @_;
+
+ claim_lock or exit 1;
+
+ for (;;) {
+ eval { watch_and_notify0 $now_playing; };
+ $now_playing = 1;
+ sleep 5;
+ }
+}
+
+###--------------------------------------------------------------------------
+### User-facing operations.
+
+my %OP;
+
+$OP{"volume-up"} =
+ sub { run_discard_output "amixer", "sset", $C{mixer}, "5\%+"; };
+$OP{"volume-down"} =
+ sub { run_discard_output "amixer", "sset", $C{mixer}, "5\%-"; };
+
+$OP{"scratch"} = sub {
+ my $sk = configured_connection;
+ send_command $sk, "scratch";
+ close $sk;
+};
+
+$OP{"enable/disable"} = sub {
+ my $st = get_state;
+ my $sk = configured_connection;
+ if ($st->{play}) { send_command $sk, "disable"; }
+ else { send_command $sk, "enable"; }
+ close $sk;
+};
+
+$OP{"play/pause"} = sub {
+ my $st = get_state;
+ my $sk = configured_connection;
+ if (!$st->{play}) {
+ send_command $sk, "enable";
+ if ($st->{pause}) { send_command $sk, "resume"; }
+ } else {
+ if ($st->{pause}) { send_command $sk, "resume"; }
+ else { send_command $sk, "pause"; }
+ }
+ close $sk;
+};
+
+$OP{"watch"} = sub {
+ if (defined (my $lkpid = locked_by)) {
+ print STDERR "$0: already watched by pid $lkpid\n";
+ exit 2;
+ }
+ watch_and_notify 1;
+};
+
+$OP{"now-playing"} = sub {
+ my $sk = configured_connection;
+ my $info = get_now_playing $sk;
+ close $sk;
+ print format_now_playing %$info;
+ print "\n";
+};
+
+$OP{"notify-now-playing"} = sub {
+ my $sk = configured_connection;
+ my $info = get_now_playing $sk;
+ close $sk;
+ notify "$TITLE: Now playing", format_now_playing %$info;
+ unless (defined locked_by) {
+ fork and exit 0;
+ watch_and_notify 0;
+ }
+};
+
+$OP{"next-config"} = sub {
+ (my $dir = $C{config}) =~ s:/[^/]*$::;
+ my (@conf, $curr, $conf, $min);
+
+ if (-l $C{config} && (my $t = readlink $C{config}) =~ /^passwd\.(.*)$/)
+ { $curr = $1; }
+
+ opendir my $dh, +$dir;
+ FILE: while (my $f = readdir $dh)
+ { push @conf, $1 if $f =~ /^passwd\.(.*[^~])$/; }
+
+ for (my $i = 0; $i < @conf; $i++) {
+ $min = $conf[$i] if (!defined $min) || $conf[$i] lt $min;
+ $conf = $conf[$i]
+ if ((!defined $curr) || $curr lt $conf[$i]) &&
+ ((!defined $conf) || $conf[$i] lt $conf);
+ }
+ $conf = $min unless defined $conf;
+
+ try_unlink "$dir/passwd.new";
+ symlink "passwd.$conf", "$dir/passwd.new";
+ rename "$dir/passwd.new", "$dir/passwd";
+ notify "DisOrder configuration", "Switched to `$conf'";
+};
+
+###--------------------------------------------------------------------------
+### Main program.
+
+sub usage (\*) {
+ my ($fh) = @_;
+ print $fh "usage: $PROG [-u CONFIG] COMMAND\n";
+}
+
+sub help () {
+ usage *STDOUT;
+ print <<EOF;
+
+Command-line options:
+ -h, --help Show this help text
+ -u, --user-config Set user configuration file
+
+Commands:
+ volume-up
+ volume-down
+ scratch
+ enable/disable
+ play/pause
+ watch
+ now-playing
+ notify-now-playing
+ next-config
+EOF
+}
+
+my $bad = 0;
+GetOptions
+ "h|help" => sub { help; exit 0; },
+ "u|user-config=s" => \$C{config}
+ or $bad = 1;
+@ARGV == 1 or $bad = 1;
+if ($bad) { usage *STDERR; exit 2; }
+my $op = $ARGV[0];
+if (!exists $OP{$op}) { print STDERR "$0: unknown op `$op'\n"; exit 2; }
+$OP{$op}();
+
+###----- That's all, folks --------------------------------------------------
--- /dev/null
+#! @PERL@ -w
+
+use autodie qw{:all};
+use strict;
+
+use DisOrder;
+use Getopt::Long qw{:config gnu_compat bundling
+ require_order no_getopt_compat};
+use POSIX qw{:errno_h :fcntl_h :sys_wait_h};
+
+my $CONFFILE = undef;
+my $DEBUG = 0;
+(my $PROG = $0) =~ s:^.*/::;
+
+sub mumble ($) { print STDERR ";; $_[0]\n" if $DEBUG; }
+
+sub connection () {
+ my $file = $CONFFILE // "$ENV{HOME}/.disorder/passwd", my $conf;
+
+ if (-f $file || defined $CONFFILE)
+ { $conf = load_config $file; }
+ else {
+ $conf = { connect => ["-unix", "/var/lib/disorder/private/socket"],
+ username => ["root"], password => ["hunoz"] };
+ }
+ return connect_to_server %$conf;
+}
+
+my $PAUSETIME = 300;
+my $PID = undef;
+my $STATE = "off"; # `off', `on', `killed'
+my $WANT = "off"; # `off', `on', `pause'
+my $STOPTIME = undef; # if $WANT eq "pause"
+my $NOW = time;
+
+$SIG{CHLD} = sub {
+ KID: for (;;) {
+ my $kid = waitpid -1, WNOHANG;
+ last if $kid <= 0;
+ if ($kid == $PID) {
+ mumble "player exited (st = $?)";
+ $PID = undef; $STATE = "off";
+ }
+ }
+};
+
+$SIG{TERM} = $SIG{INT} = sub {
+ kill "TERM", $PID if defined $PID;
+ exit 0;
+};
+
+sub start () { $WANT = "on"; $STOPTIME = undef; }
+
+sub pause () {
+ if ($WANT eq "on") { $WANT = "pause"; $STOPTIME = $NOW + $PAUSETIME; }
+}
+
+sub fix_state () {
+
+ ##mumble "state = $STATE ($PID)";
+ ##mumble "want = $WANT ($STOPTIME <=> $NOW)";
+
+ if ($WANT eq "pause" && $NOW >= $STOPTIME) {
+ $WANT = "off"; $STOPTIME = undef;
+ mumble "pause time up: stopping" if $STATE eq "on";
+ }
+
+ if ($WANT eq "on" && $STATE eq "off") {
+ my $kid = fork();
+ if (!$kid) { exec @ARGV; }
+ $STATE = "on"; $PID = $kid;
+ mumble "player wanted but not running: started pid $kid";
+ } elsif ($WANT eq "off" && $STATE eq "on") {
+ kill "TERM", $PID;
+ $STATE = "killed";
+ mumble "player running but not wanted: killed pid $PID";
+ }
+}
+
+sub watch_status () {
+ my $sk = connection;
+
+ my $pause, my $track = 0;
+
+ my $rdin = ""; vec($rdin, fileno($sk), 1) = 1;
+ my $buffer = "", my @lines = ();
+
+ $NOW = time;
+
+ my $r = send_command $sk, "playing";
+ $track = defined $r;
+
+ print $sk "log\n";
+ fcntl $sk, F_SETFL, (fcntl $sk, F_GETFL, 0) | O_NONBLOCK;
+ WATCH: for (;;) {
+
+ if (!$sk) { mumble "eof from server"; last WATCH; }
+ my $nfd;
+ SEL: {
+ eval {
+ $nfd = select my $rdout = $rdin, undef, undef,
+ defined($STOPTIME) ? $STOPTIME - $NOW : 60;
+ };
+ if ($@ && $@->errno == EINTR) { next SEL; }
+ elsif ($@) { mumble "error from select: " . $@->errno; last WATCH; }
+ }
+ if (!$nfd) {
+ eval { print $sk "."; flush $sk; };
+ if ($@) { mumble "error from write: " . $@->errno; last WATCH; }
+ @lines = ();
+ } else {
+ READ: for (;;) {
+ my ($b, $n);
+ eval { $n = sysread $sk, $b, 4096; };
+ if ($@ && $@->errno == EAGAIN) { last READ; }
+ elsif ($@ && $@->errno == EINTR) { next READ; }
+ elsif ($@) { mumble "error from read: " . $@->errno; last WATCH; }
+ elsif (!$n) { close $sk; $sk = undef; last READ; }
+ else { $buffer .= $b; }
+ }
+
+ @lines = split /\n/, $buffer, -1;
+ $buffer = pop @lines;
+ }
+
+ for my $line (@lines) {
+ my @f = split_fields $line;
+ if ($f[1] eq "state") {
+ if ($f[2] eq "pause") { mumble "paused"; $pause = 1; }
+ elsif ($f[2] eq "resume") { mumble "unpaused"; $pause = 0; }
+ } elsif ($f[1] eq "playing") { mumble "track started"; $track = 1; }
+ elsif ($f[1] eq "completed") { mumble "track finished"; $track = 0; }
+ }
+
+ $NOW = time;
+
+ if ($track && !$pause) { start; } else { pause; }
+ fix_state;
+ }
+}
+
+sub usage (\*) {
+ my ($fh) = @_;
+ print $fh "usage: $PROG [-d] [-u CONFIG] [--] COMMAND ARGS...\n";
+}
+
+sub help () {
+ usage *STDOUT;
+ print <<EOF;
+
+Command-line options:
+ -h, --help Show this help text
+ -u, --user-config Set user configuration file
+EOF
+}
+
+my $bad = 0;
+GetOptions
+ "h|help" => sub { help; exit 0; },
+ "d|debug" => \$DEBUG,
+ "u|user-config=s" => \$CONFFILE
+ or $bad = 1;
+@ARGV > 0 or $bad = 1;
+if ($bad) { usage *STDERR; exit 2; }
+
+for (;;) {
+ eval { watch_status; }; mumble "watcher exited: $@";
+ pause; fix_state;
+ sleep 5;
+}
--- /dev/null
+#! /bin/sh -e
+
+prog=${0##*/}
+fail () { echo >&2 "$prog: $1"; exit 2; }
+usage () { echo "usage: $prog [CONF]"; }
+
+bogus=nil
+while getopts "h" opt; do
+ case $opt in
+ h) usage; exit 0 ;;
+ *) bogus=t ;;
+ esac
+done
+shift $(( $OPTIND - 1 ))
+case $# in 0) op=query ;; 1) op=set conf=$1 ;; *) bogus=t ;; esac
+case $bogus in t) usage >&2; exit 2 ;; esac
+
+cd "$HOME/.disorder"
+case $op in
+ query)
+ if ! [ -L passwd ]; then link=bogus
+ else link=$(readlink passwd)
+ fi
+ case $link in
+ passwd.*) conf=${link#passwd.} ;;
+ *) fail "\`~/.disorder/passwd' not a link to \`passwd.CONF'" ;;
+ esac
+ echo "$conf"
+ ;;
+ set)
+ if ! [ -f "passwd.$conf" ]; then fail "no config \`passwd.$conf'"; fi
+ ln -sf "passwd.$conf" passwd
+ ;;
+esac
~mdw / disorder-toys / commitdiff