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