lisp/erc/erc-dcc.el

   1 ;;; erc-dcc.el --- CTCP DCC module for ERC
   2
   3 ;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2017 Free Software
   4 ;; 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: emacs-devel@gnu.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 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 <https://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" (downcase (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                         (format " (%d%%)"
 598                                 (floor (* 100.0 byte-count)
 599                                        (plist-get elt :size))))))
 600        ?f (or (and (plist-member elt :file) (plist-get elt :file)) "")))
 601     (erc-display-message
 602      nil 'notice 'active
 603      'dcc-list-end)
 604     t))
 605
 606 (defun erc-dcc-do-SEND-command (proc nick &rest file)
 607   "Offer FILE to NICK by sending a ctcp dcc send message.
 608 If FILE is split into multiple arguments, re-join the arguments,
 609 separated by a space."
 610   (setq file (and file (mapconcat #'identity file " ")))
 611   (if (file-exists-p file)
 612       (progn
 613         (erc-display-message
 614          nil 'notice 'active
 615          'dcc-send-offer ?n nick ?f file)
 616         (erc-dcc-send-file nick file) t)
 617     (erc-display-message nil '(notice error) proc "File not found") t))
 618
 619 ;;; Server message handling (i.e. messages from remote users)
 620
 621 ;;;###autoload
 622 (defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC)
 623   "Hook variable for CTCP DCC queries.")
 624
 625 (defvar erc-dcc-query-handler-alist
 626   '(("SEND" . erc-dcc-handle-ctcp-send)
 627     ("CHAT" . erc-dcc-handle-ctcp-chat)))
 628
 629 ;;;###autoload
 630 (defun erc-ctcp-query-DCC (proc nick login host to query)
 631   "The function called when a CTCP DCC request is detected by the client.
 632 It examines the DCC subcommand, and calls the appropriate routine for
 633 that subcommand."
 634   (let* ((cmd (cadr (split-string query " ")))
 635          (handler (cdr (assoc cmd erc-dcc-query-handler-alist))))
 636     (if handler
 637         (funcall handler proc query nick login host to)
 638       ;; FIXME: Send a ctcp error notice to the remote end?
 639       (erc-display-message
 640        nil '(notice error) proc
 641        'dcc-ctcp-unknown
 642        ?q query ?n nick ?u login ?h host))))
 643
 644 (defconst erc-dcc-ctcp-query-send-regexp
 645   (concat "^DCC SEND \\("
 646           ;; Following part matches either filename without spaces
 647           ;; or filename enclosed in double quotes with any number
 648           ;; of escaped double quotes inside.
 649           "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)"
 650           "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)"))
 651
 652 (define-inline erc-dcc-unquote-filename (filename)
 653   (inline-quote
 654    (erc-replace-regexp-in-string "\\\\\\\\" "\\"
 655                                  (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t)))
 656
 657 (defun erc-dcc-handle-ctcp-send (proc query nick login host to)
 658   "This is called if a CTCP DCC SEND subcommand is sent to the client.
 659 It extracts the information about the dcc request and adds it to
 660 `erc-dcc-list'."
 661   (unless (eq erc-dcc-send-request 'ignore)
 662     (cond
 663      ((not (erc-current-nick-p to))
 664       ;; DCC SEND requests must be sent to you, and you alone.
 665       (erc-display-message
 666        nil 'notice proc
 667        'dcc-request-bogus
 668        ?r "SEND" ?n nick ?u login ?h host))
 669      ((string-match erc-dcc-ctcp-query-send-regexp query)
 670       (let ((filename
 671              (or (match-string 5 query)
 672                  (erc-dcc-unquote-filename (match-string 2 query))))
 673             (ip       (erc-decimal-to-ip (match-string 6 query)))
 674             (port     (match-string 7 query))
 675             (size     (match-string 8 query)))
 676         ;; FIXME: a warning really should also be sent
 677         ;; if the ip address != the host the dcc sender is on.
 678         (erc-display-message
 679          nil 'notice proc
 680          'dcc-send-offered
 681          ?f filename ?n nick ?u login ?h host
 682          ?s (if (string= size "") "unknown" size))
 683         (and (< (string-to-number port) 1025)
 684              (erc-display-message
 685               nil 'notice proc
 686               'dcc-privileged-port
 687               ?p port))
 688         (erc-dcc-list-add
 689          'GET (format "%s!%s@%s" nick login host)
 690          nil proc
 691          :ip ip :port port :file filename
 692          :size (string-to-number size))
 693         (if (and (eq erc-dcc-send-request 'auto)
 694                  (erc-dcc-auto-mask-p (format "\"%s!%s@%s\"" nick login host)))
 695             (erc-dcc-get-file (car erc-dcc-list) filename proc))))
 696      (t
 697       (erc-display-message
 698        nil 'notice proc
 699        'dcc-malformed
 700        ?n nick ?u login ?h host ?q query)))))
 701
 702 (defun erc-dcc-auto-mask-p (spec)
 703   "Takes a full SPEC of a user in the form \"nick!login@host\" and
 704 matches against all the regexp's in `erc-dcc-auto-masks'. If any
 705 match, returns that regexp and nil otherwise."
 706   (let ((lst erc-dcc-auto-masks))
 707     (while (and lst
 708                 (not (string-match (car lst) spec)))
 709       (setq lst (cdr lst)))
 710     (and lst (car lst))))
 711
 712 (defconst erc-dcc-ctcp-query-chat-regexp
 713   "^DCC CHAT +chat +\\([0-9]+\\) +\\([0-9]+\\)")
 714
 715 (defcustom erc-dcc-chat-request 'ask
 716   "How to treat incoming DCC Chat requests.
 717 `ask' - Report the Chat request, and wait for the user to manually accept it
 718 `auto' - Automatically accept the request and open a new chat window
 719 `ignore' - Ignore incoming DCC chat requests completely."
 720   :group 'erc-dcc
 721   :type '(choice (const ask) (const auto) (const ignore)))
 722
 723 (defun erc-dcc-handle-ctcp-chat (proc query nick login host to)
 724   (unless (eq erc-dcc-chat-request 'ignore)
 725     (cond
 726      (;; DCC CHAT requests must be sent to you, and you alone.
 727       (not (erc-current-nick-p to))
 728       (erc-display-message
 729        nil '(notice error) proc
 730        'dcc-request-bogus ?r "CHAT" ?n nick ?u login ?h host))
 731      ((string-match erc-dcc-ctcp-query-chat-regexp query)
 732       ;; We need to use let* here, since erc-dcc-member might clutter
 733       ;; the match value.
 734       (let* ((ip   (erc-decimal-to-ip (match-string 1 query)))
 735              (port (match-string 2 query))
 736              (elt  (erc-dcc-member :nick nick :type 'CHAT)))
 737         ;; FIXME: A warning really should also be sent if the ip
 738         ;; address != the host the dcc sender is on.
 739         (erc-display-message
 740          nil 'notice proc
 741          'dcc-chat-offered
 742          ?n nick ?u login ?h host ?p port)
 743         (and (< (string-to-number port) 1025)
 744              (erc-display-message
 745               nil 'notice proc
 746               'dcc-privileged-port ?p port))
 747         (cond (elt
 748                ;; XXX: why are we updating ip/port on the existing connection?
 749                (setq elt (plist-put (plist-put elt :port port) :ip ip))
 750                (erc-display-message
 751                 nil 'notice proc
 752                 'dcc-chat-discarded ?n nick ?u login ?h host))
 753               (t
 754                (erc-dcc-list-add
 755                 'CHAT (format "%s!%s@%s" nick login host)
 756                 nil proc
 757                 :ip ip :port port)))
 758         (if (eq erc-dcc-chat-request 'auto)
 759             (erc-dcc-chat-accept (erc-dcc-member :nick nick :type 'CHAT)
 760                                  proc))))
 761      (t
 762       (erc-display-message
 763        nil '(notice error) proc
 764        'dcc-malformed ?n nick ?u login ?h host ?q query)))))
 765
 766
 767 (defvar erc-dcc-entry-data nil
 768   "Holds the `erc-dcc-list' entry for this DCC connection.")
 769 (make-variable-buffer-local 'erc-dcc-entry-data)
 770
 771 ;;; SEND handling
 772
 773 (defcustom erc-dcc-block-size 1024
 774   "Block size to use for DCC SEND sessions."
 775   :group 'erc-dcc
 776   :type 'integer)
 777
 778 (defcustom erc-dcc-pump-bytes nil
 779   "If set to an integer, keep sending until that number of bytes are
 780 unconfirmed."
 781   :group 'erc-dcc
 782   :type '(choice (const nil) integer))
 783
 784 (define-inline erc-dcc-get-parent (proc)
 785   (inline-quote (plist-get (erc-dcc-member :peer ,proc) :parent)))
 786
 787 (defun erc-dcc-send-block (proc)
 788   "Send one block of data.
 789 PROC is the process-object of the DCC connection.  Returns the number of
 790 bytes sent."
 791   (let* ((elt (erc-dcc-member :peer proc))
 792          (confirmed-marker (plist-get elt :sent))
 793          (sent-marker (plist-get elt :sent)))
 794     (with-current-buffer (process-buffer proc)
 795       (when erc-dcc-verbose
 796         (erc-display-message
 797          nil 'notice (erc-dcc-get-parent proc)
 798          (format "DCC: Confirmed %d, sent %d, sending block now"
 799                  (- confirmed-marker (point-min))
 800                (- sent-marker (point-min)))))
 801       (let* ((end (min (+ sent-marker erc-dcc-block-size)
 802                        (point-max)))
 803              (string (buffer-substring-no-properties sent-marker end)))
 804         (when (< sent-marker end)
 805           (set-marker sent-marker end)
 806           (process-send-string proc string))
 807         (length string)))))
 808
 809 (defun erc-dcc-send-filter (proc string)
 810   (let* ((size (erc-unpack-int string))
 811          (elt (erc-dcc-member :peer proc))
 812          (parent (plist-get elt :parent))
 813          (sent-marker (plist-get elt :sent))
 814          (confirmed-marker (plist-get elt :confirmed)))
 815     (with-current-buffer (process-buffer proc)
 816       (set-marker confirmed-marker (+ (point-min) size))
 817       (cond
 818        ((and (= confirmed-marker sent-marker)
 819              (= confirmed-marker (point-max)))
 820         (erc-display-message
 821          nil 'notice parent
 822          'dcc-send-finished
 823          ?n (plist-get elt :nick)
 824          ?f buffer-file-name
 825          ?s (number-to-string (- sent-marker (point-min))))
 826         (setq erc-dcc-list (delete elt erc-dcc-list))
 827         (set-buffer-modified-p nil)
 828         (kill-buffer (current-buffer))
 829         (delete-process proc))
 830        ((<= confirmed-marker sent-marker)
 831         (while (and (< (- sent-marker confirmed-marker)
 832                        (or erc-dcc-pump-bytes
 833                            erc-dcc-block-size))
 834                     (> (erc-dcc-send-block proc) 0))))
 835        ((> confirmed-marker sent-marker)
 836         (erc-display-message
 837          nil 'notice parent
 838          (format "DCC: Client confirmed too much (%s vs %s)!"
 839                  (marker-position confirmed-marker)
 840                  (marker-position sent-marker)))
 841         (set-buffer-modified-p nil)
 842         (kill-buffer (current-buffer))
 843         (delete-process proc))))))
 844
 845 (defun erc-dcc-display-send (proc)
 846   (erc-display-message
 847    nil 'notice (erc-dcc-get-parent proc)
 848    (format "DCC: SEND connect from %s"
 849            (format-network-address (process-contact proc :remote)))))
 850
 851 (defcustom erc-dcc-send-connect-hook
 852   '(erc-dcc-display-send erc-dcc-send-block)
 853   "Hook run whenever the remote end of a DCC SEND offer connected to your
 854 listening port."
 855   :group 'erc-dcc
 856   :type 'hook)
 857
 858 (defun erc-dcc-nick (plist)
 859   "Extract the nickname portion of the :nick property value in PLIST."
 860   (erc-extract-nick (plist-get plist :nick)))
 861
 862 (defun erc-dcc-send-sentinel (proc event)
 863   (let* ((elt (erc-dcc-member :peer proc)))
 864     (cond
 865      ((string-match "^open from " event)
 866       (when elt
 867         (let ((buf (marker-buffer (plist-get elt :sent))))
 868           (with-current-buffer buf
 869             (set-process-buffer proc buf)
 870             (setq erc-dcc-entry-data elt)))
 871         (run-hook-with-args 'erc-dcc-send-connect-hook proc))))))
 872
 873 (defun erc-dcc-find-file (file)
 874   (with-current-buffer (generate-new-buffer (file-name-nondirectory file))
 875     (insert-file-contents-literally file)
 876     (setq buffer-file-name file)
 877     (current-buffer)))
 878
 879 (defun erc-dcc-file-to-name (file)
 880   (with-temp-buffer
 881     (insert (file-name-nondirectory file))
 882     (subst-char-in-region (point-min) (point-max) ?  ?_ t)
 883     (buffer-string)))
 884
 885 (defun erc-dcc-send-file (nick file &optional pproc)
 886   "Open a socket for incoming connections, and send a CTCP send request to the
 887 other client."
 888   (interactive "sNick: \nfFile: ")
 889   (when (null pproc) (if (processp erc-server-process)
 890                          (setq pproc erc-server-process)
 891                        (error "Can not find parent process")))
 892   (if (featurep 'make-network-process)
 893       (let* ((buffer (erc-dcc-find-file file))
 894              (size (buffer-size buffer))
 895              (start (with-current-buffer buffer
 896                       (point-min-marker)))
 897              (sproc (erc-dcc-server "dcc-send"
 898                                     'erc-dcc-send-filter
 899                                     'erc-dcc-send-sentinel))
 900              (contact (process-contact sproc)))
 901         (erc-dcc-list-add
 902          'SEND nick sproc pproc
 903          :file file :size size
 904          :sent start :confirmed (copy-marker start))
 905         (process-send-string
 906          pproc (format "PRIVMSG %s :\C-aDCC SEND %s %s %d %d\C-a\n"
 907                        nick (erc-dcc-file-to-name file)
 908                        (erc-ip-to-decimal (or erc-dcc-public-host
 909                                               (nth 0 contact)))
 910                        (nth 1 contact)
 911                        size)))
 912     (error "`make-network-process' not supported by your Emacs")))
 913
 914 ;;; GET handling
 915
 916 (defcustom erc-dcc-receive-cache (* 1024 512)
 917   "Number of bytes to let the receive buffer grow before flushing it."
 918   :group 'erc-dcc
 919   :type 'integer)
 920
 921 (defvar erc-dcc-file-name nil)
 922 (make-variable-buffer-local 'erc-dcc-file-name)
 923
 924 (defun erc-dcc-get-file (entry file parent-proc)
 925   "This function does the work of setting up a transfer from the remote client
 926 to the local one over a tcp connection. This involves setting up a process
 927 filter and a process sentinel, and making the connection."
 928   (let* ((buffer (generate-new-buffer (file-name-nondirectory file)))
 929          proc)
 930     (with-current-buffer buffer
 931       (fundamental-mode)
 932       (buffer-disable-undo (current-buffer))
 933       ;; This is necessary to have the buffer saved as-is in GNU
 934       ;; Emacs.
 935       ;; XEmacs change: We don't have `set-buffer-multibyte', setting
 936       ;; coding system to 'binary below takes care of us.
 937       (when (fboundp 'set-buffer-multibyte)
 938         (set-buffer-multibyte nil))
 939
 940       (setq mode-line-process '(":%s")
 941             buffer-read-only t)
 942       (setq erc-dcc-file-name file)
 943
 944       ;; Truncate the given file to size 0 before appending to it.
 945       (let ((inhibit-file-name-handlers
 946              (append '(jka-compr-handler image-file-handler)
 947                      inhibit-file-name-handlers))
 948             (inhibit-file-name-operation 'write-region))
 949         (write-region (point) (point) erc-dcc-file-name nil 'nomessage))
 950
 951       (setq erc-server-process parent-proc
 952             erc-dcc-entry-data entry)
 953       (setq erc-dcc-byte-count 0)
 954       (setq proc
 955             (funcall erc-dcc-connect-function
 956                      "dcc-get" buffer
 957                      (plist-get entry :ip)
 958                      (string-to-number (plist-get entry :port))
 959                      entry))
 960       (set-process-buffer proc buffer)
 961       (set-process-coding-system proc 'binary 'binary)
 962       (set-buffer-file-coding-system 'binary t)
 963
 964       (set-process-filter proc 'erc-dcc-get-filter)
 965       (set-process-sentinel proc 'erc-dcc-get-sentinel)
 966       (setq entry (plist-put entry :start-time (erc-current-time)))
 967       (setq entry (plist-put entry :peer proc)))))
 968
 969 (defun erc-dcc-append-contents (buffer file)
 970   "Append the contents of BUFFER to FILE.
 971 The contents of the BUFFER will then be erased."
 972   (with-current-buffer buffer
 973     (let ((coding-system-for-write 'binary)
 974           (inhibit-read-only t)
 975           (inhibit-file-name-handlers
 976            (append '(jka-compr-handler image-file-handler)
 977                    inhibit-file-name-handlers))
 978           (inhibit-file-name-operation 'write-region))
 979       (write-region (point-min) (point-max) erc-dcc-file-name t 'nomessage)
 980       (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count))
 981       (erase-buffer))))
 982
 983 (defun erc-dcc-get-filter (proc str)
 984   "This is the process filter for transfers from other clients to this one.
 985 It reads incoming bytes from the network and stores them in the DCC
 986 buffer, and sends back the replies after each block of data per the DCC
 987 protocol spec.  Well not really.  We write back a reply after each read,
 988 rather than every 1024 byte block, but nobody seems to care."
 989   (with-current-buffer (process-buffer proc)
 990     (let ((inhibit-read-only t)
 991           received-bytes)
 992       (goto-char (point-max))
 993       (insert (string-make-unibyte str))
 994
 995       (when (> (point-max) erc-dcc-receive-cache)
 996         (erc-dcc-append-contents (current-buffer) erc-dcc-file-name))
 997       (setq received-bytes (+ (buffer-size) erc-dcc-byte-count))
 998
 999       (and erc-dcc-verbose
1000            (erc-display-message
1001             nil 'notice erc-server-process
1002             'dcc-get-bytes-received
1003             ?f (file-name-nondirectory buffer-file-name)
1004             ?b (number-to-string received-bytes)))
1005       (cond
1006        ((and (> (plist-get erc-dcc-entry-data :size) 0)
1007              (> received-bytes (plist-get erc-dcc-entry-data :size)))
1008         (erc-display-message
1009          nil '(notice error) 'active
1010          'dcc-get-file-too-long
1011          ?f (file-name-nondirectory buffer-file-name))
1012         (delete-process proc))
1013        (t
1014         (process-send-string
1015          proc (erc-pack-int received-bytes)))))))
1016
1017
1018 (defun erc-dcc-get-sentinel (proc event)
1019   "This is the process sentinel for CTCP DCC SEND connections.
1020 It shuts down the connection and notifies the user that the
1021 transfer is complete."
1022   ;; FIXME, we should look at EVENT, and also check size.
1023   (with-current-buffer (process-buffer proc)
1024     (delete-process proc)
1025     (setq erc-dcc-list (delete erc-dcc-entry-data erc-dcc-list))
1026     (unless (= (point-min) (point-max))
1027       (erc-dcc-append-contents (current-buffer) erc-dcc-file-name))
1028     (erc-display-message
1029      nil 'notice erc-server-process
1030      'dcc-get-complete
1031      ?f erc-dcc-file-name
1032      ?s (number-to-string erc-dcc-byte-count)
1033      ?t (format "%.0f"
1034                 (erc-time-diff (plist-get erc-dcc-entry-data :start-time)
1035                                (erc-current-time)))))
1036   (kill-buffer (process-buffer proc))
1037   (delete-process proc))
1038
1039 ;;; CHAT handling
1040
1041 (defcustom erc-dcc-chat-buffer-name-format "DCC-CHAT-%s"
1042   "Format to use for DCC Chat buffer names."
1043   :group 'erc-dcc
1044   :type 'string)
1045
1046 (defcustom erc-dcc-chat-mode-hook nil
1047   "Hook calls when `erc-dcc-chat-mode' finished setting up the buffer."
1048   :group 'erc-dcc
1049   :type 'hook)
1050
1051 (defcustom erc-dcc-chat-connect-hook nil
1052   ""
1053   :group 'erc-dcc
1054   :type 'hook)
1055
1056 (defcustom erc-dcc-chat-exit-hook nil
1057   ""
1058   :group 'erc-dcc
1059   :type 'hook)
1060
1061 (defun erc-cmd-CREQ (line &optional force)
1062   "Set or get the DCC chat request flag.
1063 Possible values are: ask, auto, ignore."
1064   (when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line)
1065     (let ((cmd (match-string 1 line)))
1066       (if (stringp cmd)
1067           (erc-display-message
1068            nil 'notice 'active
1069            (format "Set DCC Chat requests to %S"
1070                    (setq erc-dcc-chat-request (intern cmd))))
1071         (erc-display-message nil 'notice 'active
1072                              (format "DCC Chat requests are set to %S"
1073                                      erc-dcc-chat-request)))
1074       t)))
1075
1076 (defun erc-cmd-SREQ (line &optional force)
1077   "Set or get the DCC send request flag.
1078 Possible values are: ask, auto, ignore."
1079   (when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line)
1080     (let ((cmd (match-string 1 line)))
1081       (if (stringp cmd)
1082           (erc-display-message
1083            nil 'notice 'active
1084            (format "Set DCC Send requests to %S"
1085                    (setq erc-dcc-send-request (intern cmd))))
1086         (erc-display-message nil 'notice 'active
1087                              (format "DCC Send requests are set to %S"
1088                                      erc-dcc-send-request)))
1089       t)))
1090
1091 (defun pcomplete/erc-mode/CREQ ()
1092   (pcomplete-here '("auto" "ask" "ignore")))
1093 (defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ)
1094
1095 (defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output)
1096   "Abnormal hook run after parsing (and maybe inserting) a DCC message.
1097 Each function is called with two arguments: the ERC process and
1098 the unprocessed output.")
1099
1100 (define-obsolete-variable-alias 'erc-dcc-chat-filter-hook
1101   'erc-dcc-chat-filter-functions "24.3")
1102
1103 (defvar erc-dcc-chat-mode-map
1104   (let ((map (make-sparse-keymap)))
1105     (define-key map (kbd "RET") 'erc-send-current-line)
1106     (define-key map "\t" 'completion-at-point)
1107     map)
1108   "Keymap for `erc-dcc-mode'.")
1109
1110 (define-derived-mode erc-dcc-chat-mode fundamental-mode "DCC-Chat"
1111   "Major mode for wasting time via DCC chat."
1112   (setq mode-line-process '(":%s")
1113         erc-send-input-line-function 'erc-dcc-chat-send-input-line
1114         erc-default-recipients '(dcc))
1115   (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
1116
1117 (defun erc-dcc-chat-send-input-line (recipient line &optional force)
1118   "Send LINE to the remote end.
1119 Argument RECIPIENT should always be the symbol dcc, and force
1120 is ignored."
1121   ;; FIXME: We need to get rid of all force arguments one day!
1122   (if (eq recipient 'dcc)
1123       (process-send-string
1124        (get-buffer-process (current-buffer)) line)
1125     (error "erc-dcc-chat-send-input-line in %s" (current-buffer))))
1126
1127 (defun erc-dcc-chat (nick &optional pproc)
1128   "Open a socket for incoming connections, and send a chat request to the
1129 other client."
1130   (interactive "sNick: ")
1131   (when (null pproc) (if (processp erc-server-process)
1132                          (setq pproc erc-server-process)
1133                        (error "Can not find parent process")))
1134   (let* ((sproc (erc-dcc-server "dcc-chat-out"
1135                                 'erc-dcc-chat-filter
1136                                 'erc-dcc-chat-sentinel))
1137          (contact (process-contact sproc)))
1138     (erc-dcc-list-add 'OCHAT nick sproc pproc)
1139     (process-send-string pproc
1140      (format "PRIVMSG %s :\C-aDCC CHAT chat %s %d\C-a\n"
1141              nick
1142              (erc-ip-to-decimal (nth 0 contact)) (nth 1 contact)))))
1143
1144 (defvar erc-dcc-from)
1145 (make-variable-buffer-local 'erc-dcc-from)
1146
1147 (defvar erc-dcc-unprocessed-output)
1148 (make-variable-buffer-local 'erc-dcc-unprocessed-output)
1149
1150 (defun erc-dcc-chat-setup (entry)
1151   "Setup a DCC chat buffer, returning the buffer."
1152   (let* ((nick (erc-extract-nick (plist-get entry :nick)))
1153          (buffer (generate-new-buffer
1154                   (format erc-dcc-chat-buffer-name-format nick)))
1155          (proc (plist-get entry :peer))
1156          (parent-proc (plist-get entry :parent)))
1157     (erc-setup-buffer buffer)
1158     ;; buffer is now the current buffer.
1159     (erc-dcc-chat-mode)
1160     (setq erc-server-process parent-proc)
1161     (setq erc-dcc-from nick)
1162     (setq erc-dcc-entry-data entry)
1163     (setq erc-dcc-unprocessed-output "")
1164     (setq erc-insert-marker (point-max-marker))
1165     (setq erc-input-marker (make-marker))
1166     (erc-display-prompt buffer (point-max))
1167     (set-process-buffer proc buffer)
1168     (add-hook 'kill-buffer-hook 'erc-dcc-chat-buffer-killed nil t)
1169     (run-hook-with-args 'erc-dcc-chat-connect-hook proc)
1170     buffer))
1171
1172 (defun erc-dcc-chat-accept (entry parent-proc)
1173   "Accept an incoming DCC connection and open a DCC window"
1174   (let* ((nick (erc-extract-nick (plist-get entry :nick)))
1175          buffer proc)
1176     (setq proc
1177           (funcall erc-dcc-connect-function
1178                    "dcc-chat" nil
1179                    (plist-get entry :ip)
1180                    (string-to-number (plist-get entry :port))
1181                    entry))
1182     ;; XXX: connected, should we kill the ip/port properties?
1183     (setq entry (plist-put entry :peer proc))
1184     (setq entry (plist-put entry :parent parent-proc))
1185     (set-process-filter proc 'erc-dcc-chat-filter)
1186     (set-process-sentinel proc 'erc-dcc-chat-sentinel)
1187     (setq buffer (erc-dcc-chat-setup entry))))
1188
1189 (defun erc-dcc-chat-filter (proc str)
1190   (let ((orig-buffer (current-buffer)))
1191     (unwind-protect
1192         (progn
1193           (set-buffer (process-buffer proc))
1194           (setq erc-dcc-unprocessed-output
1195                 (concat erc-dcc-unprocessed-output str))
1196           (run-hook-with-args 'erc-dcc-chat-filter-functions
1197                               proc erc-dcc-unprocessed-output))
1198       (set-buffer orig-buffer))))
1199
1200 (defun erc-dcc-chat-parse-output (proc str)
1201   (save-match-data
1202     (let ((posn 0)
1203           line)
1204       (while (string-match "\n" str posn)
1205         (setq line (substring str posn (match-beginning 0)))
1206         (setq posn (match-end 0))
1207         (erc-display-message
1208          nil nil proc
1209          'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'font-lock-face
1210                                               'erc-nick-default-face) ?m line))
1211       (setq erc-dcc-unprocessed-output (substring str posn)))))
1212
1213 (defun erc-dcc-chat-buffer-killed ()
1214   (erc-dcc-chat-close "killed buffer"))
1215
1216 (defun erc-dcc-chat-close (&optional event)
1217   "Close a DCC chat, removing any associated processes and tidying up
1218 `erc-dcc-list'"
1219   (let ((proc (plist-get erc-dcc-entry-data :peer))
1220         (evt (or event "")))
1221     (when proc
1222       (setq erc-dcc-list (delq erc-dcc-entry-data erc-dcc-list))
1223       (run-hook-with-args 'erc-dcc-chat-exit-hook proc)
1224       (delete-process proc)
1225       (erc-display-message
1226        nil 'notice erc-server-process
1227        'dcc-chat-ended ?n erc-dcc-from ?t (current-time-string) ?e evt)
1228       (setq erc-dcc-entry-data (plist-put erc-dcc-entry-data :peer nil)))))
1229
1230 (defun erc-dcc-chat-sentinel (proc event)
1231   (let ((buf (current-buffer))
1232         (elt (erc-dcc-member :peer proc)))
1233     ;; the sentinel is also notified when the connection is opened, so don't
1234     ;; immediately kill it again
1235     ;(message "buf %s elt %S evt %S" buf elt event)
1236     (unwind-protect
1237         (if (string-match "^open from" event)
1238             (erc-dcc-chat-setup elt)
1239           (erc-dcc-chat-close event))
1240       (set-buffer buf))))
1241
1242 (defun erc-dcc-no-such-nick (proc parsed)
1243   "Detect and handle no-such-nick replies from the IRC server."
1244   (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed))
1245                               :parent proc))
1246          (peer (plist-get elt :peer)))
1247     (when (or (and (processp peer) (not (eq (process-status peer) 'open)))
1248               elt)
1249       ;; Since we already created an entry before sending the CTCP
1250       ;; message, we now remove it, if it doesn't point to a process
1251       ;; which is already open.
1252       (setq erc-dcc-list (delq elt erc-dcc-list))
1253       (if (processp peer) (delete-process peer)))
1254     nil))
1255
1256 (provide 'erc-dcc)
1257
1258 ;;; erc-dcc.el ends here
1259 ;;
1260 ;; Local Variables:
1261 ;; generated-autoload-file: "erc-loaddefs.el"
1262 ;; indent-tabs-mode: nil
1263 ;; End: