chiark / gitweb /
el/dot-emacs.el: Don't print `flyspell' overlays.
[profile] / pl / DisOrder.pm
1 ### -*-perl-*-
2
3 use autodie qw{:all};
4 use strict;
5
6 use Digest::SHA;
7 use Exporter qw{import};
8 use Socket qw{:DEFAULT :addrinfo};
9
10 our @EXPORT_OK = qw{get_response0 decode_response get_response
11                     send_command0 send_command
12                     split_fields
13                     load_config connect_to_server};
14
15 use Data::Dumper;
16
17 sub split_response_code ($) {
18   my ($st) = @_;
19   my $c = $st%10; $st = int($st/10);
20   my $b = $st%10; $st = int($st/10);
21   my $a = $st;
22   return ($a, $b, $c);
23 }
24
25 sub get_response0 ($) {
26   my ($sk) = @_;
27   (my $st, my $r) = split ' ', (readline $sk), 2;
28   chomp $r;
29
30   my ($a, $b, $c) = split_response_code $st;
31   if ($a == 5) {
32     if ($c == 5) { return $st, undef; }
33     else { die "server error: $r"; }
34   }
35   elsif ($a != 2) { die "unexpected status code $a"; }
36   else { return $st, $r; }
37 }
38
39 sub decode_response ($$$) {
40   my ($sk, $st, $r) = @_;
41   my ($a, $b, $c) = split_response_code $st;
42
43   if ($c == 0 || $c == 5 || $c == 9) { return undef; }
44   elsif ($c == 1 || $c == 2) { return $r; }
45   elsif ($c == 3) {
46     my @r = ();
47     LINE: for (;;) {
48       chomp (my $line = readline $sk);
49       last LINE if $line eq ".";
50       $line =~ s/^\.//;
51       push @r, $line;
52     }
53     return @r;
54   } else { die "unexpected format code $c in $st"; }
55 }
56
57 sub get_response ($) {
58   my ($sk) = @_;
59   my ($st, $r) = get_response0 $sk;
60   return decode_response $sk, $st, $r;
61 }
62
63 sub send_command0 ($@) {
64   my ($sk, @f) = @_;
65
66   my $t = "";
67   for my $f (@f) {
68     if ($f eq "" || $f =~ /[\\"'\s]/) {
69       $f =~ s/([\\"])/\\$1/g;
70       $f = '"' . $f . '"';
71     }
72     $t .= " " if $t;
73     $t .= $f;
74   }
75   print $sk "$t\n";
76   return get_response0 $sk;
77 }
78
79 sub send_command ($@) {
80   my ($sk, @f) = @_;
81   my ($st, $r) = send_command0 $sk, @f;
82   return decode_response $sk, $st, $r;
83 }
84
85 sub split_fields ($) {
86   my ($l) = @_;
87   my @f = ();
88   my $f;
89
90   FIELD: for (;;) {
91     $l =~ s/^\s*//;
92     last FIELD if $l eq "";
93     if ($l =~ /^(["'])/) {
94       my $q = $1;
95       ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
96       $f =~ s/\\(.)/$1/g;
97     } else {
98       ($f, $l) = split ' ', $l, 2; $l //= "";
99     }
100     push @f, $f;
101   }
102   return @f;
103 }
104
105 sub load_config ($) {
106   my ($conf) = @_;
107   my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
108
109   open my $fh, "<", $conf;
110   LINE: while (<$fh>) {
111     chomp;
112     next LINE unless /^\s*[^\s#]/;
113     (my $k, my @f) = split;
114     $conf{$k} = \@f;
115   }
116   close $fh;
117   for my $i (qw{ username password })
118     { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
119   return \%conf;
120 }
121
122 sub connect_to_server (\%;$) {
123   my ($conf, $quietp) = @_;
124   my @f;
125
126   my $af = AF_UNSPEC;
127   my @a = $conf->{connect}->@*;
128   die "empty address" unless @a;
129   if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
130   elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
131   elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
132   elsif ($a[0] eq "-") { shift @a; }
133   die "empty address" unless @a;
134
135   my $a;
136   my @i;
137   if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
138     @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
139     shift @a;
140   } else {
141     die "missing port" unless @a >= 2;
142     (my $e, @i) = getaddrinfo $a[0], $a[1],
143       { family => $af, socktype => SOCK_STREAM };
144     die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
145     splice @a, 0, 2;
146   }
147   die "junk in address" if @a;
148
149   my $sk;
150   my @e;
151   ADDR: for my $i (@i) {
152     eval {
153       socket $sk, $i->{family}, SOCK_STREAM, 0;
154       connect $sk, $i->{addr};
155     };
156     last ADDR unless $@;
157     close $sk if defined $sk;
158     push @e, $@->errno;
159     $sk = undef;
160   }
161
162   unless (defined $sk) {
163     die "failed to connect" if $quietp;
164     print STDERR "failed to connect!\n";
165     for (my $i = 0; $i < @i; $i++) {
166       if ($i[$i]{family} == AF_UNIX)
167         { $a = unpack_sockaddr_un $i[$i]{addr}; }
168       else {
169         my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
170           NI_NUMERICHOST | NI_NUMERICSERV;
171         die "getnameinfo: $e" if $e;
172         $a = $host . ":" . $svc;
173       }
174       print STDERR "\t$a: $e[$i]\n";
175     }
176     die "giving up";
177   }
178   autoflush $sk 1;
179
180   @f = split_fields get_response $sk;
181   die "expected version 2" unless $f[0] eq "2";
182   my $h = Digest::SHA->new($f[1]);
183   $h->add($conf->{password}[0], pack "H*", $f[2]);
184   my $d = $h->hexdigest;
185   send_command $sk, "user", $conf->{username}[0], $d;
186
187   return $sk;
188 }
189
190 1;