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