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-enqueue-request (type &rest args)
  52   (let ((request (apply #'make-liece-dcc-object :type type args)))
  53     (inline (queue-enqueue liece-dcc-requests request))))
  54
  55 (defun liece-dcc-dequeue-request (&optional type)
  56   (when (or (not type)
  57             (eq (liece-dcc-object-type
  58                  (queue-first liece-dcc-requests))
  59                 type))
  60     (inline (queue-dequeue liece-dcc-requests))))
  61
  62 (defmacro liece-dcc-add-to-process-alist (process type &rest args)
  63   `(push (cons (process-name ,process)
  64                (make-liece-dcc-object :type ,type ,@args))
  65          liece-dcc-process-alist))
  66
  67 (defmacro liece-dcc-get-process-object (process)
  68   `(cdr (assoc (process-name ,process) liece-dcc-process-alist)))
  69
  70 (defmacro liece-dcc-message (&rest msg)
  71   `(message "DCC %s" (format ,@msg)))
  72
  73 (defun* liece-ctcp-dcc-message (from chnl rest)
  74   (cond
  75    ((string-match "^SEND +" rest)
  76     (multiple-value-bind (filename host port size)
  77         (split-string (substring rest (match-end 0)))
  78       (setq filename (file-name-nondirectory filename))
  79       (liece-insert-dcc
  80        (append liece-O-buffer liece-D-buffer)
  81        (format (_ "SEND request from %s: %s (%s bytes)\n")
  82                from filename size))
  83       (liece-dcc-enqueue-request
  84        'send :from from :host host :port port :file filename :size size)
  85       (when liece-dcc-receive-direct
  86         (liece-insert-dcc
  87          (append liece-O-buffer liece-D-buffer)
  88          (format (_ "SEND applied autoreceive: %s (%s bytes)\n")
  89                  filename size))
  90         (liece-command-dcc-receive))))
  91    ((string-match "^CHAT [^ ]+ +" rest)
  92     (multiple-value-bind (host port)
  93         (split-string (substring rest (match-end 0)))
  94       (liece-dcc-enqueue-request 'chat :from from :host host :port port)
  95       (liece-insert-dcc
  96        (append liece-O-buffer liece-D-buffer)
  97        (concat "CHAT request from " from "\n"))))))
  98
  99 (defun liece-command-dcc-send (filename towhom)
 100   "Send file to user."
 101   (interactive
 102    (list (expand-file-name
 103           (read-file-name
 104            (_ "File to send: ")
 105            default-directory nil))
 106          (liece-minibuffer-completing-default-read
 107           (_ "To whom: ")
 108           (append liece-nick-alist liece-channel-alist)
 109           nil nil liece-privmsg-partner)))
 110
 111   (setq liece-privmsg-partner towhom)
 112   (let (process)
 113     (setq process (start-process
 114                    liece-dcc-program nil liece-dcc-program
 115                    "send" (int-to-string liece-dcc-port) filename))
 116     (set-process-filter process #'liece-dcc-send-filter)
 117     (set-process-sentinel process #'liece-dcc-sentinel))
 118   (or (zerop liece-dcc-port)
 119       (incf liece-dcc-port)))
 120
 121 (defun liece-dcc-sentinel (process output)
 122   (let* ((object (liece-dcc-get-process-object process))
 123          (type (liece-dcc-object-type object)))
 124     (if (null object)
 125         (delete-process process)
 126       (if (string-match "^finished" output)
 127           (cond
 128            ((eq type 'send)
 129             (liece-dcc-message (_ "Sent file to %s: %s (%s bytes)")
 130                                (liece-dcc-object-from object)
 131                                (liece-dcc-object-file object)
 132                                (liece-dcc-object-size object)))
 133            ((eq type 'receive)
 134             (liece-dcc-message (_ "Received file from %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 'chat)
 139             (liece-dcc-message (_ "Chat connection with %s finished")
 140                                (liece-dcc-object-from object))))
 141         (liece-dcc-message
 142          (_ "%s error (%s %s %s) is %s\n")
 143          (capitalize (downcase (prin1-to-string
 144                                 (liece-dcc-object-type object))))
 145          (or (liece-dcc-object-file object) "")
 146          (cond ((eq type 'send) "to")
 147                ((eq type 'receive) "from")
 148                ((eq type 'chat) "with"))
 149          (liece-dcc-object-from object)
 150          (substring output 0 (1- (length output))))))))
 151
 152 (defun liece-dcc-send-filter (process output)
 153   (if (string-match "DCC send +" output)
 154       (multiple-value-bind (filename port host size)
 155           (split-string (substring output (match-end 0)))
 156         (setq filename (file-name-nondirectory filename))
 157         (liece-send "PRIVMSG %s :\001DCC SEND %s %s %s %s\001"
 158                     liece-privmsg-partner filename host port size)
 159         (liece-dcc-message (_ "Sending file to %s: %s (%s bytes)")
 160                            liece-privmsg-partner filename size)
 161         (liece-dcc-add-to-process-alist process 'send
 162                                         :host host
 163                                         :port port
 164                                         :from liece-privmsg-partner
 165                                         :file filename
 166                                         :size size))
 167     (liece-dcc-message (_ "send error to %s: %s")
 168                        liece-privmsg-partner
 169                        (substring output 0 (1- (length output))))))
 170
 171 (defmacro liece-dcc-prepare-directory ()
 172   '(or (file-directory-p (expand-file-name liece-dcc-directory))
 173        (and (y-or-n-p (_ "DCC directory does not exist. Create it? "))
 174             (make-directory (expand-file-name liece-dcc-directory)))))
 175
 176 (defun liece-command-dcc-receive (&optional number)
 177   "Receive next file from list."
 178   (interactive "P")
 179   (let ((object (liece-dcc-dequeue-request 'send)))
 180     (if (not object)
 181         (liece-message (_ "DCC No send request has been arrived."))
 182       (liece-dcc-message (_ "Getting file from %s: %s (%s bytes)")
 183                           (liece-dcc-object-from object)
 184                           (liece-dcc-object-file object)
 185                           (liece-dcc-object-size object))
 186       (liece-dcc-prepare-directory)
 187       (let ((file
 188              (expand-file-name
 189               (liece-dcc-object-file object)
 190               liece-dcc-directory))
 191             process)
 192         (setq process
 193               (start-process
 194                liece-dcc-program nil liece-dcc-program
 195                "receive"
 196                (liece-dcc-object-host object)
 197                (liece-dcc-object-port object)
 198                (liece-dcc-object-size object)
 199                (expand-file-name
 200                 (liece-dcc-object-file object)
 201                 liece-dcc-directory)))
 202         (set-process-filter process #'liece-dcc-receive-filter)
 203         (set-process-sentinel process  #'liece-dcc-sentinel)
 204         (liece-dcc-add-to-process-alist
 205          process 'receive
 206          :from (liece-dcc-object-from object)
 207          :host (liece-dcc-object-host object)
 208          :port (liece-dcc-object-port object)
 209          :file file
 210          :size (liece-dcc-object-size object))))))
 211
 212 (defun liece-dcc-receive-filter (process output)
 213   (liece-dcc-message "%s" (substring output 0 (1- (length output)))))
 214
 215 (defun liece-command-dcc-chat-listen (towhom)
 216   (interactive
 217    (list (liece-minibuffer-completing-default-read
 218           (_ "With whom: ")
 219           (append liece-nick-alist liece-channel-alist)
 220           nil nil liece-privmsg-partner)))
 221   (setq liece-privmsg-partner towhom)
 222   (let (process)
 223     (as-binary-process
 224      (setq process
 225            (start-process
 226             liece-dcc-program nil
 227             liece-dcc-program "chat" "listen"
 228             (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       (as-binary-process
 272        (setq process
 273              (start-process liece-dcc-program nil
 274                             liece-dcc-program "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