lisp/liece-dcc.el

   1 ;;; liece-dcc.el --- DCC handlers and commands.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1998-11-25
   7 ;; Keywords: IRC, liece, DCC
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'liece-intl)
  34   (require 'liece-inlines)
  35   (require 'liece-channel))
  36
  37 (eval-when-compile (require 'queue-m))
  38
  39 (require 'liece-coding)
  40 (require 'liece-misc)
  41 (require 'liece-minibuf)
  42
  43 (defvar liece-dcc-requests (queue-create))
  44 (defvar liece-dcc-receive-direct t)
  45 (defvar liece-dcc-process-alist nil)
  46
  47 (defconst liece-dcc-acceptable-messages '("SEND" "CHAT"))
  48
  49 (defstruct liece-dcc-object type from host port file size)
  50
  51 (defun liece-dcc-start-process (args)
  52   (let ((program
  53          (or (car-safe liece-dcc-program)
  54              liece-dcc-program)))
  55     (apply #'start-process " *DCC*" nil program args)))
  56
  57 (defun liece-dcc-enqueue-request (type &rest args)
  58   (let ((request (apply #'make-liece-dcc-object :type type args)))
  59     (inline (queue-enqueue liece-dcc-requests request))))
  60
  61 (defun liece-dcc-dequeue-request (&optional type)
  62   (when (or (not type)
  63             (eq (liece-dcc-object-type
  64                  (queue-first liece-dcc-requests))
  65                 type))
  66     (inline (queue-dequeue liece-dcc-requests))))
  67
  68 (defmacro liece-dcc-add-to-process-alist (process type &rest args)
  69   `(push (cons (process-name ,process)
  70                (make-liece-dcc-object :type ,type ,@args))
  71          liece-dcc-process-alist))
  72
  73 (defmacro liece-dcc-get-process-object (process)
  74   `(cdr (assoc (process-name ,process) liece-dcc-process-alist)))
  75
  76 (defmacro liece-dcc-message (&rest msg)
  77   `(message "DCC %s" (format ,@msg)))
  78
  79 (defun* liece-ctcp-dcc-message (from chnl rest)
  80   (cond
  81    ((string-match "^SEND +" rest)
  82     (multiple-value-bind (filename host port size)
  83         (split-string (substring rest (match-end 0)))
  84       (setq filename (file-name-nondirectory filename))
  85       (liece-insert-dcc
  86        (append liece-O-buffer liece-D-buffer)
  87        (format (_ "SEND request from %s: %s (%s bytes)\n")
  88                from filename size))
  89       (liece-dcc-enqueue-request
  90        'send :from from :host host :port port :file filename :size size)
  91       (when liece-dcc-receive-direct
  92         (liece-insert-dcc
  93          (append liece-O-buffer liece-D-buffer)
  94          (format (_ "SEND applied autoreceive: %s (%s bytes)\n")
  95                  filename size))
  96         (liece-command-dcc-receive))))
  97    ((string-match "^CHAT [^ ]+ +" rest)
  98     (multiple-value-bind (host port)
  99         (split-string (substring rest (match-end 0)))
 100       (liece-dcc-enqueue-request 'chat :from from :host host :port port)
 101       (liece-insert-dcc
 102        (append liece-O-buffer liece-D-buffer)
 103        (concat "CHAT request from " from "\n"))))))
 104
 105 (defun liece-command-dcc-send (filename towhom)
 106   "Send file to user."
 107   (interactive
 108    (list (expand-file-name
 109           (read-file-name
 110            (_ "File to send: ")
 111            default-directory nil))
 112          (liece-minibuffer-completing-read
 113           (_ "To whom: ")
 114           (append liece-nick-alist liece-channel-alist)
 115           nil nil nil nil liece-privmsg-partner)))
 116
 117   (setq liece-privmsg-partner towhom)
 118   (let ((process
 119          (liece-dcc-start-process
 120           (list "send" (int-to-string liece-dcc-port) filename))))
 121     (set-process-filter process #'liece-dcc-send-filter)
 122     (set-process-sentinel process #'liece-dcc-sentinel))
 123   (or (zerop liece-dcc-port)
 124       (incf liece-dcc-port)))
 125
 126 (defun liece-dcc-sentinel (process output)
 127   (let* ((object (liece-dcc-get-process-object process))
 128          (type (liece-dcc-object-type object)))
 129     (if (null object)
 130         (delete-process process)
 131       (if (string-match "^finished" output)
 132           (cond
 133            ((eq type 'send)
 134             (liece-dcc-message (_ "Sent file to %s: %s (%s bytes)")
 135                                (liece-dcc-object-from object)
 136                                (liece-dcc-object-file object)
 137                                (liece-dcc-object-size object)))
 138            ((eq type 'receive)
 139             (liece-dcc-message (_ "Received file from %s: %s (%s bytes)")
 140                                (liece-dcc-object-from object)
 141                                (liece-dcc-object-file object)
 142                                (liece-dcc-object-size object)))
 143            ((eq type 'chat)
 144             (liece-dcc-message (_ "Chat connection with %s finished")
 145                                (liece-dcc-object-from object))))
 146         (liece-dcc-message
 147          (_ "%s error (%s %s %s) is %s\n")
 148          (capitalize (downcase (prin1-to-string
 149                                 (liece-dcc-object-type object))))
 150          (or (liece-dcc-object-file object) "")
 151          (cond ((eq type 'send) "to")
 152                ((eq type 'receive) "from")
 153                ((eq type 'chat) "with"))
 154          (liece-dcc-object-from object)
 155          (substring output 0 (1- (length output))))))))
 156
 157 (defun liece-dcc-send-filter (process output)
 158   (if (string-match "DCC send +" output)
 159       (multiple-value-bind (filename port host size)
 160           (split-string (substring output (match-end 0)))
 161         (setq filename (file-name-nondirectory filename))
 162         (liece-send "PRIVMSG %s :\001DCC SEND %s %s %s %s\001"
 163                     liece-privmsg-partner filename host port size)
 164         (liece-dcc-message (_ "Sending file to %s: %s (%s bytes)")
 165                            liece-privmsg-partner filename size)
 166         (liece-dcc-add-to-process-alist process 'send
 167                                         :host host
 168                                         :port port
 169                                         :from liece-privmsg-partner
 170                                         :file filename
 171                                         :size size))
 172     (liece-dcc-message (_ "send error to %s: %s")
 173                        liece-privmsg-partner
 174                        (substring output 0 (1- (length output))))))
 175
 176 (defmacro liece-dcc-prepare-directory ()
 177   '(or (file-directory-p (expand-file-name liece-dcc-directory))
 178        (and (y-or-n-p (_ "DCC directory does not exist. Create it? "))
 179             (make-directory (expand-file-name liece-dcc-directory)))))
 180
 181 (defun liece-command-dcc-receive (&optional number)
 182   "Receive next file from list."
 183   (interactive "P")
 184   (let ((object (liece-dcc-dequeue-request 'send)))
 185     (if (not object)
 186         (liece-message (_ "DCC No send request has been arrived."))
 187       (liece-dcc-message (_ "Getting file from %s: %s (%s bytes)")
 188                           (liece-dcc-object-from object)
 189                           (liece-dcc-object-file object)
 190                           (liece-dcc-object-size object))
 191       (liece-dcc-prepare-directory)
 192       (let ((file
 193              (expand-file-name
 194               (liece-dcc-object-file object)
 195               liece-dcc-directory))
 196             (process
 197              (liece-dcc-start-process
 198               (list "receive"
 199                     (liece-dcc-object-host object)
 200                     (liece-dcc-object-port object)
 201                     (liece-dcc-object-size object)
 202                     (expand-file-name
 203                      (liece-dcc-object-file object)
 204                      liece-dcc-directory)))))
 205         (set-process-filter process #'liece-dcc-receive-filter)
 206         (set-process-sentinel process  #'liece-dcc-sentinel)
 207         (liece-dcc-add-to-process-alist
 208          process 'receive
 209          :from (liece-dcc-object-from object)
 210          :host (liece-dcc-object-host object)
 211          :port (liece-dcc-object-port object)
 212          :file file
 213          :size (liece-dcc-object-size object))))))
 214
 215 (defun liece-dcc-receive-filter (process output)
 216   (liece-dcc-message "%s" (substring output 0 (1- (length output)))))
 217
 218 (defun liece-command-dcc-chat-listen (towhom)
 219   (interactive
 220    (list (liece-minibuffer-completing-read
 221           (_ "With whom: ")
 222           (append liece-nick-alist liece-channel-alist)
 223           nil nil nil nil liece-privmsg-partner)))
 224   (setq liece-privmsg-partner towhom)
 225   (let ((process
 226          (as-binary-process
 227           (liece-dcc-start-process
 228            (list "chat" "listen" (int-to-string liece-dcc-port))))))
 229     (set-process-buffer
 230      process
 231      (liece-get-buffer-create (format " DCC:%s" (process-id process))))
 232     (set-process-filter process 'liece-dcc-chat-listen-filter)
 233     (set-process-sentinel process 'liece-dcc-sentinel))
 234   (unless (zerop liece-dcc-port)
 235     (setq liece-dcc-port (1+ liece-dcc-port))))
 236
 237 (defun liece-dcc-chat-listen-filter (process output)
 238   (cond
 239    ((string-match "DCC chat +" output)
 240     (multiple-value-bind (host port)
 241         (split-string (substring output (match-end 0)))
 242       (liece-send "PRIVMSG %s :\001DCC CHAT chat %s %s\001"
 243                   liece-privmsg-partner host port)
 244       (liece-dcc-message (_ "Ringing user %s")
 245                          liece-privmsg-partner)
 246       (liece-dcc-add-to-process-alist
 247        process 'chat :from liece-privmsg-partner)))
 248    ((string-match "^DCC chat established" output)
 249     (set-process-filter process 'liece-dcc-chat-filter)
 250     (let* ((object (liece-dcc-get-process-object process))
 251            (nick (liece-dcc-object-from object)))
 252       (setq nick (liece-channel-prepare-representation nick 'dcc))
 253       (liece-channel-prepare-partner nick)
 254       (liece-dcc-message (_ "Chat connection established with: %s")
 255                          nick))
 256     (message ""))
 257    (t
 258     (liece-dcc-message (_ "listen error to %s: %s")
 259                        liece-privmsg-partner
 260                        (substring output 0 (1- (length output)))))))
 261
 262 (defun liece-command-dcc-chat-connect (&optional number)
 263   (interactive "P")
 264   (let* ((object (liece-dcc-dequeue-request 'chat))
 265          (nick (liece-dcc-object-from object))
 266          process)
 267     (if (not object)
 268         (liece-message (_ "DCC No chat request has been arrived."))
 269       (liece-dcc-message (_ "Connecting to: %s") nick)
 270       (setq liece-privmsg-partner nick)
 271       (setq process
 272             (as-binary-process
 273              (liece-dcc-start-process
 274               (list "chat" "connect"
 275                     (liece-dcc-object-host object)
 276                     (liece-dcc-object-port object)))))
 277       (set-process-buffer
 278        process
 279        (liece-get-buffer-create
 280         (format " DCC:%s" (process-id process))))
 281       (set-process-filter process #'liece-dcc-chat-connect-filter)
 282       (set-process-sentinel process #'liece-dcc-sentinel)
 283       (liece-dcc-add-to-process-alist
 284        process 'chat :from liece-privmsg-partner))))
 285
 286 (defun liece-dcc-chat-connect-filter (process output)
 287   (if (string-match "^DCC chat established" output)
 288       (let* ((object (liece-dcc-get-process-object process))
 289              (nick (liece-dcc-object-from object)))
 290         (set-process-filter process #'liece-dcc-chat-filter)
 291         (setq nick (liece-channel-prepare-representation nick 'dcc))
 292         (liece-channel-prepare-partner nick)
 293         (liece-dcc-message (_ "Chat connection established with: %s")
 294                            nick)
 295         (message ""))
 296     (liece-dcc-message
 297      (_ "connect error to %s: %s")
 298      liece-privmsg-partner
 299      (substring output 0 (1- (length output))))))
 300
 301 (defun liece-dcc-chat-filter (process output)
 302   (save-match-data
 303     (with-current-buffer (process-buffer process)
 304       (let* ((object (liece-dcc-get-process-object process))
 305              (nick (liece-channel-prepare-representation
 306                     (liece-dcc-object-from object) 'dcc)))
 307         (goto-char (point-max))
 308         (insert output)
 309         (goto-char (point-min))
 310         (while (search-forward "\n\n" (point-max) t)
 311           (delete-char -1))
 312         (goto-char (point-min))
 313         (when (string-match "\n" output)
 314           (let (st nd line)
 315             (while (looking-at ".*\n")
 316               (setq st (match-beginning 0) nd (match-end 0)
 317                     line (liece-coding-decode-charset-string
 318                           (buffer-substring st (1- nd))))
 319               (delete-region st nd)
 320               (let ((liece-message-target (liece-current-nickname))
 321                     (liece-message-speaker nick))
 322                 (liece-display-message line)))))))))
 323
 324 (defun liece-dcc-chat-nick-to-process (nick)
 325   "Convert NICK to process symbol."
 326   (let ((alist liece-dcc-process-alist)
 327         pair)
 328     (catch 'found
 329       (while alist
 330         (setq pair (pop alist))
 331         (if (and (eq 'chat (cadr pair))
 332                  (liece-nick-equal nick (caddr pair)))
 333             (throw 'found (car pair))))
 334       nil)))
 335
 336 (defun liece-dcc-chat-send (nick message)
 337   "Send MSG string to NICK via DCC chat."
 338   (let ((process (liece-dcc-chat-nick-to-process nick)))
 339     (if (not process)
 340         (liece-message (_ "DCC chat has not been started."))
 341       (with-current-buffer liece-command-buffer
 342         (setq message (liece-coding-encode-charset-string message)
 343               message (if (string-match "\r$" message) message
 344                         (concat message "\r\n")))
 345         (process-send-string process message)))))
 346
 347 (defun liece-command-dcc-accept ()
 348   "Dispatch one DCC request."
 349   (interactive)
 350   (let* ((object (queue-first liece-dcc-requests))
 351          (type (liece-dcc-object-type object)))
 352     (cond ((eq type 'send)
 353            (liece-command-dcc-receive))
 354           ((eq type 'chat)
 355            (liece-command-dcc-chat-connect))
 356           (t
 357            (liece-message
 358             (_ "DCC No request has been arrived."))))))
 359
 360 (defun liece-command-dcc-list ()
 361   "List files in receive queue."
 362   (interactive)
 363   (if (queue-empty liece-dcc-requests)
 364       (liece-dcc-message (_ "No DCC request here"))
 365     (let ((i 0) (objects (queue-all liece-dcc-requests)) type)
 366       (dolist (object objects)
 367         (setq type (liece-dcc-object-type object))
 368         (cond ((eq type 'send)
 369                (liece-dcc-message
 370                 (_ "(%d) %s request %s: %s (%s bytes)")
 371                 i (upcase (symbol-name type))
 372                 (liece-dcc-object-from object)
 373                 (liece-dcc-object-file object)
 374                 (liece-dcc-object-size object)))
 375               ((eq type 'chat)
 376                (liece-dcc-message
 377                 (_ "(%d) %s request from %s")
 378                 i (upcase (symbol-name type))
 379                 (liece-dcc-object-from object))))
 380         (incf i)))))
 381
 382 (defun liece-dcc-compare-hostnames (h1 h2)
 383   "Compare two internet domain hostnames. Return true iff they resolve to the
 384 same IP-address."
 385   (or
 386    (string-equal-ignore-case h1 h2)
 387    (if liece-dcc-program
 388        (let ((pob (liece-get-buffer-create "*IRC DCC resolve*"))
 389              (output) (domatch nil))
 390          (save-excursion
 391            (call-process liece-dcc-program nil pob nil "resolve" h1 h2)
 392            (set-buffer pob)
 393            (goto-char (point-min))
 394            (setq output (buffer-substring (point-min) (point-max)))
 395            (if (string-match "\\([^ ]+\\)\n\\([^ ]+\\)\n" output)
 396                (if (string= (match-string 1 output)
 397                             (match-string 2 output))
 398                    (setq domatch t))))
 399          (kill-buffer pob)
 400          domatch)
 401      (string-equal-ignore-case h1 h2))))
 402
 403 (provide 'liece-dcc)
 404
 405 ;;; liece-dcc.el ends here