lisp/erc/erc-dcc.el

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