code.delx.au - gnu-emacs/blob - lisp/erc/erc-dcc.el

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