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