;;; erc-dcc.el --- CTCP DCC module for ERC
-;; Copyright (C) 1993, 1994, 1995, 1998, 2002, 2003, 2004, 2006, 2007, 2008
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2014 Free Software
+;; Foundation, Inc.
;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu>
;; Noah Friedman <friedman@prep.ai.mit.edu>
;; Per Persson <pp@sno.pp.se>
-;; Maintainer: mlang@delysid.org
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: comm, processes
;; Created: 1994-01-23
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'erc)
-(eval-when-compile
- (require 'cl)
- (require 'pcomplete))
+(eval-when-compile (require 'pcomplete))
;;;###autoload (autoload 'erc-dcc-mode "erc-dcc")
(define-erc-module dcc nil
:group 'erc)
(defcustom erc-dcc-verbose nil
- "*If non-nil, be verbose about DCC activity reporting."
+ "If non-nil, be verbose about DCC activity reporting."
:group 'erc-dcc
:type 'boolean)
+(defconst erc-dcc-connection-types
+ '("CHAT" "GET" "SEND")
+ "List of valid DCC connection types.
+All values of the list must be uppercase strings.")
+
(defvar erc-dcc-list nil
"List of DCC connections. Looks like:
((:nick \"nick!user@host\" :type GET :peer proc :parent proc :size size :file file)
(dcc-get-file-too-long
. "DCC: %f: File longer than sender claimed; aborting transfer")
(dcc-get-notfound . "DCC: %n hasn't offered %f for DCC transfer")
- (dcc-list-head . "DCC: From Type Active Size Filename")
- (dcc-list-line . "DCC: -------- ---- ------ ------------ --------")
- (dcc-list-item . "DCC: %-8n %-4t %-6a %-12s %f")
+ (dcc-list-head . "DCC: From Type Active Size Filename")
+ (dcc-list-line . "DCC: -------- ---- ------ -------------- --------")
+ (dcc-list-item . "DCC: %-8n %-4t %-6a %-14s %f")
(dcc-list-end . "DCC: End of list.")
(dcc-malformed . "DCC: error: %n (%u@%h) sent malformed request: %q")
(dcc-privileged-port
result))
(defun erc-pack-int (value)
- "Convert an integer into a packed string."
- (let* ((len (ceiling (/ value 256.0)))
- (str (make-string len ?a))
- (i (1- len)))
- (while (>= i 0)
+ "Convert an integer into a packed string in network byte order,
+which is big-endian."
+ ;; make sure value is not negative
+ (when (< value 0)
+ (error "ERC-DCC (erc-pack-int): packet size is negative"))
+ ;; make sure size is not larger than 4 bytes
+ (let ((len (if (= value 0) 0
+ (ceiling (/ (ceiling (/ (log value) (log 2))) 8.0)))))
+ (when (> len 4)
+ (error "ERC-DCC (erc-pack-int): packet too large")))
+ ;; pack
+ (let ((str (make-string 4 0))
+ (i 3))
+ (while (and (>= i 0) (> value 0))
(aset str i (% value 256))
(setq value (/ value 256))
(setq i (1- i)))
str))
+(defconst erc-most-positive-int-bytes
+ (ceiling (/ (ceiling (/ (log most-positive-fixnum) (log 2))) 8.0))
+ "Maximum number of bytes for a fixnum.")
+
+(defconst erc-most-positive-int-msb
+ (lsh most-positive-fixnum (- 0 (* 8 (1- erc-most-positive-int-bytes))))
+ "Content of the most significant byte of most-positive-fixnum.")
+
(defun erc-unpack-int (str)
"Unpack a packed string into an integer."
- (let ((len (length str))
- (num 0)
- (count 0))
- (while (< count len)
- (setq num (+ num (lsh (aref str (- len count 1)) (* 8 count))))
- (setq count (1+ count)))
- num))
+ (let ((len (length str)))
+ ;; strip leading 0-bytes
+ (let ((start 0))
+ (while (and (> len start) (eq (aref str start) 0))
+ (setq start (1+ start)))
+ (when (> start 0)
+ (setq str (substring str start))
+ (setq len (- len start))))
+ ;; make sure size is not larger than Emacs can handle
+ (when (or (> len (min 4 erc-most-positive-int-bytes))
+ (and (eq len erc-most-positive-int-bytes)
+ (> (aref str 0) erc-most-positive-int-msb)))
+ (error "ERC-DCC (erc-unpack-int): packet to send is too large"))
+ ;; unpack
+ (let ((num 0)
+ (count 0))
+ (while (< count len)
+ (setq num (+ num (lsh (aref str (- len count 1)) (* 8 count))))
+ (setq count (1+ count)))
+ num)))
(defconst erc-dcc-ipv4-regexp
(concat "^"
(* (nth 1 ips) 65536.0)
(* (nth 2 ips) 256.0)
(nth 3 ips))))
- (if (interactive-p)
+ (if (called-interactively-p 'interactive)
(message "%s is %.0f" ip res)
(format "%.0f" res)))))
:valid-regexp erc-dcc-ipv4-regexp)))
(defcustom erc-dcc-send-request 'ask
- "*How to treat incoming DCC Send requests.
+ "How to treat incoming DCC Send requests.
'ask - Report the Send request, and wait for the user to manually accept it
You might want to set `erc-dcc-auto-masks' for this.
'auto - Automatically accept the request and begin downloading the file
(when (fboundp 'set-process-coding-system)
(set-process-coding-system process 'binary 'binary))
(when (fboundp 'set-process-filter-multibyte)
- (set-process-filter-multibyte process nil))))
+ (with-no-warnings ; obsolete since 23.1
+ (set-process-filter-multibyte process nil)))))
(file-error
- (unless (and (string= "Cannot bind server socket" (cadr err))
- (string= "address already in use" (caddr err)))
+ (unless (and (string= "Cannot bind server socket" (nth 1 err))
+ (string= "address already in use" (nth 2 err)))
(signal (car err) (cdr err)))
(setq port (1+ port))
(unless (< port upper)
;;; Interactive command handling
(defcustom erc-dcc-get-default-directory nil
- "*Default directory for incoming DCC file transfers.
+ "Default directory for incoming DCC file transfers.
If this is nil, then the current value of `default-directory' is used."
:group 'erc-dcc
:type '(choice (const nil :tag "Default directory") directory))
(apropos "erc-dcc-do-.*-command")
t))))
+(autoload 'pcomplete-erc-all-nicks "erc-pcomplete")
+
;;;###autoload
(defun pcomplete/erc-mode/DCC ()
"Provides completion for the /DCC command."
(pcomplete-here (append '("chat" "close" "get" "list")
(when (fboundp 'make-network-process) '("send"))))
(pcomplete-here
- (case (intern (downcase (pcomplete-arg 1)))
- (chat (mapcar (lambda (elt) (plist-get elt :nick))
+ (pcase (intern (downcase (pcomplete-arg 1)))
+ (`chat (mapcar (lambda (elt) (plist-get elt :nick))
+ (erc-remove-if-not
+ #'(lambda (elt)
+ (eq (plist-get elt :type) 'CHAT))
+ erc-dcc-list)))
+ (`close (erc-delete-dups
+ (mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
+ erc-dcc-list)))
+ (`get (mapcar #'erc-dcc-nick
(erc-remove-if-not
#'(lambda (elt)
- (eq (plist-get elt :type) 'CHAT))
+ (eq (plist-get elt :type) 'GET))
erc-dcc-list)))
- (close (remove-duplicates
- (mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
- erc-dcc-list) :test 'string=))
- (get (mapcar #'erc-dcc-nick
- (erc-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type) 'GET))
- erc-dcc-list)))
- (send (pcomplete-erc-all-nicks))))
+ (`send (pcomplete-erc-all-nicks))))
(pcomplete-here
- (case (intern (downcase (pcomplete-arg 2)))
- (get (mapcar (lambda (elt) (plist-get elt :file))
- (erc-remove-if-not
- #'(lambda (elt)
- (and (eq (plist-get elt :type) 'GET)
- (erc-nick-equal-p (erc-extract-nick
- (plist-get elt :nick))
- (pcomplete-arg 1))))
- erc-dcc-list)))
- (close (mapcar #'erc-dcc-nick
- (erc-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type)
- (intern (upcase (pcomplete-arg 1)))))
- erc-dcc-list)))
- (send (pcomplete-entries)))))
+ (pcase (intern (downcase (pcomplete-arg 2)))
+ (`get (mapcar (lambda (elt) (plist-get elt :file))
+ (erc-remove-if-not
+ #'(lambda (elt)
+ (and (eq (plist-get elt :type) 'GET)
+ (erc-nick-equal-p (erc-extract-nick
+ (plist-get elt :nick))
+ (pcomplete-arg 1))))
+ erc-dcc-list)))
+ (`close (mapcar #'erc-dcc-nick
+ (erc-remove-if-not
+ #'(lambda (elt)
+ (eq (plist-get elt :type)
+ (intern (upcase (pcomplete-arg 1)))))
+ erc-dcc-list)))
+ (`send (pcomplete-entries)))))
(defun erc-dcc-do-CHAT-command (proc &optional nick)
(when nick
t))))
(defun erc-dcc-do-CLOSE-command (proc &optional type nick)
- "/dcc close type nick
-type and nick are optional."
- ;; FIXME, should also work if only nick is specified
- (when (string-match (concat "^\\s-*\\(\\S-+\\)? *\\("
- erc-valid-nick-regexp "\\)?\\s-*$") line)
- (let ((type (when (match-string 1 line)
- (intern (upcase (match-string 1 line)))))
- (nick (match-string 2 line))
- (ret t))
+ "Close a connection. Usage: /dcc close type nick.
+At least one of TYPE and NICK must be provided."
+ ;; disambiguate type and nick if only one is provided
+ (when (and type (null nick)
+ (not (member (upcase type) erc-dcc-connection-types)))
+ (setq nick type)
+ (setq type nil))
+ ;; validate nick argument
+ (unless (and nick (string-match (concat "\\`" erc-valid-nick-regexp "\\'")
+ nick))
+ (setq nick nil))
+ ;; validate type argument
+ (if (and type (member (upcase type) erc-dcc-connection-types))
+ (setq type (intern (upcase type)))
+ (setq type nil))
+ (when (or nick type)
+ (let ((ret t))
(while ret
- (if nick
- (setq ret (erc-dcc-member :type type :nick nick))
- (setq ret (erc-dcc-member :type type)))
+ (cond ((and nick type)
+ (setq ret (erc-dcc-member :type type :nick nick)))
+ (nick
+ (setq ret (erc-dcc-member :nick nick)))
+ (type
+ (setq ret (erc-dcc-member :type type)))
+ (t
+ (setq ret nil)))
(when ret
;; found a match - delete process if it exists.
(and (processp (plist-get ret :peer))
'dcc-closed
?T (plist-get ret :type)
?n (erc-extract-nick (plist-get ret :nick))))))
- t))
+ t))
(defun erc-dcc-do-GET-command (proc nick &rest file)
"Do a DCC GET command. NICK is the person who is sending the file.
nil '(notice error) 'active
'dcc-get-notfound ?n nick ?f filename))))
+(defvar erc-dcc-byte-count nil)
+(make-variable-buffer-local 'erc-dcc-byte-count)
+
(defun erc-dcc-do-LIST-command (proc)
"This is the handler for the /dcc list command.
It lists the current state of `erc-dcc-list' in an easy to read manner."
(plist-member elt :file)
(buffer-live-p (get-buffer (plist-get elt :file)))
(plist-member elt :size))
- (concat " (" (number-to-string
+ (let ((byte-count (with-current-buffer
+ (get-buffer (plist-get elt :file))
+ (+ (buffer-size) 0.0
+ erc-dcc-byte-count))))
+ (concat " ("
+ (if (= byte-count 0)
+ "0"
+ (number-to-string
+ (truncate
(* 100
- (/ (buffer-size
- (get-buffer (plist-get elt :file)))
- (plist-get elt :size))))
- "%)")))
+ (/ byte-count (plist-get elt :size))))))
+ "%)"))))
?f (or (and (plist-member elt :file) (plist-get elt :file)) "")))
(erc-display-message
nil 'notice 'active
;;;###autoload
(defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC)
- "Hook variable for CTCP DCC queries")
+ "Hook variable for CTCP DCC queries.")
(defvar erc-dcc-query-handler-alist
'(("SEND" . erc-dcc-handle-ctcp-send)
?q query ?n nick ?u login ?h host))))
(defconst erc-dcc-ctcp-query-send-regexp
- "^DCC SEND \\([^ ]+\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")
+ (concat "^DCC SEND \\("
+ ;; Following part matches either filename without spaces
+ ;; or filename enclosed in double quotes with any number
+ ;; of escaped double quotes inside.
+ "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)"
+ "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)"))
+
+(defsubst erc-dcc-unquote-filename (filename)
+ (erc-replace-regexp-in-string "\\\\\\\\" "\\"
+ (erc-replace-regexp-in-string "\\\\\"" "\"" filename t t) t t))
(defun erc-dcc-handle-ctcp-send (proc query nick login host to)
"This is called if a CTCP DCC SEND subcommand is sent to the client.
'dcc-request-bogus
?r "SEND" ?n nick ?u login ?h host))
((string-match erc-dcc-ctcp-query-send-regexp query)
- (let ((filename (match-string 1 query))
- (ip (erc-decimal-to-ip (match-string 2 query)))
- (port (match-string 3 query))
- (size (match-string 4 query)))
+ (let ((filename
+ (or (match-string 5 query)
+ (erc-dcc-unquote-filename (match-string 2 query))))
+ (ip (erc-decimal-to-ip (match-string 6 query)))
+ (port (match-string 7 query))
+ (size (match-string 8 query)))
;; FIXME: a warning really should also be sent
;; if the ip address != the host the dcc sender is on.
(erc-display-message
"^DCC CHAT +chat +\\([0-9]+\\) +\\([0-9]+\\)")
(defcustom erc-dcc-chat-request 'ask
- "*How to treat incoming DCC Chat requests.
+ "How to treat incoming DCC Chat requests.
'ask - Report the Chat request, and wait for the user to manually accept it
'auto - Automatically accept the request and open a new chat window
'ignore - Ignore incoming DCC chat requests completely."
;;; SEND handling
(defcustom erc-dcc-block-size 1024
- "*Block size to use for DCC SEND sessions."
+ "Block size to use for DCC SEND sessions."
:group 'erc-dcc
:type 'integer)
(defcustom erc-dcc-pump-bytes nil
- "*If set to an integer, keep sending until that number of bytes are
+ "If set to an integer, keep sending until that number of bytes are
unconfirmed."
:group 'erc-dcc
:type '(choice (const nil) integer))
(defcustom erc-dcc-send-connect-hook
'(erc-dcc-display-send erc-dcc-send-block)
- "*Hook run whenever the remote end of a DCC SEND offer connected to your
+ "Hook run whenever the remote end of a DCC SEND offer connected to your
listening port."
:group 'erc-dcc
:type 'hook)
(let* ((buffer (erc-dcc-find-file file))
(size (buffer-size buffer))
(start (with-current-buffer buffer
- (set-marker (make-marker) (point-min))))
+ (point-min-marker)))
(sproc (erc-dcc-server "dcc-send"
'erc-dcc-send-filter
'erc-dcc-send-sentinel))
:group 'erc-dcc
:type 'integer)
-(defvar erc-dcc-byte-count nil)
-(make-variable-buffer-local 'erc-dcc-byte-count)
(defvar erc-dcc-file-name nil)
(make-variable-buffer-local 'erc-dcc-file-name)
(set-buffer-multibyte nil))
(setq mode-line-process '(":%s")
- buffer-file-type t
buffer-read-only t)
(setq erc-dcc-file-name file)
;; Truncate the given file to size 0 before appending to it.
- (write-region (point) (point) erc-dcc-file-name nil 'nomessage)
+ (let ((inhibit-file-name-handlers
+ (append '(jka-compr-handler image-file-handler)
+ inhibit-file-name-handlers))
+ (inhibit-file-name-operation 'write-region))
+ (write-region (point) (point) erc-dcc-file-name nil 'nomessage))
(setq erc-server-process parent-proc
erc-dcc-entry-data entry)
"Append the contents of BUFFER to FILE.
The contents of the BUFFER will then be erased."
(with-current-buffer buffer
- (let ((coding-system-for-write 'binary))
+ (let ((coding-system-for-write 'binary)
+ (inhibit-read-only t)
+ (inhibit-file-name-handlers
+ (append '(jka-compr-handler image-file-handler)
+ inhibit-file-name-handlers))
+ (inhibit-file-name-operation 'write-region))
(write-region (point-min) (point-max) erc-dcc-file-name t 'nomessage)
+ (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count))
(erase-buffer))))
(defun erc-dcc-get-filter (proc str)
protocol spec. Well not really. We write back a reply after each read,
rather than every 1024 byte block, but nobody seems to care."
(with-current-buffer (process-buffer proc)
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ received-bytes)
(goto-char (point-max))
(insert (string-make-unibyte str))
- (setq erc-dcc-byte-count (+ (length str) erc-dcc-byte-count))
(when (> (point-max) erc-dcc-receive-cache)
(erc-dcc-append-contents (current-buffer) erc-dcc-file-name))
+ (setq received-bytes (+ (buffer-size) erc-dcc-byte-count))
(and erc-dcc-verbose
(erc-display-message
nil 'notice erc-server-process
'dcc-get-bytes-received
?f (file-name-nondirectory buffer-file-name)
- ?b (number-to-string erc-dcc-byte-count)))
+ ?b (number-to-string received-bytes)))
(cond
((and (> (plist-get erc-dcc-entry-data :size) 0)
- (> erc-dcc-byte-count (plist-get erc-dcc-entry-data :size)))
+ (> received-bytes (plist-get erc-dcc-entry-data :size)))
(erc-display-message
nil '(error notice) 'active
'dcc-get-file-too-long
(delete-process proc))
(t
(process-send-string
- proc (erc-pack-int erc-dcc-byte-count)))))))
+ proc (erc-pack-int received-bytes)))))))
(defun erc-dcc-get-sentinel (proc event)
(delete-process proc)
(setq erc-dcc-list (delete erc-dcc-entry-data erc-dcc-list))
(unless (= (point-min) (point-max))
- (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count))
(erc-dcc-append-contents (current-buffer) erc-dcc-file-name))
(erc-display-message
nil 'notice erc-server-process
;;; CHAT handling
(defcustom erc-dcc-chat-buffer-name-format "DCC-CHAT-%s"
- "*Format to use for DCC Chat buffer names."
+ "Format to use for DCC Chat buffer names."
:group 'erc-dcc
:type 'string)
(defcustom erc-dcc-chat-mode-hook nil
- "*Hook calls when `erc-dcc-chat-mode' finished setting up the buffer."
+ "Hook calls when `erc-dcc-chat-mode' finished setting up the buffer."
:group 'erc-dcc
:type 'hook)
(pcomplete-here '("auto" "ask" "ignore")))
(defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ)
-(defvar erc-dcc-chat-filter-hook '(erc-dcc-chat-parse-output)
- "*Hook to run after doing parsing (and possible insertion) of DCC messages.")
+(defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output)
+ "Abnormal hook run after parsing (and maybe inserting) a DCC message.
+Each function is called with two arguments: the ERC process and
+the unprocessed output.")
+
+(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook
+ 'erc-dcc-chat-filter-functions "24.3")
(defvar erc-dcc-chat-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'erc-send-current-line)
- (define-key map "\t" 'erc-complete-word)
+ (define-key map "\t" 'completion-at-point)
map)
"Keymap for `erc-dcc-mode'.")
-(defun erc-dcc-chat-mode ()
+(define-derived-mode erc-dcc-chat-mode fundamental-mode "DCC-Chat"
"Major mode for wasting time via DCC chat."
- (interactive)
- (kill-all-local-variables)
(setq mode-line-process '(":%s")
- mode-name "DCC-Chat"
- major-mode 'erc-dcc-chat-mode
erc-send-input-line-function 'erc-dcc-chat-send-input-line
erc-default-recipients '(dcc))
- (use-local-map erc-dcc-chat-mode-map)
- (run-hooks 'erc-dcc-chat-mode-hook))
+ (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
(defun erc-dcc-chat-send-input-line (recipient line &optional force)
"Send LINE to the remote end.
(setq erc-dcc-from nick)
(setq erc-dcc-entry-data entry)
(setq erc-dcc-unprocessed-output "")
- (setq erc-insert-marker (set-marker (make-marker) (point-max)))
+ (setq erc-insert-marker (point-max-marker))
(setq erc-input-marker (make-marker))
(erc-display-prompt buffer (point-max))
(set-process-buffer proc buffer)
(set-buffer (process-buffer proc))
(setq erc-dcc-unprocessed-output
(concat erc-dcc-unprocessed-output str))
- (run-hook-with-args 'erc-dcc-chat-filter-hook proc
- erc-dcc-unprocessed-output))
+ (run-hook-with-args 'erc-dcc-chat-filter-functions
+ proc erc-dcc-unprocessed-output))
(set-buffer orig-buffer))))
(defun erc-dcc-chat-parse-output (proc str)
(defun erc-dcc-no-such-nick (proc parsed)
"Detect and handle no-such-nick replies from the IRC server."
- (let* ((elt (erc-dcc-member :nick (second (erc-response.command-args parsed))
+ (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed))
:parent proc))
(peer (plist-get elt :peer)))
(when (or (and (processp peer) (not (eq (process-status peer) 'open)))
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: cda5a6b3-c510-4dbe-b699-84cccfa04edb
HCoop / bpt / emacs.git / blobdiff