lisp/erc/erc-dcc.el

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