Commit | Line | Data |
---|---|---|
597993cf MB |
1 | ;;; erc-dcc.el --- CTCP DCC module for ERC |
2 | ||
ba318903 | 3 | ;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2014 Free Software |
ab422c4d | 4 | ;; Foundation, Inc. |
597993cf MB |
5 | |
6 | ;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu> | |
7 | ;; Noah Friedman <friedman@prep.ai.mit.edu> | |
8 | ;; Per Persson <pp@sno.pp.se> | |
34dc21db | 9 | ;; Maintainer: emacs-devel@gnu.org |
597993cf MB |
10 | ;; Keywords: comm, processes |
11 | ;; Created: 1994-01-23 | |
12 | ||
13 | ;; This file is part of GNU Emacs. | |
14 | ||
4ee57b2a | 15 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
597993cf | 16 | ;; it under the terms of the GNU General Public License as published by |
4ee57b2a GM |
17 | ;; the Free Software Foundation, either version 3 of the License, or |
18 | ;; (at your option) any later version. | |
597993cf MB |
19 | |
20 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
21 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
22 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
23 | ;; GNU General Public License for more details. | |
24 | ||
25 | ;; You should have received a copy of the GNU General Public License | |
4ee57b2a | 26 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
597993cf MB |
27 | |
28 | ;;; Commentary: | |
29 | ||
9cc8d0b6 | 30 | ;; This file provides Direct Client-to-Client support for ERC. |
597993cf MB |
31 | ;; |
32 | ;; The original code was taken from zenirc-dcc.el, heavily mangled and | |
33 | ;; rewritten to support the way how ERC operates. Server socket support | |
34 | ;; was added for DCC CHAT and SEND afterwards. Thanks | |
35 | ;; to the original authors for their work. | |
83dc6995 MB |
36 | |
37 | ;;; Usage: | |
38 | ||
597993cf MB |
39 | ;; To use this file, put |
40 | ;; (require 'erc-dcc) | |
41 | ;; in your .emacs. | |
42 | ;; | |
43 | ;; Provided commands | |
44 | ;; /dcc chat nick - Either accept pending chat offer from nick, or offer | |
45 | ;; DCC chat to nick | |
46 | ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick | |
47 | ;; /dcc get nick [file] - Accept DCC offer from nick | |
48 | ;; /dcc list - List all DCC offers/connections | |
49 | ;; /dcc send nick file - Offer DCC SEND to nick | |
50 | ;; | |
51 | ;; Please note that offering DCC connections (offering chats and sending | |
83dc6995 | 52 | ;; files) is only supported with Emacs 22. |
597993cf MB |
53 | |
54 | ;;; Code: | |
55 | ||
56 | (require 'erc) | |
19dc7206 | 57 | (eval-when-compile (require 'pcomplete)) |
597993cf | 58 | |
5e56b3fb MO |
59 | ;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") |
60 | (define-erc-module dcc nil | |
61 | "Provide Direct Client-to-Client support for ERC." | |
62 | ((add-hook 'erc-server-401-functions 'erc-dcc-no-such-nick)) | |
63 | ((remove-hook 'erc-server-401-functions 'erc-dcc-no-such-nick))) | |
64 | ||
597993cf MB |
65 | (defgroup erc-dcc nil |
66 | "DCC stands for Direct Client Communication, where you and your | |
67 | friend's client programs connect directly to each other, | |
68 | bypassing IRC servers and their occasional \"lag\" or \"split\" | |
69 | problems. Like /MSG, the DCC chat is completely private. | |
70 | ||
71 | Using DCC get and send, you can transfer files directly from and to other | |
72 | IRC users." | |
73 | :group 'erc) | |
74 | ||
5e56b3fb | 75 | (defcustom erc-dcc-verbose nil |
fb7ada5f | 76 | "If non-nil, be verbose about DCC activity reporting." |
597993cf MB |
77 | :group 'erc-dcc |
78 | :type 'boolean) | |
79 | ||
1c86baa4 MO |
80 | (defconst erc-dcc-connection-types |
81 | '("CHAT" "GET" "SEND") | |
82 | "List of valid DCC connection types. | |
83 | All values of the list must be uppercase strings.") | |
84 | ||
597993cf MB |
85 | (defvar erc-dcc-list nil |
86 | "List of DCC connections. Looks like: | |
87 | ((:nick \"nick!user@host\" :type GET :peer proc :parent proc :size size :file file) | |
88 | (:nick \"nick!user@host\" :type CHAT :peer proc :parent proc) | |
89 | (:nick \"nick\" :type SEND :peer server-proc :parent parent-proc :file | |
90 | file :sent <marker> :confirmed <marker>)) | |
91 | ||
92 | :nick - a user or userhost for the peer. combine with :parent to reach them | |
93 | ||
94 | :type - the type of DCC connection - SEND for outgoing files, GET for | |
95 | incoming, and CHAT for both directions. To tell which end started | |
96 | the DCC chat, look at :peer | |
97 | ||
98 | :peer - the other end of the DCC connection. In the case of outgoing DCCs, | |
99 | this represents a server process until a connection is established | |
100 | ||
101 | :parent - the server process where the dcc connection was established. | |
102 | Note that this can be nil or an invalid process since a DCC | |
103 | connection is in general independent from a particular server | |
104 | connection after it was established. | |
105 | ||
106 | :file - for outgoing sends, the full path to the file. for incoming sends, | |
107 | the suggested filename or vetted filename | |
108 | ||
109 | :size - size of the file, may be nil on incoming DCCs") | |
110 | ||
111 | (defun erc-dcc-list-add (type nick peer parent &rest args) | |
112 | "Add a new entry of type TYPE to `erc-dcc-list' and return it." | |
113 | (car | |
114 | (setq erc-dcc-list | |
115 | (cons | |
116 | (append (list :nick nick :type type :peer peer :parent parent) args) | |
117 | erc-dcc-list)))) | |
118 | ||
119 | ;; This function takes all the usual args as open-network-stream, plus one | |
120 | ;; more: the entry data from erc-dcc-list for this particular process. | |
121 | (defvar erc-dcc-connect-function 'erc-dcc-open-network-stream) | |
122 | ||
123 | (defun erc-dcc-open-network-stream (procname buffer addr port entry) | |
124 | (if nil; (fboundp 'open-network-stream-nowait) ;; this currently crashes | |
125 | ;; cvs emacs | |
126 | (open-network-stream-nowait procname buffer addr port) | |
127 | (open-network-stream procname buffer addr port))) | |
128 | ||
129 | (erc-define-catalog | |
130 | 'english | |
131 | '((dcc-chat-discarded | |
132 | . "DCC: previous chat request from %n (%u@%h) discarded") | |
133 | (dcc-chat-ended . "DCC: chat with %n ended %t: %e") | |
134 | (dcc-chat-no-request . "DCC: chat request from %n not found") | |
135 | (dcc-chat-offered . "DCC: chat offered by %n (%u@%h:%p)") | |
136 | (dcc-chat-offer . "DCC: offering chat to %n") | |
137 | (dcc-chat-accept . "DCC: accepting chat from %n") | |
138 | (dcc-chat-privmsg . "=%n= %m") | |
139 | (dcc-closed . "DCC: Closed %T from %n") | |
140 | (dcc-command-undefined | |
141 | . "DCC: %c undefined subcommand. GET, CHAT and LIST are defined.") | |
142 | (dcc-ctcp-errmsg . "DCC: `%s' is not a DCC subcommand known to this client") | |
143 | (dcc-ctcp-unknown . "DCC: unknown dcc command `%q' from %n (%u@%h)") | |
144 | (dcc-get-bytes-received . "DCC: %f: %b bytes received") | |
145 | (dcc-get-complete | |
146 | . "DCC: file %f transfer complete (%s bytes in %t seconds)") | |
147 | (dcc-get-cmd-aborted . "DCC: Aborted getting %f from %n") | |
148 | (dcc-get-file-too-long | |
149 | . "DCC: %f: File longer than sender claimed; aborting transfer") | |
150 | (dcc-get-notfound . "DCC: %n hasn't offered %f for DCC transfer") | |
1c86baa4 MO |
151 | (dcc-list-head . "DCC: From Type Active Size Filename") |
152 | (dcc-list-line . "DCC: -------- ---- ------ -------------- --------") | |
153 | (dcc-list-item . "DCC: %-8n %-4t %-6a %-14s %f") | |
597993cf MB |
154 | (dcc-list-end . "DCC: End of list.") |
155 | (dcc-malformed . "DCC: error: %n (%u@%h) sent malformed request: %q") | |
156 | (dcc-privileged-port | |
157 | . "DCC: possibly bogus request: %p is a privileged port.") | |
158 | (dcc-request-bogus . "DCC: bogus dcc `%r' from %n (%u@%h)") | |
159 | (dcc-send-finished . "DCC: SEND of %f to %n finished (size %s)") | |
160 | (dcc-send-offered . "DCC: file %f offered by %n (%u@%h) (size %s)") | |
161 | (dcc-send-offer . "DCC: offering %f to %n"))) | |
162 | ||
163 | ;;; Misc macros and utility functions | |
164 | ||
165 | (defun erc-dcc-member (&rest args) | |
166 | "Return the first matching entry in `erc-dcc-list' which satisfies the | |
167 | constraints given as a plist in ARGS. Returns nil on no match. | |
168 | ||
169 | The property :nick is treated specially, if it contains a '!' character, | |
170 | it is treated as a nick!user@host string, and compared with the :nick property | |
171 | value of the individual elements using string-equal. Otherwise it is | |
172 | compared with `erc-nick-equal-p' which is IRC case-insensitive." | |
173 | (let ((list erc-dcc-list) | |
174 | result test) | |
175 | ;; for each element in erc-dcc-list | |
176 | (while (and list (not result)) | |
177 | (let ((elt (car list)) | |
178 | (prem args) | |
179 | (cont t)) | |
180 | ;; loop through the constraints | |
181 | (while (and prem cont) | |
182 | (let ((prop (car prem)) | |
183 | (val (cadr prem))) | |
184 | (setq prem (cddr prem) | |
185 | ;; plist-member is a predicate in xemacs | |
186 | test (and (plist-member elt prop) | |
187 | (plist-get elt prop))) | |
188 | ;; if the property exists and is equal, we continue, else, try the | |
189 | ;; next element of the list | |
190 | (or (and (eq prop :nick) (string-match "!" val) | |
191 | test (string-equal test val)) | |
192 | (and (eq prop :nick) | |
193 | test val | |
194 | (erc-nick-equal-p | |
195 | (erc-extract-nick test) | |
196 | (erc-extract-nick val))) | |
197 | ;; not a nick | |
198 | (eq test val) | |
199 | (setq cont nil)))) | |
200 | (if cont | |
201 | (setq result elt) | |
202 | (setq list (cdr list))))) | |
203 | result)) | |
204 | ||
5e56b3fb | 205 | (defun erc-pack-int (value) |
1c86baa4 MO |
206 | "Convert an integer into a packed string in network byte order, |
207 | which is big-endian." | |
208 | ;; make sure value is not negative | |
209 | (when (< value 0) | |
210 | (error "ERC-DCC (erc-pack-int): packet size is negative")) | |
211 | ;; make sure size is not larger than 4 bytes | |
212 | (let ((len (if (= value 0) 0 | |
213 | (ceiling (/ (ceiling (/ (log value) (log 2))) 8.0))))) | |
214 | (when (> len 4) | |
215 | (error "ERC-DCC (erc-pack-int): packet too large"))) | |
216 | ;; pack | |
217 | (let ((str (make-string 4 0)) | |
218 | (i 3)) | |
219 | (while (and (>= i 0) (> value 0)) | |
5e56b3fb MO |
220 | (aset str i (% value 256)) |
221 | (setq value (/ value 256)) | |
222 | (setq i (1- i))) | |
223 | str)) | |
597993cf | 224 | |
1c86baa4 MO |
225 | (defconst erc-most-positive-int-bytes |
226 | (ceiling (/ (ceiling (/ (log most-positive-fixnum) (log 2))) 8.0)) | |
227 | "Maximum number of bytes for a fixnum.") | |
228 | ||
229 | (defconst erc-most-positive-int-msb | |
230 | (lsh most-positive-fixnum (- 0 (* 8 (1- erc-most-positive-int-bytes)))) | |
231 | "Content of the most significant byte of most-positive-fixnum.") | |
232 | ||
597993cf | 233 | (defun erc-unpack-int (str) |
5e56b3fb | 234 | "Unpack a packed string into an integer." |
1c86baa4 MO |
235 | (let ((len (length str))) |
236 | ;; strip leading 0-bytes | |
237 | (let ((start 0)) | |
238 | (while (and (> len start) (eq (aref str start) 0)) | |
239 | (setq start (1+ start))) | |
240 | (when (> start 0) | |
241 | (setq str (substring str start)) | |
242 | (setq len (- len start)))) | |
243 | ;; make sure size is not larger than Emacs can handle | |
244 | (when (or (> len (min 4 erc-most-positive-int-bytes)) | |
245 | (and (eq len erc-most-positive-int-bytes) | |
246 | (> (aref str 0) erc-most-positive-int-msb))) | |
247 | (error "ERC-DCC (erc-unpack-int): packet to send is too large")) | |
248 | ;; unpack | |
249 | (let ((num 0) | |
250 | (count 0)) | |
251 | (while (< count len) | |
252 | (setq num (+ num (lsh (aref str (- len count 1)) (* 8 count)))) | |
253 | (setq count (1+ count))) | |
254 | num))) | |
597993cf MB |
255 | |
256 | (defconst erc-dcc-ipv4-regexp | |
257 | (concat "^" | |
258 | (mapconcat #'identity (make-list 4 "\\([0-9]\\{1,3\\}\\)") "\\.") | |
259 | "$")) | |
260 | ||
261 | (defun erc-ip-to-decimal (ip) | |
262 | "Convert IP address to its decimal representation. | |
263 | Argument IP is the address as a string. The result is also a string." | |
264 | (interactive "sIP Address: ") | |
265 | (if (not (string-match erc-dcc-ipv4-regexp ip)) | |
266 | (error "Not an IP address") | |
267 | (let* ((ips (mapcar | |
268 | (lambda (str) | |
269 | (let ((n (string-to-number str))) | |
270 | (if (and (>= n 0) (< n 256)) | |
271 | n | |
272 | (error "%d out of range" n)))) | |
273 | (split-string ip "\\."))) | |
274 | (res (+ (* (car ips) 16777216.0) | |
275 | (* (nth 1 ips) 65536.0) | |
276 | (* (nth 2 ips) 256.0) | |
277 | (nth 3 ips)))) | |
19dc7206 | 278 | (if (called-interactively-p 'interactive) |
597993cf MB |
279 | (message "%s is %.0f" ip res) |
280 | (format "%.0f" res))))) | |
281 | ||
282 | (defun erc-decimal-to-ip (dec) | |
283 | "Convert a decimal representation DEC to an IP address. | |
284 | The result is also a string." | |
285 | (when (stringp dec) | |
286 | (setq dec (string-to-number (concat dec ".0")))) | |
287 | (let* ((first (floor (/ dec 16777216.0))) | |
288 | (first-rest (- dec (* first 16777216.0))) | |
289 | (second (floor (/ first-rest 65536.0))) | |
290 | (second-rest (- first-rest (* second 65536.0))) | |
291 | (third (floor (/ second-rest 256.0))) | |
292 | (third-rest (- second-rest (* third 256.0))) | |
293 | (fourth (floor third-rest))) | |
294 | (format "%s.%s.%s.%s" first second third fourth))) | |
295 | ||
296 | ;;; Server code | |
297 | ||
5e56b3fb MO |
298 | (defcustom erc-dcc-listen-host nil |
299 | "IP address to listen on when offering files. | |
300 | Should be set to a string or nil. If nil, automatic detection of | |
301 | the host interface to use will be attempted." | |
597993cf MB |
302 | :group 'erc-dcc |
303 | :type (list 'choice (list 'const :tag "Auto-detect" nil) | |
304 | (list 'string :tag "IP-address" | |
305 | :valid-regexp erc-dcc-ipv4-regexp))) | |
306 | ||
5e56b3fb MO |
307 | (defcustom erc-dcc-public-host nil |
308 | "IP address to use for outgoing DCC offers. | |
309 | Should be set to a string or nil. If nil, use the value of | |
310 | `erc-dcc-listen-host'." | |
311 | :group 'erc-dcc | |
312 | :type (list 'choice (list 'const :tag "Same as erc-dcc-listen-host" nil) | |
313 | (list 'string :tag "IP-address" | |
314 | :valid-regexp erc-dcc-ipv4-regexp))) | |
315 | ||
597993cf | 316 | (defcustom erc-dcc-send-request 'ask |
fb7ada5f | 317 | "How to treat incoming DCC Send requests. |
597993cf MB |
318 | 'ask - Report the Send request, and wait for the user to manually accept it |
319 | You might want to set `erc-dcc-auto-masks' for this. | |
320 | 'auto - Automatically accept the request and begin downloading the file | |
321 | 'ignore - Ignore incoming DCC Send requests completely." | |
322 | :group 'erc-dcc | |
323 | :type '(choice (const ask) (const auto) (const ignore))) | |
324 | ||
325 | (defun erc-dcc-get-host (proc) | |
326 | "Returns the local IP address used for an open PROCess." | |
327 | (format-network-address (process-contact proc :local) t)) | |
328 | ||
329 | (defun erc-dcc-host () | |
330 | "Determine the IP address we are using. | |
331 | If variable `erc-dcc-host' is non-nil, use it. Otherwise call | |
332 | `erc-dcc-get-host' on the erc-server-process." | |
5e56b3fb | 333 | (or erc-dcc-listen-host (erc-dcc-get-host erc-server-process) |
597993cf MB |
334 | (error "Unable to determine local address"))) |
335 | ||
336 | (defcustom erc-dcc-port-range nil | |
337 | "If nil, any available user port is used for outgoing DCC connections. | |
338 | If set to a cons, it specifies a range of ports to use in the form (min . max)" | |
339 | :group 'erc-dcc | |
340 | :type '(choice | |
341 | (const :tag "Any port" nil) | |
342 | (cons :tag "Port range" | |
343 | (integer :tag "Lower port") | |
344 | (integer :tag "Upper port")))) | |
345 | ||
346 | (defcustom erc-dcc-auto-masks nil | |
347 | "List of regexps matching user identifiers whose DCC send offers should be | |
348 | accepted automatically. A user identifier has the form \"nick!login@host\". | |
349 | For instance, to accept all incoming DCC send offers automatically, add the | |
350 | string \".*!.*@.*\" to this list." | |
351 | :group 'erc-dcc | |
352 | :type '(repeat regexp)) | |
353 | ||
354 | (defun erc-dcc-server (name filter sentinel) | |
355 | "Start listening on a port for an incoming DCC connection. Returns the newly | |
356 | created subprocess, or nil." | |
357 | (let ((port (or (and erc-dcc-port-range (car erc-dcc-port-range)) t)) | |
358 | (upper (and erc-dcc-port-range (cdr erc-dcc-port-range))) | |
359 | process) | |
360 | (while (not process) | |
361 | (condition-case err | |
5e56b3fb | 362 | (progn |
597993cf MB |
363 | (setq process |
364 | (make-network-process :name name | |
365 | :buffer nil | |
366 | :host (erc-dcc-host) | |
367 | :service port | |
368 | :nowait t | |
369 | :noquery nil | |
370 | :filter filter | |
371 | :sentinel sentinel | |
372 | :log #'erc-dcc-server-accept | |
373 | :server t)) | |
5e56b3fb MO |
374 | (when (processp process) |
375 | (when (fboundp 'set-process-coding-system) | |
376 | (set-process-coding-system process 'binary 'binary)) | |
377 | (when (fboundp 'set-process-filter-multibyte) | |
7d8345da GM |
378 | (with-no-warnings ; obsolete since 23.1 |
379 | (set-process-filter-multibyte process nil))))) | |
597993cf | 380 | (file-error |
19dc7206 SM |
381 | (unless (and (string= "Cannot bind server socket" (nth 1 err)) |
382 | (string= "address already in use" (nth 2 err))) | |
597993cf MB |
383 | (signal (car err) (cdr err))) |
384 | (setq port (1+ port)) | |
385 | (unless (< port upper) | |
386 | (error "No available ports in erc-dcc-port-range"))))) | |
387 | process)) | |
388 | ||
389 | (defun erc-dcc-server-accept (server client message) | |
390 | "Log an accepted DCC offer, then terminate the listening process and set up | |
391 | the accepted connection." | |
392 | (erc-log (format "(erc-dcc-server-accept): server %s client %s message %s" | |
393 | server client message)) | |
394 | (when (and (string-match "^accept from " message) | |
395 | (processp server) (processp client)) | |
396 | (let ((elt (erc-dcc-member :peer server))) | |
397 | ;; change the entry in erc-dcc-list from the listening process to the | |
398 | ;; accepted process | |
399 | (setq elt (plist-put elt :peer client)) | |
400 | ;; delete the listening process, as we've accepted the connection | |
401 | (delete-process server)))) | |
402 | ||
403 | ;;; Interactive command handling | |
404 | ||
405 | (defcustom erc-dcc-get-default-directory nil | |
fb7ada5f | 406 | "Default directory for incoming DCC file transfers. |
597993cf MB |
407 | If this is nil, then the current value of `default-directory' is used." |
408 | :group 'erc-dcc | |
409 | :type '(choice (const nil :tag "Default directory") directory)) | |
410 | ||
411 | ;;;###autoload | |
412 | (defun erc-cmd-DCC (cmd &rest args) | |
413 | "Parser for /dcc command. | |
414 | This figures out the dcc subcommand and calls the appropriate routine to | |
415 | handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\", | |
416 | where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." | |
417 | (when cmd | |
418 | (let ((fn (intern-soft (concat "erc-dcc-do-" (upcase cmd) "-command")))) | |
419 | (if fn | |
420 | (apply fn erc-server-process args) | |
421 | (erc-display-message | |
422 | nil 'notice 'active | |
423 | 'dcc-command-undefined ?c cmd) | |
424 | (apropos "erc-dcc-do-.*-command") | |
425 | t)))) | |
426 | ||
595521d7 GM |
427 | (autoload 'pcomplete-erc-all-nicks "erc-pcomplete") |
428 | ||
597993cf MB |
429 | ;;;###autoload |
430 | (defun pcomplete/erc-mode/DCC () | |
431 | "Provides completion for the /DCC command." | |
432 | (pcomplete-here (append '("chat" "close" "get" "list") | |
433 | (when (fboundp 'make-network-process) '("send")))) | |
434 | (pcomplete-here | |
19dc7206 SM |
435 | (pcase (intern (downcase (pcomplete-arg 1))) |
436 | (`chat (mapcar (lambda (elt) (plist-get elt :nick)) | |
437 | (erc-remove-if-not | |
438 | #'(lambda (elt) | |
439 | (eq (plist-get elt :type) 'CHAT)) | |
440 | erc-dcc-list))) | |
441 | (`close (erc-delete-dups | |
442 | (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) | |
443 | erc-dcc-list))) | |
444 | (`get (mapcar #'erc-dcc-nick | |
597993cf MB |
445 | (erc-remove-if-not |
446 | #'(lambda (elt) | |
19dc7206 | 447 | (eq (plist-get elt :type) 'GET)) |
597993cf | 448 | erc-dcc-list))) |
19dc7206 | 449 | (`send (pcomplete-erc-all-nicks)))) |
597993cf | 450 | (pcomplete-here |
19dc7206 SM |
451 | (pcase (intern (downcase (pcomplete-arg 2))) |
452 | (`get (mapcar (lambda (elt) (plist-get elt :file)) | |
453 | (erc-remove-if-not | |
454 | #'(lambda (elt) | |
455 | (and (eq (plist-get elt :type) 'GET) | |
456 | (erc-nick-equal-p (erc-extract-nick | |
457 | (plist-get elt :nick)) | |
458 | (pcomplete-arg 1)))) | |
459 | erc-dcc-list))) | |
460 | (`close (mapcar #'erc-dcc-nick | |
461 | (erc-remove-if-not | |
462 | #'(lambda (elt) | |
463 | (eq (plist-get elt :type) | |
464 | (intern (upcase (pcomplete-arg 1))))) | |
465 | erc-dcc-list))) | |
466 | (`send (pcomplete-entries))))) | |
597993cf MB |
467 | |
468 | (defun erc-dcc-do-CHAT-command (proc &optional nick) | |
469 | (when nick | |
470 | (let ((elt (erc-dcc-member :nick nick :type 'CHAT :parent proc))) | |
471 | (if (and elt (not (processp (plist-get elt :peer)))) | |
472 | ;; accept an existing chat offer | |
473 | ;; FIXME: perhaps /dcc accept like other clients? | |
474 | (progn (erc-dcc-chat-accept elt erc-server-process) | |
475 | (erc-display-message | |
476 | nil 'notice 'active | |
477 | 'dcc-chat-accept ?n nick) | |
478 | t) | |
479 | (erc-dcc-chat nick erc-server-process) | |
480 | (erc-display-message | |
481 | nil 'notice 'active | |
482 | 'dcc-chat-offer ?n nick) | |
483 | t)))) | |
484 | ||
485 | (defun erc-dcc-do-CLOSE-command (proc &optional type nick) | |
1c86baa4 MO |
486 | "Close a connection. Usage: /dcc close type nick. |
487 | At least one of TYPE and NICK must be provided." | |
488 | ;; disambiguate type and nick if only one is provided | |
489 | (when (and type (null nick) | |
490 | (not (member (upcase type) erc-dcc-connection-types))) | |
491 | (setq nick type) | |
492 | (setq type nil)) | |
493 | ;; validate nick argument | |
494 | (unless (and nick (string-match (concat "\\`" erc-valid-nick-regexp "\\'") | |
495 | nick)) | |
496 | (setq nick nil)) | |
497 | ;; validate type argument | |
498 | (if (and type (member (upcase type) erc-dcc-connection-types)) | |
499 | (setq type (intern (upcase type))) | |
500 | (setq type nil)) | |
501 | (when (or nick type) | |
502 | (let ((ret t)) | |
597993cf | 503 | (while ret |
1c86baa4 MO |
504 | (cond ((and nick type) |
505 | (setq ret (erc-dcc-member :type type :nick nick))) | |
506 | (nick | |
507 | (setq ret (erc-dcc-member :nick nick))) | |
508 | (type | |
509 | (setq ret (erc-dcc-member :type type))) | |
510 | (t | |
511 | (setq ret nil))) | |
597993cf MB |
512 | (when ret |
513 | ;; found a match - delete process if it exists. | |
514 | (and (processp (plist-get ret :peer)) | |
515 | (delete-process (plist-get ret :peer))) | |
516 | (setq erc-dcc-list (delq ret erc-dcc-list)) | |
517 | (erc-display-message | |
518 | nil 'notice 'active | |
519 | 'dcc-closed | |
520 | ?T (plist-get ret :type) | |
521 | ?n (erc-extract-nick (plist-get ret :nick)))))) | |
1c86baa4 | 522 | t)) |
597993cf | 523 | |
2a927019 MO |
524 | (defun erc-dcc-do-GET-command (proc nick &rest file) |
525 | "Do a DCC GET command. NICK is the person who is sending the file. | |
526 | FILE is the filename. If FILE is split into multiple arguments, | |
527 | re-join the arguments, separated by a space. | |
528 | PROC is the server process." | |
529 | (setq file (and file (mapconcat #'identity file " "))) | |
597993cf MB |
530 | (let* ((elt (erc-dcc-member :nick nick :type 'GET)) |
531 | (filename (or file (plist-get elt :file) "unknown"))) | |
532 | (if elt | |
533 | (let* ((file (read-file-name | |
534 | (format "Local filename (default %s): " | |
535 | (file-name-nondirectory filename)) | |
536 | (or erc-dcc-get-default-directory | |
537 | default-directory) | |
538 | (expand-file-name (file-name-nondirectory filename) | |
539 | (or erc-dcc-get-default-directory | |
540 | default-directory))))) | |
541 | (cond ((file-exists-p file) | |
542 | (if (yes-or-no-p (format "File %s exists. Overwrite? " | |
543 | file)) | |
544 | (erc-dcc-get-file elt file proc) | |
545 | (erc-display-message | |
546 | nil '(notice error) proc | |
547 | 'dcc-get-cmd-aborted | |
548 | ?n nick ?f filename))) | |
549 | (t | |
550 | (erc-dcc-get-file elt file proc)))) | |
551 | (erc-display-message | |
552 | nil '(notice error) 'active | |
553 | 'dcc-get-notfound ?n nick ?f filename)))) | |
554 | ||
1c86baa4 MO |
555 | (defvar erc-dcc-byte-count nil) |
556 | (make-variable-buffer-local 'erc-dcc-byte-count) | |
557 | ||
597993cf MB |
558 | (defun erc-dcc-do-LIST-command (proc) |
559 | "This is the handler for the /dcc list command. | |
560 | It lists the current state of `erc-dcc-list' in an easy to read manner." | |
561 | (let ((alist erc-dcc-list) | |
562 | size elt) | |
563 | (erc-display-message | |
564 | nil 'notice 'active | |
565 | 'dcc-list-head) | |
566 | (erc-display-message | |
567 | nil 'notice 'active | |
568 | 'dcc-list-line) | |
569 | (while alist | |
570 | (setq elt (car alist) | |
571 | alist (cdr alist)) | |
572 | ||
573 | (setq size (or (and (plist-member elt :size) | |
574 | (plist-get elt :size)) | |
575 | "")) | |
576 | (setq size | |
577 | (cond ((null size) "") | |
578 | ((numberp size) (number-to-string size)) | |
579 | ((string= size "") "unknown"))) | |
580 | (erc-display-message | |
581 | nil 'notice 'active | |
582 | 'dcc-list-item | |
583 | ?n (erc-dcc-nick elt) | |
584 | ?t (plist-get elt :type) | |
585 | ?a (if (processp (plist-get elt :peer)) | |
586 | (process-status (plist-get elt :peer)) | |
587 | "no") | |
588 | ?s (concat size | |
589 | (if (and (eq 'GET (plist-get elt :type)) | |
590 | (plist-member elt :file) | |
591 | (buffer-live-p (get-buffer (plist-get elt :file))) | |
592 | (plist-member elt :size)) | |
1c86baa4 MO |
593 | (let ((byte-count (with-current-buffer |
594 | (get-buffer (plist-get elt :file)) | |
595 | (+ (buffer-size) 0.0 | |
596 | erc-dcc-byte-count)))) | |
597 | (concat " (" | |
598 | (if (= byte-count 0) | |
599 | "0" | |
600 | (number-to-string | |
601 | (truncate | |
597993cf | 602 | (* 100 |
1c86baa4 MO |
603 | (/ byte-count (plist-get elt :size)))))) |
604 | "%)")))) | |
597993cf MB |
605 | ?f (or (and (plist-member elt :file) (plist-get elt :file)) ""))) |
606 | (erc-display-message | |
607 | nil 'notice 'active | |
608 | 'dcc-list-end) | |
609 | t)) | |
610 | ||
2a927019 MO |
611 | (defun erc-dcc-do-SEND-command (proc nick &rest file) |
612 | "Offer FILE to NICK by sending a ctcp dcc send message. | |
613 | If FILE is split into multiple arguments, re-join the arguments, | |
614 | separated by a space." | |
615 | (setq file (and file (mapconcat #'identity file " "))) | |
597993cf MB |
616 | (if (file-exists-p file) |
617 | (progn | |
618 | (erc-display-message | |
619 | nil 'notice 'active | |
620 | 'dcc-send-offer ?n nick ?f file) | |
621 | (erc-dcc-send-file nick file) t) | |
622 | (erc-display-message nil '(notice error) proc "File not found") t)) | |
623 | ||
624 | ;;; Server message handling (i.e. messages from remote users) | |
625 | ||
626 | ;;;###autoload | |
627 | (defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC) | |
f1a4e679 | 628 | "Hook variable for CTCP DCC queries.") |
597993cf MB |
629 | |
630 | (defvar erc-dcc-query-handler-alist | |
631 | '(("SEND" . erc-dcc-handle-ctcp-send) | |
632 | ("CHAT" . erc-dcc-handle-ctcp-chat))) | |
633 | ||
634 | ;;;###autoload | |
635 | (defun erc-ctcp-query-DCC (proc nick login host to query) | |
636 | "The function called when a CTCP DCC request is detected by the client. | |
637 | It examines the DCC subcommand, and calls the appropriate routine for | |
638 | that subcommand." | |
639 | (let* ((cmd (cadr (split-string query " "))) | |
640 | (handler (cdr (assoc cmd erc-dcc-query-handler-alist)))) | |
641 | (if handler | |
642 | (funcall handler proc query nick login host to) | |
643 | ;; FIXME: Send a ctcp error notice to the remote end? | |
644 | (erc-display-message | |
645 | nil '(notice error) proc | |
646 | 'dcc-ctcp-unknown | |
647 | ?q query ?n nick ?u login ?h host)))) | |
648 | ||
649 | (defconst erc-dcc-ctcp-query-send-regexp | |
3c2727e8 JD |
650 | (concat "^DCC SEND \\(" |
651 | ;; Following part matches either filename without spaces | |
652 | ;; or filename enclosed in double quotes with any number | |
653 | ;; of escaped double quotes inside. | |
654 | "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)" | |
655 | "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) | |
656 | ||
657 | (defsubst erc-dcc-unquote-filename (filename) | |
658 | (erc-replace-regexp-in-string "\\\\\\\\" "\\" | |
659 | (erc-replace-regexp-in-string "\\\\\"" "\"" filename t t) t t)) | |
597993cf MB |
660 | |
661 | (defun erc-dcc-handle-ctcp-send (proc query nick login host to) | |
662 | "This is called if a CTCP DCC SEND subcommand is sent to the client. | |
663 | It extracts the information about the dcc request and adds it to | |
664 | `erc-dcc-list'." | |
665 | (unless (eq erc-dcc-send-request 'ignore) | |
666 | (cond | |
667 | ((not (erc-current-nick-p to)) | |
668 | ;; DCC SEND requests must be sent to you, and you alone. | |
669 | (erc-display-message | |
670 | nil 'notice proc | |
671 | 'dcc-request-bogus | |
672 | ?r "SEND" ?n nick ?u login ?h host)) | |
673 | ((string-match erc-dcc-ctcp-query-send-regexp query) | |
3c2727e8 | 674 | (let ((filename |
d3722480 | 675 | (or (match-string 5 query) |
3c2727e8 JD |
676 | (erc-dcc-unquote-filename (match-string 2 query)))) |
677 | (ip (erc-decimal-to-ip (match-string 6 query))) | |
678 | (port (match-string 7 query)) | |
679 | (size (match-string 8 query))) | |
597993cf MB |
680 | ;; FIXME: a warning really should also be sent |
681 | ;; if the ip address != the host the dcc sender is on. | |
682 | (erc-display-message | |
683 | nil 'notice proc | |
684 | 'dcc-send-offered | |
685 | ?f filename ?n nick ?u login ?h host | |
686 | ?s (if (string= size "") "unknown" size)) | |
687 | (and (< (string-to-number port) 1025) | |
688 | (erc-display-message | |
689 | nil 'notice proc | |
690 | 'dcc-privileged-port | |
691 | ?p port)) | |
692 | (erc-dcc-list-add | |
693 | 'GET (format "%s!%s@%s" nick login host) | |
694 | nil proc | |
695 | :ip ip :port port :file filename | |
696 | :size (string-to-number size)) | |
697 | (if (and (eq erc-dcc-send-request 'auto) | |
698 | (erc-dcc-auto-mask-p (format "\"%s!%s@%s\"" nick login host))) | |
699 | (erc-dcc-get-file (car erc-dcc-list) filename proc)))) | |
700 | (t | |
701 | (erc-display-message | |
702 | nil 'notice proc | |
703 | 'dcc-malformed | |
704 | ?n nick ?u login ?h host ?q query))))) | |
705 | ||
706 | (defun erc-dcc-auto-mask-p (spec) | |
707 | "Takes a full SPEC of a user in the form \"nick!login@host\" and | |
708 | matches against all the regexp's in `erc-dcc-auto-masks'. If any | |
709 | match, returns that regexp and nil otherwise." | |
710 | (let ((lst erc-dcc-auto-masks)) | |
711 | (while (and lst | |
712 | (not (string-match (car lst) spec))) | |
713 | (setq lst (cdr lst))) | |
714 | (and lst (car lst)))) | |
715 | ||
716 | (defconst erc-dcc-ctcp-query-chat-regexp | |
717 | "^DCC CHAT +chat +\\([0-9]+\\) +\\([0-9]+\\)") | |
718 | ||
719 | (defcustom erc-dcc-chat-request 'ask | |
fb7ada5f | 720 | "How to treat incoming DCC Chat requests. |
597993cf MB |
721 | 'ask - Report the Chat request, and wait for the user to manually accept it |
722 | 'auto - Automatically accept the request and open a new chat window | |
723 | 'ignore - Ignore incoming DCC chat requests completely." | |
724 | :group 'erc-dcc | |
725 | :type '(choice (const ask) (const auto) (const ignore))) | |
726 | ||
727 | (defun erc-dcc-handle-ctcp-chat (proc query nick login host to) | |
728 | (unless (eq erc-dcc-chat-request 'ignore) | |
729 | (cond | |
730 | (;; DCC CHAT requests must be sent to you, and you alone. | |
731 | (not (erc-current-nick-p to)) | |
732 | (erc-display-message | |
733 | nil '(notice error) proc | |
734 | 'dcc-request-bogus ?r "CHAT" ?n nick ?u login ?h host)) | |
735 | ((string-match erc-dcc-ctcp-query-chat-regexp query) | |
736 | ;; We need to use let* here, since erc-dcc-member might clutter | |
737 | ;; the match value. | |
738 | (let* ((ip (erc-decimal-to-ip (match-string 1 query))) | |
739 | (port (match-string 2 query)) | |
740 | (elt (erc-dcc-member :nick nick :type 'CHAT))) | |
741 | ;; FIXME: A warning really should also be sent if the ip | |
742 | ;; address != the host the dcc sender is on. | |
743 | (erc-display-message | |
744 | nil 'notice proc | |
745 | 'dcc-chat-offered | |
746 | ?n nick ?u login ?h host ?p port) | |
747 | (and (< (string-to-number port) 1025) | |
748 | (erc-display-message | |
749 | nil 'notice proc | |
750 | 'dcc-privileged-port ?p port)) | |
751 | (cond (elt | |
752 | ;; XXX: why are we updating ip/port on the existing connection? | |
753 | (setq elt (plist-put (plist-put elt :port port) :ip ip)) | |
754 | (erc-display-message | |
755 | nil 'notice proc | |
756 | 'dcc-chat-discarded ?n nick ?u login ?h host)) | |
757 | (t | |
758 | (erc-dcc-list-add | |
759 | 'CHAT (format "%s!%s@%s" nick login host) | |
760 | nil proc | |
761 | :ip ip :port port))) | |
762 | (if (eq erc-dcc-chat-request 'auto) | |
763 | (erc-dcc-chat-accept (erc-dcc-member :nick nick :type 'CHAT) | |
764 | proc)))) | |
765 | (t | |
766 | (erc-display-message | |
767 | nil '(notice error) proc | |
768 | 'dcc-malformed ?n nick ?u login ?h host ?q query))))) | |
769 | ||
770 | ||
771 | (defvar erc-dcc-entry-data nil | |
772 | "Holds the `erc-dcc-list' entry for this DCC connection.") | |
773 | (make-variable-buffer-local 'erc-dcc-entry-data) | |
774 | ||
775 | ;;; SEND handling | |
776 | ||
777 | (defcustom erc-dcc-block-size 1024 | |
fb7ada5f | 778 | "Block size to use for DCC SEND sessions." |
597993cf MB |
779 | :group 'erc-dcc |
780 | :type 'integer) | |
781 | ||
782 | (defcustom erc-dcc-pump-bytes nil | |
fb7ada5f | 783 | "If set to an integer, keep sending until that number of bytes are |
597993cf MB |
784 | unconfirmed." |
785 | :group 'erc-dcc | |
786 | :type '(choice (const nil) integer)) | |
787 | ||
788 | (defsubst erc-dcc-get-parent (proc) | |
789 | (plist-get (erc-dcc-member :peer proc) :parent)) | |
790 | ||
791 | (defun erc-dcc-send-block (proc) | |
792 | "Send one block of data. | |
793 | PROC is the process-object of the DCC connection. Returns the number of | |
794 | bytes sent." | |
795 | (let* ((elt (erc-dcc-member :peer proc)) | |
796 | (confirmed-marker (plist-get elt :sent)) | |
797 | (sent-marker (plist-get elt :sent))) | |
798 | (with-current-buffer (process-buffer proc) | |
5e56b3fb | 799 | (when erc-dcc-verbose |
597993cf MB |
800 | (erc-display-message |
801 | nil 'notice (erc-dcc-get-parent proc) | |
802 | (format "DCC: Confirmed %d, sent %d, sending block now" | |
803 | (- confirmed-marker (point-min)) | |
804 | (- sent-marker (point-min))))) | |
805 | (let* ((end (min (+ sent-marker erc-dcc-block-size) | |
806 | (point-max))) | |
807 | (string (buffer-substring-no-properties sent-marker end))) | |
808 | (when (< sent-marker end) | |
809 | (set-marker sent-marker end) | |
810 | (process-send-string proc string)) | |
811 | (length string))))) | |
812 | ||
813 | (defun erc-dcc-send-filter (proc string) | |
5e56b3fb | 814 | (let* ((size (erc-unpack-int string)) |
597993cf MB |
815 | (elt (erc-dcc-member :peer proc)) |
816 | (parent (plist-get elt :parent)) | |
817 | (sent-marker (plist-get elt :sent)) | |
818 | (confirmed-marker (plist-get elt :confirmed))) | |
819 | (with-current-buffer (process-buffer proc) | |
820 | (set-marker confirmed-marker (+ (point-min) size)) | |
821 | (cond | |
822 | ((and (= confirmed-marker sent-marker) | |
823 | (= confirmed-marker (point-max))) | |
824 | (erc-display-message | |
825 | nil 'notice parent | |
826 | 'dcc-send-finished | |
827 | ?n (plist-get elt :nick) | |
828 | ?f buffer-file-name | |
829 | ?s (number-to-string (- sent-marker (point-min)))) | |
830 | (setq erc-dcc-list (delete elt erc-dcc-list)) | |
831 | (set-buffer-modified-p nil) | |
832 | (kill-buffer (current-buffer)) | |
833 | (delete-process proc)) | |
834 | ((<= confirmed-marker sent-marker) | |
835 | (while (and (< (- sent-marker confirmed-marker) | |
836 | (or erc-dcc-pump-bytes | |
837 | erc-dcc-block-size)) | |
838 | (> (erc-dcc-send-block proc) 0)))) | |
839 | ((> confirmed-marker sent-marker) | |
840 | (erc-display-message | |
841 | nil 'notice parent | |
5e56b3fb MO |
842 | (format "DCC: Client confirmed too much (%s vs %s)!" |
843 | (marker-position confirmed-marker) | |
844 | (marker-position sent-marker))) | |
845 | (set-buffer-modified-p nil) | |
846 | (kill-buffer (current-buffer)) | |
597993cf MB |
847 | (delete-process proc)))))) |
848 | ||
5e56b3fb MO |
849 | (defun erc-dcc-display-send (proc) |
850 | (erc-display-message | |
851 | nil 'notice (erc-dcc-get-parent proc) | |
852 | (format "DCC: SEND connect from %s" | |
853 | (format-network-address (process-contact proc :remote))))) | |
854 | ||
597993cf | 855 | (defcustom erc-dcc-send-connect-hook |
5e56b3fb | 856 | '(erc-dcc-display-send erc-dcc-send-block) |
fb7ada5f | 857 | "Hook run whenever the remote end of a DCC SEND offer connected to your |
597993cf MB |
858 | listening port." |
859 | :group 'erc-dcc | |
860 | :type 'hook) | |
861 | ||
862 | (defun erc-dcc-nick (plist) | |
863 | "Extract the nickname portion of the :nick property value in PLIST." | |
864 | (erc-extract-nick (plist-get plist :nick))) | |
865 | ||
866 | (defun erc-dcc-send-sentinel (proc event) | |
5e56b3fb | 867 | (let* ((elt (erc-dcc-member :peer proc))) |
597993cf MB |
868 | (cond |
869 | ((string-match "^open from " event) | |
870 | (when elt | |
5e56b3fb MO |
871 | (let ((buf (marker-buffer (plist-get elt :sent)))) |
872 | (with-current-buffer buf | |
873 | (set-process-buffer proc buf) | |
874 | (setq erc-dcc-entry-data elt))) | |
597993cf MB |
875 | (run-hook-with-args 'erc-dcc-send-connect-hook proc)))))) |
876 | ||
877 | (defun erc-dcc-find-file (file) | |
878 | (with-current-buffer (generate-new-buffer (file-name-nondirectory file)) | |
879 | (insert-file-contents-literally file) | |
880 | (setq buffer-file-name file) | |
881 | (current-buffer))) | |
882 | ||
883 | (defun erc-dcc-file-to-name (file) | |
884 | (with-temp-buffer | |
885 | (insert (file-name-nondirectory file)) | |
886 | (subst-char-in-region (point-min) (point-max) ? ?_ t) | |
887 | (buffer-string))) | |
888 | ||
889 | (defun erc-dcc-send-file (nick file &optional pproc) | |
890 | "Open a socket for incoming connections, and send a CTCP send request to the | |
891 | other client." | |
892 | (interactive "sNick: \nfFile: ") | |
893 | (when (null pproc) (if (processp erc-server-process) | |
894 | (setq pproc erc-server-process) | |
895 | (error "Can not find parent process"))) | |
896 | (if (featurep 'make-network-process) | |
897 | (let* ((buffer (erc-dcc-find-file file)) | |
898 | (size (buffer-size buffer)) | |
899 | (start (with-current-buffer buffer | |
30818a23 | 900 | (point-min-marker))) |
597993cf MB |
901 | (sproc (erc-dcc-server "dcc-send" |
902 | 'erc-dcc-send-filter | |
903 | 'erc-dcc-send-sentinel)) | |
904 | (contact (process-contact sproc))) | |
905 | (erc-dcc-list-add | |
906 | 'SEND nick sproc pproc | |
907 | :file file :size size | |
908 | :sent start :confirmed (copy-marker start)) | |
909 | (process-send-string | |
910 | pproc (format "PRIVMSG %s :\C-aDCC SEND %s %s %d %d\C-a\n" | |
911 | nick (erc-dcc-file-to-name file) | |
5e56b3fb MO |
912 | (erc-ip-to-decimal (or erc-dcc-public-host |
913 | (nth 0 contact))) | |
597993cf MB |
914 | (nth 1 contact) |
915 | size))) | |
c6e43135 | 916 | (error "`make-network-process' not supported by your Emacs"))) |
597993cf MB |
917 | |
918 | ;;; GET handling | |
919 | ||
5e56b3fb MO |
920 | (defcustom erc-dcc-receive-cache (* 1024 512) |
921 | "Number of bytes to let the receive buffer grow before flushing it." | |
922 | :group 'erc-dcc | |
923 | :type 'integer) | |
924 | ||
5e56b3fb MO |
925 | (defvar erc-dcc-file-name nil) |
926 | (make-variable-buffer-local 'erc-dcc-file-name) | |
597993cf MB |
927 | |
928 | (defun erc-dcc-get-file (entry file parent-proc) | |
929 | "This function does the work of setting up a transfer from the remote client | |
930 | to the local one over a tcp connection. This involves setting up a process | |
931 | filter and a process sentinel, and making the connection." | |
932 | (let* ((buffer (generate-new-buffer (file-name-nondirectory file))) | |
933 | proc) | |
934 | (with-current-buffer buffer | |
935 | (fundamental-mode) | |
5e56b3fb | 936 | (buffer-disable-undo (current-buffer)) |
597993cf MB |
937 | ;; This is necessary to have the buffer saved as-is in GNU |
938 | ;; Emacs. | |
939 | ;; XEmacs change: We don't have `set-buffer-multibyte', setting | |
940 | ;; coding system to 'binary below takes care of us. | |
941 | (when (fboundp 'set-buffer-multibyte) | |
942 | (set-buffer-multibyte nil)) | |
943 | ||
944 | (setq mode-line-process '(":%s") | |
597993cf | 945 | buffer-read-only t) |
5e56b3fb MO |
946 | (setq erc-dcc-file-name file) |
947 | ||
948 | ;; Truncate the given file to size 0 before appending to it. | |
1c86baa4 MO |
949 | (let ((inhibit-file-name-handlers |
950 | (append '(jka-compr-handler image-file-handler) | |
951 | inhibit-file-name-handlers)) | |
952 | (inhibit-file-name-operation 'write-region)) | |
953 | (write-region (point) (point) erc-dcc-file-name nil 'nomessage)) | |
597993cf MB |
954 | |
955 | (setq erc-server-process parent-proc | |
956 | erc-dcc-entry-data entry) | |
957 | (setq erc-dcc-byte-count 0) | |
958 | (setq proc | |
959 | (funcall erc-dcc-connect-function | |
960 | "dcc-get" buffer | |
961 | (plist-get entry :ip) | |
962 | (string-to-number (plist-get entry :port)) | |
963 | entry)) | |
964 | (set-process-buffer proc buffer) | |
597993cf MB |
965 | (set-process-coding-system proc 'binary 'binary) |
966 | (set-buffer-file-coding-system 'binary t) | |
967 | ||
968 | (set-process-filter proc 'erc-dcc-get-filter) | |
969 | (set-process-sentinel proc 'erc-dcc-get-sentinel) | |
970 | (setq entry (plist-put entry :start-time (erc-current-time))) | |
971 | (setq entry (plist-put entry :peer proc))))) | |
972 | ||
5e56b3fb MO |
973 | (defun erc-dcc-append-contents (buffer file) |
974 | "Append the contents of BUFFER to FILE. | |
975 | The contents of the BUFFER will then be erased." | |
976 | (with-current-buffer buffer | |
1c86baa4 MO |
977 | (let ((coding-system-for-write 'binary) |
978 | (inhibit-read-only t) | |
979 | (inhibit-file-name-handlers | |
980 | (append '(jka-compr-handler image-file-handler) | |
981 | inhibit-file-name-handlers)) | |
982 | (inhibit-file-name-operation 'write-region)) | |
5e56b3fb | 983 | (write-region (point-min) (point-max) erc-dcc-file-name t 'nomessage) |
1c86baa4 | 984 | (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count)) |
5e56b3fb MO |
985 | (erase-buffer)))) |
986 | ||
597993cf MB |
987 | (defun erc-dcc-get-filter (proc str) |
988 | "This is the process filter for transfers from other clients to this one. | |
989 | It reads incoming bytes from the network and stores them in the DCC | |
990 | buffer, and sends back the replies after each block of data per the DCC | |
991 | protocol spec. Well not really. We write back a reply after each read, | |
992 | rather than every 1024 byte block, but nobody seems to care." | |
993 | (with-current-buffer (process-buffer proc) | |
1c86baa4 MO |
994 | (let ((inhibit-read-only t) |
995 | received-bytes) | |
6904f7fe MB |
996 | (goto-char (point-max)) |
997 | (insert (string-make-unibyte str)) | |
998 | ||
5e56b3fb MO |
999 | (when (> (point-max) erc-dcc-receive-cache) |
1000 | (erc-dcc-append-contents (current-buffer) erc-dcc-file-name)) | |
1c86baa4 | 1001 | (setq received-bytes (+ (buffer-size) erc-dcc-byte-count)) |
5e56b3fb MO |
1002 | |
1003 | (and erc-dcc-verbose | |
6904f7fe MB |
1004 | (erc-display-message |
1005 | nil 'notice erc-server-process | |
1006 | 'dcc-get-bytes-received | |
1007 | ?f (file-name-nondirectory buffer-file-name) | |
1c86baa4 | 1008 | ?b (number-to-string received-bytes))) |
6904f7fe MB |
1009 | (cond |
1010 | ((and (> (plist-get erc-dcc-entry-data :size) 0) | |
1c86baa4 | 1011 | (> received-bytes (plist-get erc-dcc-entry-data :size))) |
6904f7fe MB |
1012 | (erc-display-message |
1013 | nil '(error notice) 'active | |
1014 | 'dcc-get-file-too-long | |
1015 | ?f (file-name-nondirectory buffer-file-name)) | |
1016 | (delete-process proc)) | |
1017 | (t | |
1018 | (process-send-string | |
1c86baa4 | 1019 | proc (erc-pack-int received-bytes))))))) |
597993cf MB |
1020 | |
1021 | ||
1022 | (defun erc-dcc-get-sentinel (proc event) | |
1023 | "This is the process sentinel for CTCP DCC SEND connections. | |
1024 | It shuts down the connection and notifies the user that the | |
1025 | transfer is complete." | |
1026 | ;; FIXME, we should look at EVENT, and also check size. | |
1027 | (with-current-buffer (process-buffer proc) | |
1028 | (delete-process proc) | |
597993cf | 1029 | (setq erc-dcc-list (delete erc-dcc-entry-data erc-dcc-list)) |
5e56b3fb | 1030 | (unless (= (point-min) (point-max)) |
5e56b3fb | 1031 | (erc-dcc-append-contents (current-buffer) erc-dcc-file-name)) |
597993cf MB |
1032 | (erc-display-message |
1033 | nil 'notice erc-server-process | |
1034 | 'dcc-get-complete | |
5e56b3fb MO |
1035 | ?f erc-dcc-file-name |
1036 | ?s (number-to-string erc-dcc-byte-count) | |
597993cf MB |
1037 | ?t (format "%.0f" |
1038 | (erc-time-diff (plist-get erc-dcc-entry-data :start-time) | |
5e56b3fb | 1039 | (erc-current-time))))) |
597993cf MB |
1040 | (kill-buffer (process-buffer proc)) |
1041 | (delete-process proc)) | |
1042 | ||
1043 | ;;; CHAT handling | |
1044 | ||
1045 | (defcustom erc-dcc-chat-buffer-name-format "DCC-CHAT-%s" | |
fb7ada5f | 1046 | "Format to use for DCC Chat buffer names." |
597993cf MB |
1047 | :group 'erc-dcc |
1048 | :type 'string) | |
1049 | ||
1050 | (defcustom erc-dcc-chat-mode-hook nil | |
fb7ada5f | 1051 | "Hook calls when `erc-dcc-chat-mode' finished setting up the buffer." |
597993cf MB |
1052 | :group 'erc-dcc |
1053 | :type 'hook) | |
1054 | ||
1055 | (defcustom erc-dcc-chat-connect-hook nil | |
1056 | "" | |
1057 | :group 'erc-dcc | |
1058 | :type 'hook) | |
1059 | ||
1060 | (defcustom erc-dcc-chat-exit-hook nil | |
1061 | "" | |
1062 | :group 'erc-dcc | |
1063 | :type 'hook) | |
1064 | ||
1065 | (defun erc-cmd-CREQ (line &optional force) | |
1066 | "Set or get the DCC chat request flag. | |
1067 | Possible values are: ask, auto, ignore." | |
1068 | (when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line) | |
1069 | (let ((cmd (match-string 1 line))) | |
1070 | (if (stringp cmd) | |
1071 | (erc-display-message | |
1072 | nil 'notice 'active | |
1073 | (format "Set DCC Chat requests to %S" | |
1074 | (setq erc-dcc-chat-request (intern cmd)))) | |
1075 | (erc-display-message nil 'notice 'active | |
1076 | (format "DCC Chat requests are set to %S" | |
1077 | erc-dcc-chat-request))) | |
1078 | t))) | |
1079 | ||
1080 | (defun erc-cmd-SREQ (line &optional force) | |
1081 | "Set or get the DCC send request flag. | |
1082 | Possible values are: ask, auto, ignore." | |
1083 | (when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line) | |
1084 | (let ((cmd (match-string 1 line))) | |
1085 | (if (stringp cmd) | |
1086 | (erc-display-message | |
1087 | nil 'notice 'active | |
1088 | (format "Set DCC Send requests to %S" | |
1089 | (setq erc-dcc-send-request (intern cmd)))) | |
1090 | (erc-display-message nil 'notice 'active | |
1091 | (format "DCC Send requests are set to %S" | |
1092 | erc-dcc-send-request))) | |
1093 | t))) | |
1094 | ||
1095 | (defun pcomplete/erc-mode/CREQ () | |
1096 | (pcomplete-here '("auto" "ask" "ignore"))) | |
1097 | (defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ) | |
1098 | ||
f1a4e679 CY |
1099 | (defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output) |
1100 | "Abnormal hook run after parsing (and maybe inserting) a DCC message. | |
1101 | Each function is called with two arguments: the ERC process and | |
1102 | the unprocessed output.") | |
1103 | ||
1104 | (define-obsolete-variable-alias 'erc-dcc-chat-filter-hook | |
2a1e2476 | 1105 | 'erc-dcc-chat-filter-functions "24.3") |
597993cf MB |
1106 | |
1107 | (defvar erc-dcc-chat-mode-map | |
1108 | (let ((map (make-sparse-keymap))) | |
1109 | (define-key map (kbd "RET") 'erc-send-current-line) | |
d4aa710a | 1110 | (define-key map "\t" 'completion-at-point) |
597993cf MB |
1111 | map) |
1112 | "Keymap for `erc-dcc-mode'.") | |
1113 | ||
4d789d84 | 1114 | (define-derived-mode erc-dcc-chat-mode fundamental-mode "DCC-Chat" |
597993cf | 1115 | "Major mode for wasting time via DCC chat." |
597993cf | 1116 | (setq mode-line-process '(":%s") |
597993cf | 1117 | erc-send-input-line-function 'erc-dcc-chat-send-input-line |
d4aa710a SM |
1118 | erc-default-recipients '(dcc)) |
1119 | (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t)) | |
597993cf MB |
1120 | |
1121 | (defun erc-dcc-chat-send-input-line (recipient line &optional force) | |
1122 | "Send LINE to the remote end. | |
1123 | Argument RECIPIENT should always be the symbol dcc, and force | |
1124 | is ignored." | |
1125 | ;; FIXME: We need to get rid of all force arguments one day! | |
1126 | (if (eq recipient 'dcc) | |
1127 | (process-send-string | |
1128 | (get-buffer-process (current-buffer)) line) | |
1129 | (error "erc-dcc-chat-send-input-line in %s" (current-buffer)))) | |
1130 | ||
1131 | (defun erc-dcc-chat (nick &optional pproc) | |
1132 | "Open a socket for incoming connections, and send a chat request to the | |
1133 | other client." | |
1134 | (interactive "sNick: ") | |
1135 | (when (null pproc) (if (processp erc-server-process) | |
1136 | (setq pproc erc-server-process) | |
1137 | (error "Can not find parent process"))) | |
1138 | (let* ((sproc (erc-dcc-server "dcc-chat-out" | |
1139 | 'erc-dcc-chat-filter | |
1140 | 'erc-dcc-chat-sentinel)) | |
1141 | (contact (process-contact sproc))) | |
1142 | (erc-dcc-list-add 'OCHAT nick sproc pproc) | |
1143 | (process-send-string pproc | |
1144 | (format "PRIVMSG %s :\C-aDCC CHAT chat %s %d\C-a\n" | |
1145 | nick | |
1146 | (erc-ip-to-decimal (nth 0 contact)) (nth 1 contact))))) | |
1147 | ||
1148 | (defvar erc-dcc-from) | |
1149 | (make-variable-buffer-local 'erc-dcc-from) | |
1150 | ||
1151 | (defvar erc-dcc-unprocessed-output) | |
1152 | (make-variable-buffer-local 'erc-dcc-unprocessed-output) | |
1153 | ||
1154 | (defun erc-dcc-chat-setup (entry) | |
1155 | "Setup a DCC chat buffer, returning the buffer." | |
1156 | (let* ((nick (erc-extract-nick (plist-get entry :nick))) | |
1157 | (buffer (generate-new-buffer | |
1158 | (format erc-dcc-chat-buffer-name-format nick))) | |
1159 | (proc (plist-get entry :peer)) | |
1160 | (parent-proc (plist-get entry :parent))) | |
1161 | (erc-setup-buffer buffer) | |
1162 | ;; buffer is now the current buffer. | |
1163 | (erc-dcc-chat-mode) | |
1164 | (setq erc-server-process parent-proc) | |
1165 | (setq erc-dcc-from nick) | |
1166 | (setq erc-dcc-entry-data entry) | |
1167 | (setq erc-dcc-unprocessed-output "") | |
30818a23 | 1168 | (setq erc-insert-marker (point-max-marker)) |
cb0a26d3 | 1169 | (setq erc-input-marker (make-marker)) |
597993cf MB |
1170 | (erc-display-prompt buffer (point-max)) |
1171 | (set-process-buffer proc buffer) | |
1172 | (add-hook 'kill-buffer-hook 'erc-dcc-chat-buffer-killed nil t) | |
1173 | (run-hook-with-args 'erc-dcc-chat-connect-hook proc) | |
1174 | buffer)) | |
1175 | ||
1176 | (defun erc-dcc-chat-accept (entry parent-proc) | |
1177 | "Accept an incoming DCC connection and open a DCC window" | |
1178 | (let* ((nick (erc-extract-nick (plist-get entry :nick))) | |
1179 | buffer proc) | |
1180 | (setq proc | |
1181 | (funcall erc-dcc-connect-function | |
1182 | "dcc-chat" nil | |
1183 | (plist-get entry :ip) | |
1184 | (string-to-number (plist-get entry :port)) | |
1185 | entry)) | |
1186 | ;; XXX: connected, should we kill the ip/port properties? | |
1187 | (setq entry (plist-put entry :peer proc)) | |
1188 | (setq entry (plist-put entry :parent parent-proc)) | |
1189 | (set-process-filter proc 'erc-dcc-chat-filter) | |
1190 | (set-process-sentinel proc 'erc-dcc-chat-sentinel) | |
1191 | (setq buffer (erc-dcc-chat-setup entry)))) | |
1192 | ||
1193 | (defun erc-dcc-chat-filter (proc str) | |
1194 | (let ((orig-buffer (current-buffer))) | |
1195 | (unwind-protect | |
1196 | (progn | |
1197 | (set-buffer (process-buffer proc)) | |
1198 | (setq erc-dcc-unprocessed-output | |
1199 | (concat erc-dcc-unprocessed-output str)) | |
f1a4e679 CY |
1200 | (run-hook-with-args 'erc-dcc-chat-filter-functions |
1201 | proc erc-dcc-unprocessed-output)) | |
597993cf MB |
1202 | (set-buffer orig-buffer)))) |
1203 | ||
1204 | (defun erc-dcc-chat-parse-output (proc str) | |
1205 | (save-match-data | |
1206 | (let ((posn 0) | |
1207 | line) | |
1208 | (while (string-match "\n" str posn) | |
1209 | (setq line (substring str posn (match-beginning 0))) | |
1210 | (setq posn (match-end 0)) | |
1211 | (erc-display-message | |
1212 | nil nil proc | |
1213 | 'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'face | |
1214 | 'erc-nick-default-face) ?m line)) | |
1215 | (setq erc-dcc-unprocessed-output (substring str posn))))) | |
1216 | ||
1217 | (defun erc-dcc-chat-buffer-killed () | |
1218 | (erc-dcc-chat-close "killed buffer")) | |
1219 | ||
1220 | (defun erc-dcc-chat-close (&optional event) | |
1221 | "Close a DCC chat, removing any associated processes and tidying up | |
1222 | `erc-dcc-list'" | |
1223 | (let ((proc (plist-get erc-dcc-entry-data :peer)) | |
1224 | (evt (or event ""))) | |
1225 | (when proc | |
1226 | (setq erc-dcc-list (delq erc-dcc-entry-data erc-dcc-list)) | |
1227 | (run-hook-with-args 'erc-dcc-chat-exit-hook proc) | |
1228 | (delete-process proc) | |
1229 | (erc-display-message | |
1230 | nil 'notice erc-server-process | |
1231 | 'dcc-chat-ended ?n erc-dcc-from ?t (current-time-string) ?e evt) | |
1232 | (setq erc-dcc-entry-data (plist-put erc-dcc-entry-data :peer nil))))) | |
1233 | ||
1234 | (defun erc-dcc-chat-sentinel (proc event) | |
1235 | (let ((buf (current-buffer)) | |
1236 | (elt (erc-dcc-member :peer proc))) | |
1237 | ;; the sentinel is also notified when the connection is opened, so don't | |
1238 | ;; immediately kill it again | |
1239 | ;(message "buf %s elt %S evt %S" buf elt event) | |
1240 | (unwind-protect | |
1241 | (if (string-match "^open from" event) | |
1242 | (erc-dcc-chat-setup elt) | |
1243 | (erc-dcc-chat-close event)) | |
1244 | (set-buffer buf)))) | |
1245 | ||
1246 | (defun erc-dcc-no-such-nick (proc parsed) | |
1247 | "Detect and handle no-such-nick replies from the IRC server." | |
19dc7206 | 1248 | (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed)) |
597993cf MB |
1249 | :parent proc)) |
1250 | (peer (plist-get elt :peer))) | |
1251 | (when (or (and (processp peer) (not (eq (process-status peer) 'open))) | |
1252 | elt) | |
1253 | ;; Since we already created an entry before sending the CTCP | |
1254 | ;; message, we now remove it, if it doesn't point to a process | |
1255 | ;; which is already open. | |
1256 | (setq erc-dcc-list (delq elt erc-dcc-list)) | |
1257 | (if (processp peer) (delete-process peer))) | |
1258 | nil)) | |
1259 | ||
597993cf MB |
1260 | (provide 'erc-dcc) |
1261 | ||
1262 | ;;; erc-dcc.el ends here | |
1263 | ;; | |
1264 | ;; Local Variables: | |
1265 | ;; indent-tabs-mode: nil | |
1266 | ;; End: | |
1267 |