.tclshrc_SRC = tclshrc
.wishrc_SRC = tclshrc
-## Jukebox things.
-MISCLINKS += lib/perl/DisOrder.pm
-lib/perl/DisOrder.pm_SRC = pl/DisOrder.pm
-SCRIPTLINKS += disorder-switch-config
-SCRIPTLINKS += disorder-autoplay
-SCRIPTLINKS += disorder-notify
-
## Random scripts.
SCRIPTLINKS += mdw-editor mdw-pager
SCRIPTLINKS += mdw-conf
+++ /dev/null
-#! /usr/bin/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
-#! /usr/bin/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
-#! /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
esac
dirs=$1 host=${2%:*} dpy=${2##*:}; shift 2
case $#,$1 in
- 0 | 1,:slideshow)
- set -- /usr/lib/xscreensaver/glslideshow -duration 60 -pan 10 \
+ 0, | 1,:slideshow)
+ set -- /usr/lib/xscreensaver/glslideshow -duration 10 -pan 10 \
-xrm "'*desktopGrabber: ./getimg %s'"
;;
1,:photopile)
'(("en_GB-ize-w_accents" "[[:alpha:]]" "[^[:alpha:]]" "'" t
("-d" "en_GB-ize-w_accents") nil utf-8))
ispell-silently-savep t)
+(setq-default viper-case-fold-search t
+ viper-electric-mode t
+ viper-ex-style-motion nil
+ viper-ex-style-editing nil
+ viper-expert-level 5
+ viper-inhibit-startup-message t
+ ;;viper-insert-state-cursor-color "red"
+ viper-no-multiple-ESC nil
+ viper-re-query-replace t
+ viper-re-search t
+ ;;viper-replace-overlay-cursor-color "red"
+ viper-shift-width 2
+ viper-vi-style-in-minibuffer nil
+ viper-want-ctl-h-help t)
(trap
(require 'uniquify)
(setq uniquify-buffer-name-style 'post-forward-angle-brackets)
(tool-bar-mode 0))
(trap (or mdw-fast-startup (global-auto-revert-mode t)))
+(defun mdw-set-viper-cursor-colour ()
+ ;; ?? doesn't seem to work
+ (set-frame-parameter nil 'cursor-color "green")
+ (message ";; %S" post-command-hook)
+ (sit-for 2))
+;;(add-hook 'viper-vi-state-hook 'mdw-set-viper-cursor-colour)
+
(defvar mdw-black-background t)
(eval-after-load "outline"
#+mdw (cl:in-package #:mdw-hacks)
;; Miscellaneous configuration.
-(setf swank:*communication-style* :fd-handler
- swank:*dont-close* t
+(setf swank:*dont-close* t
*print-right-margin* 77)
+#+(or sbcl cmu) (setf swank:*communication-style* :fd-handler)
;; Maybe inhibit some Swank extensions.
(let ((forbidden-contribs
unsetopt menu_complete
setopt notify
setopt rc_expand_param
+setopt rc_quotes
setopt share_history
hash -d t=$TMPDIR
(((class color)) :background "cyan")
(t :inverse-video t))
+(mdw-define-face viper-minibuffer-emacs (t nil))
+(mdw-define-face viper-minibuffer-insert (t nil))
+(mdw-define-face viper-minibuffer-vi (t nil))
+(mdw-define-face viper-replace-overlay
+ (((min-colors 64)) :background "darkred")
+ (((class color)) :background "red")
+ (t :inverse-video t))
+(mdw-define-face viper-search (t :inherit isearch))
+
(mdw-define-face holiday-face
(t :background "red"))
(mdw-define-face calendar-today-face
(mdw-define-c-style mdw-trustonic-c (mdw-c)
(c-basic-offset . 4)
- (c-indent-comment-alist (anchored-comment . (column . 0))
- (end-block . (space . 1))
- (cpp-end-block . (space . 1))
- (other . (space . 1)))
(c-offsets-alist (access-label . -2)))
(mdw-define-c-style mdw-trustonic-alec-c (mdw-trustonic-c)
(comment-column . 0)
+ (c-indent-comment-alist (anchored-comment . (column . 0))
+ (end-block . (space . 1))
+ (cpp-end-block . (space . 1))
+ (other . (space . 1)))
(c-offsets-alist (arglist-cont-nonempty . mdw-c-indent-arglist-nested)))
(defun mdw-set-default-c-style (modes style)
;; Miscellaneous fiddling.
(mdw-standard-fill-prefix "\\([ \t]*#+[ \t]*\\)")
(setq indent-tabs-mode nil)
+ (set (make-local-variable 'forward-sexp-function) nil)
;; Now define fontification things.
(make-local-variable 'font-lock-keywords)
--- /dev/null
+<SearchPlugin xmlns="http://www.mozilla.org/2006/browser/search/" xmlns:os="http://a9.com/-/spec/opensearch/1.1/">
+<os:ShortName>startpage (custom)</os:ShortName>
+<os:Description>Startpage: Search the web in complete privacy</os:Description>
+<os:InputEncoding>UTF-8</os:InputEncoding>
+<!-- fix me!
+<os:Image width="16" height="16">data:image/x-icon;base64,???</os:Image>
+<SearchForm>https://en.wikipedia.org/wiki/Special:Search</SearchForm>
+<os:Url type="application/x-suggestions+json" method="GET" template="https://en.wikipedia.org/w/api.php" resultDomain="en.wikipedia.org">
+ <os:Param name="action" value="opensearch"/>
+ <os:Param name="search" value="{searchTerms}"/>
+</os:Url>
+<os:Url type="text/html" method="GET" template="https://en.wikipedia.org/wiki/Special:Search" resultDomain="wikipedia.org">
+ <os:Param name="search" value="{searchTerms}"/>
+</os:Url>
+-->
+</SearchPlugin>
--- /dev/null
+/* -*-css-*- */
+/*@ domains: wiki.trustonic.internal */
+body { font-family: inherit; font-size: 11pt; }
+h1, h2, h3, h4 { font-family: sans-serif; font-weight: bold; }
+.aui-button, .aui-nav-link, .aui-nav-imagelimk, .user-mention, [role=menu]
+ { font-family: sans-serif !important; }
+code, kbd, pre { font-family: monospace; font-size: 9pt; }
+/*@END*/
+++ /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;
~mdw / profile / commitdiff