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