1 ;;; zenirc-dcc.el --- CTCP DCC module for ZenIRC
3 ;; Copyright (C) 1993, 1994 Ben A. Mesander
4 ;; Copyright (C) 1995 Noah S. Friedman
5 ;; Copyright (C) 1998 Per Persson
7 ;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu>
8 ;; Noah Friedman <friedman@prep.ai.mit.edu>
9 ;; Per Persson <pp@sno.pp.se>
10 ;; Maintainer: pp@sno.pp.se
11 ;; Keywords: zenirc, extensions
12 ;; Created: 1994-01-23
14 ;; This program is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this program; if not, you can either send email to this
26 ;; program's maintainer or write to: The Free Software Foundation,
27 ;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.
31 ;; DCC `send' isn't yet implemented because emacs does not provide server
32 ;; sockets. One way to get around this would be to write a small C or perl
33 ;; program to do the listening and interface it with emacs.
35 ;; This file is divided into 4 sections:
36 ;; * Variables related to all DCC operations
37 ;; * Misc utility macros and functions
38 ;; * Interactive command handling
39 ;; * Server message handling (i.e. messages from remote users)
47 ;; zenirc-dcc-alist looks like:
48 ;; (("nick!user@host" GET proc-or-nil ip-address port size filename)
49 ;; ("nick!user@host" CHAT proc-or-nil ip-address port))
50 (defvar zenirc-dcc-alist nil)
52 (defvar zenirc-verbose-dcc t)
54 ;; This function takes all the usual args as open-network-stream, plus one
55 ;; more: the entry data from zenirc-dcc-alist for this particular process.
56 ;; Emacs 18 cannot open-network-stream on IP numbers, so instead the
57 ;; hostname from the nick must be used; of course, these may not equivalent,
58 ;; but there's nothing that can be done about that. Use emacs 19.
59 (defvar zenirc-dcc-connect-function 'zenirc-dcc-open-network-stream)
62 ;;; Section 2: Misc macros and utility functions
64 (defmacro zenirc-dcc-catalog-entry (sym)
65 `(zenirc-lang-retrieve-catalog-entry ,sym))
67 (defun zenirc-dcc-install-message-catalogs ()
68 (zenirc-lang-define-catalog 'english
69 '((dcc-chat-discarded . "[dcc] note: previous chat request from %s discarded.\n")
70 (dcc-chat-ended . "[dcc] chat with %s ended %s: %s\n")
71 (dcc-chat-no-request . "[dcc] chat request from %s not found.\n")
72 (dcc-chat-offered . "[dcc] chat offered by %s\n")
73 (dcc-chat-privmsg . "=%s= %s\n")
74 (dcc-closed . "[dcc] Closed %s from %s%s\n")
75 (dcc-command-undefined . "[dcc] no such subcommand: %s\n")
76 (dcc-ctcp-errmsg . "`%s' is not a DCC subcommand known to this client.")
77 (dcc-ctcp-unknown . "[info] unknown dcc subcommand `%s' from %s\n")
78 (dcc-get-bytes-received . "[dcc] %s: %d bytes received.")
79 (dcc-get-complete . "[dcc] file %s transfer complete (%d bytes).\n")
80 (dcc-get-file-exists . "[dcc] File %s exists. Overwrite? ")
81 (dcc-get-file-too-long . "[dcc] %s: File longer than sender claimed; aborting transfer.")
82 (dcc-get-filename . "[dcc] Local filename (default %s): ")
83 (dcc-get-notfound . "[error] %s hasn't offered %s for DCC transfer.\n")
84 (dcc-list-end . "[dcc] End of list.\n")
85 (dcc-list-head . "[dcc] From Type Active Size Filename\n")
86 (dcc-list-item . "[dcc] %-9s %4s %-6s %4s %s\n")
87 (dcc-list-line . "[dcc] ---- ---- ------ ---- --------\n")
88 (dcc-malformed . "[dcc] error: %s sent malformed `%s' request: %s\n")
89 (dcc-privileged-port . "[dcc] possibly bogus request: %s is a privileged port.\n")
90 (dcc-request-bogus . "[dcc] bogus dcc `%s' from user %s\n")
91 (dcc-send-offered . "[dcc] file %s offered by user %s (size %s)\n")
94 ;; Return the elt of alist which contains nick and type, e.g.
95 ;; (zenirc-dcc-member "noah!friedman@prep.ai.mit.edu" 'CHAT zenirc-dcc-alist)
96 ;; => ("noah!friedman@prep.ai.mit.edu" CHAT <proc> <ipaddr> <port>)
97 (defun zenirc-dcc-member (nick type &optional alist)
98 (or alist (setq alist zenirc-dcc-alist))
99 (let ((nicklen (length nick))
100 (nickuserhostp (save-match-data
101 (string-match "!" nick)))
105 (setq elt (car alist))
106 (setq alist (cdr alist))
107 (cond ((and nickuserhostp
108 (eq (car (cdr elt)) type)
109 (zenirc-names-equal-p (car elt) nick))
112 ((and (zenirc-names-equal-p (zenirc-extract-nick (car elt)) nick)
113 (eq (car (cdr elt)) type))
118 ;; msa wrote this nifty little frob to convert an n-byte integer to a packed
120 (defun zenirc-packed-int (value count)
122 (concat (zenirc-packed-int (/ value 256) (1- count))
123 (char-to-string (% value 256)))
126 (defun zenirc-dcc-open-network-stream (procname buffer addr port entry)
127 (and (string-lessp emacs-version "19")
128 (setq addr (zenirc-extract-host (car entry))))
129 (open-network-stream procname buffer addr port))
132 ;;; Section 3: Interactive command handling
134 (defvar zenirc-command-dcc-hook '(zenirc-command-dcc))
136 (defvar zenirc-dcc-get-default-directory nil
137 "*Default directory for incoming DCC file transfers.
138 If this is nil, then the current value of `default-directory' is used.")
140 ;; parser for /dcc command. This figures out the dcc subcommand and calls
141 ;; the appropriate routine to handle it.
142 ;; The function dispatched should be named "zenirc-dcc-do-FOO-command",
143 ;; where FOO is one of `close', `get', `list', etc.
144 (defun zenirc-command-dcc (proc parsedcmd)
145 (let* ((cmd (zenirc-parse-firstword (cdr parsedcmd)))
146 (fn (intern-soft (concat "zenirc-dcc-do-" (car cmd) "-command"))))
147 (if (and fn (fboundp fn))
148 (funcall fn proc cmd)
149 (zenirc-message proc 'dcc-command-undefined (car cmd)))))
151 (defun zenirc-dcc-do-chat-command (proc subcommand)
152 (let* ((nick (car (zenirc-parse-firstword (cdr subcommand))))
153 (elt (zenirc-dcc-member nick 'CHAT)))
155 (zenirc-dcc-chat elt proc)
156 (zenirc-message proc 'dcc-chat-no-request nick))))
158 ;; /dcc close type nick
159 ;; both type and nick are optional, but type must be specified if nick is.
160 (defun zenirc-dcc-do-close-command (proc subcommand)
161 (let* ((tmp (zenirc-parse-n-words 2 (cdr subcommand)))
162 (type (if (string= "" (car tmp))
164 (intern (upcase (car tmp)))))
165 (nick (car (cdr tmp)))
166 (alist zenirc-dcc-alist)
169 (setq elt (car alist))
170 (setq alist (cdr alist))
173 ;; Skip this elt if a type was specified and this one doesn't match.
175 (not (eq (car (cdr elt)) type))))
176 ((or (string= nick "")
177 (zenirc-names-equal-p nick (zenirc-extract-nick (car elt))))
179 ;; Delete process if it exists.
180 (setq tmp (nth 2 elt))
182 (delete-process tmp))
184 (setq zenirc-dcc-alist (delq elt zenirc-dcc-alist))
185 (zenirc-message proc 'dcc-closed
187 (zenirc-extract-nick (car elt))
188 (if (eq (car (cdr elt)) 'SEND)
189 (concat ", file " (nth 6 elt))
192 (defun zenirc-dcc-do-get-command (proc parsedcmd)
193 (let* ((tmp (zenirc-parse-n-words 2 (cdr parsedcmd)))
195 (filename (car (cdr tmp)))
196 (elt (zenirc-dcc-member nick 'GET)))
198 (let* ((msg (zenirc-dcc-catalog-entry 'dcc-get-filename))
199 (file (read-file-name (format msg (file-name-nondirectory
201 (or zenirc-dcc-get-default-directory
203 (file-name-nondirectory filename))))
205 (cond ((file-exists-p file)
206 (if (yes-or-no-p (format (zenirc-dcc-catalog-entry
207 'dcc-get-file-exists)
209 (zenirc-dcc-get-file elt file proc)
210 (zenirc-message proc 'dcc-get-cmd-aborted
213 (zenirc-dcc-get-file elt file proc))))
214 (zenirc-message proc 'dcc-get-notfound nick filename))))
216 ;; this is the handler for the /dcc list command - it lists the current state
217 ;; of zenirc-dcc-alist in an easy to read manner.
218 (defun zenirc-dcc-do-list-command (proc parsedcmd)
219 (let ((alist zenirc-dcc-alist)
221 (zenirc-message proc 'dcc-list-head)
222 (zenirc-message proc 'dcc-list-line)
224 (setq elt (car alist))
225 (setq alist (cdr alist))
227 (setq size (nth 5 elt))
231 (setq size "unknown")))
233 (zenirc-message proc 'dcc-list-item
234 (zenirc-extract-nick (car elt))
236 (if (processp (nth 2 elt))
237 (process-status (nth 2 elt))
240 (or (nth 6 elt) "")))
241 (zenirc-message proc 'dcc-list-end)))
244 ;;; Section 4: Server message handling (i.e. messages from remote users)
246 ;; Hook variable for CTCP DCC queries
247 (defvar zenirc-ctcp-query-DCC-hook '(zenirc-ctcp-query-DCC))
249 (defvar zenirc-dcc-query-handler-alist
250 '(("SEND" . zenirc-dcc-handle-ctcp-send)
251 ("CHAT" . zenirc-dcc-handle-ctcp-chat)))
253 ;; zenirc-ctcp-query-DCC is the function called when a CTCP DCC
254 ;; request is detected by the client. It examines the DCC subcommand,
255 ;; and either calls the appropriate routine for that subcommand, or
256 ;; sends a ctcp errmsg to the sender.
257 (defun zenirc-ctcp-query-DCC (proc parsedctcp from to)
258 (let* ((cmd (car (zenirc-parse-firstword (cdr parsedctcp))))
259 (handler (cdr (assoc cmd zenirc-dcc-query-handler-alist))))
261 (funcall handler proc parsedctcp from to)
262 (let ((fmt (zenirc-dcc-catalog-entry 'dcc-ctcp-errmsg)))
263 (zenirc-ctcp-errmsg nil from to (concat "DCC " cmd)
264 (format fmt cmd) proc)
265 (and zenirc-verbose-ctcp
266 (zenirc-message proc 'dcc-ctcp-unknown cmd
267 (zenirc-run-hook 'zenirc-format-nickuserhost-hook from)))))))
269 ;; This is called a CTCP DCC SEND subcommand is sent to the client.
270 ;; It extracts the information about the dcc request and adds it to
272 (defun zenirc-dcc-handle-ctcp-send (proc parsedctcp from to)
273 (let ((str (cdr parsedctcp))
274 (sender (zenirc-run-hook 'zenirc-format-nickuserhost-hook from))
275 ;; filename ipaddr port size(optional)
276 (regexp "^SEND \\([^ ]+\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")
277 localfile filename ip port size)
278 (if (not (zenirc-names-equal-p to zenirc-nick t))
279 ;; DCC SEND requests must be sent to you, and you alone.
280 (zenirc-message proc 'dcc-request-bogus 'SEND sender)
282 ((string-match regexp str)
283 (setq filename (zenirc-match-string 1 str))
284 (setq ip (zenirc-match-string 2 str))
285 (setq port (zenirc-match-string 3 str))
286 (setq size (zenirc-match-string 4 str))
288 ;; a warning really should also be sent
289 ;; if the ip address != the host the dcc sender is on.
290 (zenirc-message proc 'dcc-send-offered filename sender
291 (if (string= size "") "unknown" size))
293 (and (< (string-to-int port) 1025)
294 (zenirc-message proc 'dcc-privileged-port port))
296 (setq zenirc-dcc-alist
297 (cons (list from 'GET nil ip port size filename)
300 (zenirc-message proc 'dcc-malformed sender 'SEND str))))))
302 (defun zenirc-dcc-handle-ctcp-chat (proc parsedctcp from to)
303 (let* ((str (cdr parsedctcp))
304 (sender (zenirc-run-hook 'zenirc-format-nickuserhost-hook from))
306 (regexp "^CHAT +chat +\\([0-9.]+\\) +\\([0-9]+\\)")
307 (elt (zenirc-dcc-member from 'CHAT))
309 ;; DCC CHAT requests must be sent to you, and you alone.
310 (if (not (zenirc-names-equal-p to zenirc-nick t))
311 (zenirc-message proc 'dcc-request-bogus 'CHAT sender)
312 (cond ((string-match regexp str)
313 (setq ip (zenirc-match-string 1 str))
314 (setq port (zenirc-match-string 2 str))
316 ;; A warning really should also be sent if the ip
317 ;; address != the host the dcc sender is on.
318 (zenirc-message proc 'dcc-chat-offered sender)
319 (and (< (string-to-int port) 1025)
320 (zenirc-message proc 'dcc-privileged-port port))
323 (setcar (nthcdr 3 elt) ip)
324 (setcar (nthcdr 4 elt) port)
325 (zenirc-message proc 'dcc-chat-discarded sender))
327 (setq zenirc-dcc-alist (cons (list from 'CHAT nil ip port)
328 zenirc-dcc-alist)))))
330 (zenirc-message proc 'dcc-malformed sender 'CHAT str))))))
333 ;;; Section 5: GET handling
335 ;; zenirc-dcc-get-file does the work of setting up a transfer from the remote
336 ;; client to the local one over a tcp connection. This involves setting
337 ;; up a process filter and a process sentinel, and making the connection.
338 (defun zenirc-dcc-get-file (entry file parent-proc)
339 (let* ((obuf (current-buffer))
340 (buffer (generate-new-buffer (file-name-nondirectory file)))
346 (setq mode-line-process '(":%s"))
347 (setq buffer-read-only t)
348 (set-visited-file-name file)
349 (make-local-variable 'zenirc-dcc-parent-process)
350 (setq zenirc-dcc-parent-process parent-proc)
351 (make-local-variable 'zenirc-dcc-entry-data)
352 (setq zenirc-dcc-entry-data entry)
353 (make-local-variable 'zenirc-dcc-size)
354 (setq zenirc-dcc-size (nth 5 entry))
355 (make-local-variable 'zenirc-dcc-byte-count)
356 (setq zenirc-dcc-byte-count 0)
358 (funcall zenirc-dcc-connect-function
359 "zenirc-dcc-get" buffer
360 (nth 3 entry) (string-to-int (nth 4 entry)) entry))
361 (set-process-buffer proc buffer)
362 (set-process-filter proc 'zenirc-dcc-get-filter)
363 (set-process-sentinel proc 'zenirc-dcc-get-sentinel)
364 (setcar (nthcdr 2 entry) proc))
367 ;; This is the process filter for transfers from other clients to this one.
368 ;; It reads incoming bytes from the network and stores them in the DCC
369 ;; buffer, and sends back the replies after each block of data per the DCC
370 ;; protocol spec. Well not really. We write back a reply after each read,
371 ;; rather than every 1024 byte block, but nobody seems to care.
372 (defun zenirc-dcc-get-filter (proc str)
373 (let ((obuf (current-buffer)))
376 (set-buffer (process-buffer proc))
377 (setq buffer-read-only nil)
378 (goto-char (point-max))
381 (setq zenirc-dcc-byte-count (+ (length str) zenirc-dcc-byte-count))
382 (and zenirc-verbose-dcc
383 (zenirc-message nil 'dcc-get-bytes-received
384 (file-name-nondirectory buffer-file-name)
385 zenirc-dcc-byte-count))
387 ((and (numberp zenirc-dcc-size)
388 (> zenirc-dcc-byte-count zenirc-dcc-size))
389 (zenirc-message nil 'dcc-get-file-too-long
390 (file-name-nondirectory buffer-file-name))
391 (delete-process proc))
394 proc (zenirc-packed-int zenirc-dcc-byte-count 4)))))
395 (setq buffer-read-only t)
399 ;; This is the process sentinel for CTCP DCC SEND connections.
400 ;; It shuts down the connection and notifies the user that the
401 ;; transfer is complete.
402 (defun zenirc-dcc-get-sentinel (proc event)
403 (let ((obuf (current-buffer)))
406 (set-buffer (process-buffer proc))
407 (delete-process proc)
408 (setq buffer-read-only nil)
409 (setq zenirc-dcc-alist (delq zenirc-dcc-entry-data zenirc-dcc-alist))
410 (zenirc-message zenirc-dcc-parent-process 'dcc-get-complete
411 (file-name-nondirectory buffer-file-name)
417 ;;; Section 6: CHAT handling
419 (defvar zenirc-dcc-chat-buffer-name-format "ZenIRC-DCC-%s")
421 (defvar zenirc-dcc-chat-mode-hook nil)
422 (defvar zenirc-dcc-chat-connect-hook nil)
423 (defvar zenirc-dcc-chat-exit-hook nil)
425 (defvar zenirc-dcc-chat-filter-hook '(zenirc-dcc-chat-parse-output)
426 "*Hook to run after doing parsing (and possible insertion) of DCC messages.")
428 (defvar zenirc-dcc-chat-mode-map '()
429 "Sparse keymap for zenirc-dcc-mode")
430 (cond ((not zenirc-dcc-chat-mode-map)
431 (setq zenirc-dcc-chat-mode-map (make-sparse-keymap))
432 (define-key zenirc-dcc-chat-mode-map "\n" 'zenirc-dcc-chat-send-line)
433 (define-key zenirc-dcc-chat-mode-map "\r" 'zenirc-dcc-chat-send-line)))
435 (defun zenirc-dcc-chat-mode ()
436 "Major mode for wasting time via DCC chat."
438 (kill-all-local-variables)
439 (setq mode-line-process '(":%s"))
440 (setq mode-name "ZenIRC-DCC-Chat")
441 (setq major-mode 'zenirc-dcc-chat-mode)
442 (use-local-map zenirc-dcc-chat-mode-map)
443 (zenirc-run-hook 'zenirc-dcc-chat-mode-hook))
445 (defun zenirc-dcc-chat-send-line ()
446 "Send current line to other client."
450 (let ((proc (get-buffer-process (current-buffer)))
451 (string (buffer-substring zenirc-process-mark (point))))
452 (set-marker zenirc-process-mark (point))
453 (process-send-string proc string)))
455 (defun zenirc-dcc-chat (entry parent-proc)
456 (let* ((nick (zenirc-extract-nick (car entry)))
457 (buffer (generate-new-buffer
458 (format zenirc-dcc-chat-buffer-name-format
459 (zenirc-extract-nick (car entry)))))
461 (pop-to-buffer buffer)
462 (zenirc-dcc-chat-mode)
463 (make-local-variable 'zenirc-dcc-parent-process)
464 (setq zenirc-dcc-parent-process parent-proc)
465 (make-local-variable 'zenirc-dcc-from)
466 (setq zenirc-dcc-from nick)
467 (make-local-variable 'zenirc-dcc-entry-data)
468 (setq zenirc-dcc-entry-data entry)
469 (make-local-variable 'zenirc-dcc-unprocessed-output)
470 (setq zenirc-dcc-unprocessed-output "")
471 (make-local-variable 'zenirc-process-mark)
472 (setq zenirc-process-mark (set-marker (make-marker) (point-max)))
474 (funcall zenirc-dcc-connect-function
475 "zenirc-dcc-chat" buffer
476 (nth 3 entry) (string-to-int (nth 4 entry)) entry))
477 (set-process-buffer proc buffer)
478 (set-process-filter proc 'zenirc-dcc-chat-filter)
479 (set-process-sentinel proc 'zenirc-dcc-chat-sentinel)
480 (setcar (nthcdr 2 entry) proc)
481 (zenirc-run-hook 'zenirc-dcc-chat-connect-hook proc)))
483 (defun zenirc-dcc-chat-filter (proc str)
484 (let ((orig-buffer (current-buffer)))
487 (set-buffer (process-buffer proc))
488 (setq zenirc-dcc-unprocessed-output
489 (concat zenirc-dcc-unprocessed-output str))
490 (zenirc-run-hook 'zenirc-dcc-chat-filter-hook proc
491 zenirc-dcc-unprocessed-output))
492 (set-buffer orig-buffer))))
494 (defun zenirc-dcc-chat-parse-output (proc str)
498 (while (string-match "\n" str posn)
499 (setq line (substring str posn (match-beginning 0)))
500 (setq posn (match-end 0))
501 (zenirc-message proc 'dcc-chat-privmsg zenirc-dcc-from line))
502 (setq zenirc-dcc-unprocessed-output (substring str posn)))))
504 (defun zenirc-dcc-chat-sentinel (proc event)
505 (let ((buf (current-buffer))
506 (tm (current-time-string)))
509 (set-buffer (process-buffer proc))
510 (delete-process proc)
511 (setq zenirc-dcc-alist (delq zenirc-dcc-entry-data zenirc-dcc-alist))
512 (zenirc-run-hook 'zenirc-dcc-chat-exit-hook proc)
513 (zenirc-message zenirc-dcc-parent-process 'dcc-chat-ended
514 zenirc-dcc-from tm event)
515 (zenirc-message proc 'dcc-chat-ended
516 zenirc-dcc-from tm event))
520 (provide 'zenirc-dcc)
522 (zenirc-dcc-install-message-catalogs)
524 ;;; zenirc-dcc.el ends here