cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/liece-ctcp.el

   1 ;;; liece-ctcp.el --- CTCP 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, CTCP
   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 (require 'liece-inlines))
  33 (eval-when-compile (require 'liece-misc))
  34
  35 (require 'liece-handler)
  36
  37 ;; (require 'pccl)
  38
  39 ;; (if-broken ccl-usable
  40 ;;     (require 'liece-q-el)
  41 ;;   (require 'liece-q-ccl))
  42 (require 'liece-q-el)
  43
  44 (require 'liece-x-face)
  45
  46 (autoload 'liece-ctcp-dcc-message "liece-dcc")
  47
  48 (eval-and-compile
  49   (defconst liece-ctcp-supported-symbols
  50     '(version userinfo clientinfo ping time x-face comment help)))
  51
  52 (defun liece-ctcp-make-menu-command-wrapper (symbol)
  53   (fset (intern (format "liece-menu-callback-ctcp-%s" symbol))
  54         `(lambda ()
  55            (interactive)
  56            (dolist (nick liece-nick-region-nicks)
  57              (funcall (symbol-function
  58                        (intern (format "liece-command-ctcp-%s" ',symbol)))
  59                       nick)))))
  60
  61 (dolist (symbol liece-ctcp-supported-symbols)
  62   (liece-ctcp-make-menu-command-wrapper symbol))
  63
  64 (defvar liece-ctcp-message
  65   (eval-when-compile
  66     (concat liece-client-prefix "%s(%s) = %s"))
  67   "Message in which info of other clients is displayed.")
  68
  69 (defvar liece-ctcp-buffer (append liece-D-buffer liece-O-buffer))
  70
  71 (defvar liece-ctcp-ping-time '(0 0 0))
  72
  73 (defvar liece-ctcp-last-command nil
  74   "The last command executed.")
  75
  76 (defvar liece-ctcp-last-nick nil
  77   "The last nick being queried.")
  78
  79 (defconst liece-ctcp-error-message "Unrecognized command: '%s'"
  80   "Error message given to anyone asking wrong CLIENT data.")
  81
  82 (defun liece-ctcp-last-nick-maybe-change (prefix rest)
  83   (if (equal prefix liece-ctcp-last-nick)
  84       (setq liece-ctcp-last-nick rest))
  85   nil)
  86
  87 (defun liece-ctcp-last-nick-maybe-reset (prefix rest)
  88   (if (equal prefix liece-ctcp-last-nick)
  89       (setq liece-ctcp-last-nick nil)))
  90
  91 (add-hook 'liece-nick-hook 'liece-ctcp-last-nick-maybe-change t)
  92 (add-hook 'liece-quit-hook 'liece-ctcp-last-nick-maybe-reset)
  93
  94 (defcustom liece-ctcp-file-save-directory liece-directory
  95   "Directory to save received files."
  96   :type 'directory
  97   :group 'liece-ctcp)
  98
  99 (liece-handler-define-backend "ctcp-message")
 100
 101 (defmacro liece-register-ctcp-message-handler (name)
 102   `(liece-handler-define-function
 103     ,name '(from chnl data "ctcp-message")
 104     ',(intern (format "liece-ctcp-%s-message" name))))
 105
 106 (liece-register-ctcp-message-handler "version")
 107 (liece-register-ctcp-message-handler "userinfo")
 108 (liece-register-ctcp-message-handler "clientinfo")
 109 (liece-register-ctcp-message-handler "ping")
 110 (liece-register-ctcp-message-handler "time")
 111 (liece-register-ctcp-message-handler "file")
 112 (liece-register-ctcp-message-handler "x-face")
 113 (liece-register-ctcp-message-handler "comment")
 114 (liece-register-ctcp-message-handler "help")
 115 (liece-register-ctcp-message-handler "action")
 116 (liece-register-ctcp-message-handler "dcc")
 117 (liece-register-ctcp-message-handler "errmsg")
 118
 119 (defun* liece-ctcp-message (from chnl rest)
 120   (or (string-match "^\\([^\001]*\\)\001\\([^\001]*\\)\001" rest)
 121       (return-from liece-ctcp-message))
 122   (let (hook after-hook data message)
 123     (setq data (match-string 2 rest)
 124           rest (concat
 125                 (match-string 1 rest)
 126                 (substring rest (match-end 0))))
 127     (if (string-match "^\\([^ ]*\\) *:?" data)
 128         (setq message (downcase (match-string 1 data))
 129               data (substring data (match-end 0)))
 130       (setq message "errmsg"
 131             data (_ "Couldn't figure out what was said.")))
 132     (setq hook
 133           (intern-soft
 134            (concat "liece-ctcp-" message "-hook"))
 135           after-hook
 136           (intern-soft
 137            (concat "liece-after-ctcp-" message "-hook")))
 138     (if (run-hook-with-args-until-success hook from chnl data)
 139         (return-from liece-ctcp-message rest))
 140     (let ((func
 141            (liece-handler-find-function
 142             message '(from chnl data) "ctcp-message")))
 143       (if func
 144           (funcall func from chnl data)
 145         (liece-ctcp-messages message from chnl data))
 146       (run-hook-with-args after-hook from chnl data))
 147     rest))
 148
 149 (defun liece-ctcp-messages (message from chnl rest)
 150   (liece-send "NOTICE %s :\001ERRMSG %s :%s\001"
 151                from (upcase message)
 152                (format liece-ctcp-error-message
 153                        (upcase message)))
 154   (setq chnl (liece-channel-virtual chnl))
 155   (liece-ctcp-insert (upcase message) from chnl rest))
 156
 157 (defun liece-ctcp-action-message (from chnl rest)
 158   "CTCP ACTION handler."
 159   (let ((liece-message-target (liece-channel-virtual chnl))
 160         (liece-message-speaker from)
 161         (liece-message-type 'action))
 162     (liece-display-message rest)))
 163
 164 (defun liece-ctcp-insert (message from &optional chnl rest)
 165   (if (or (null chnl)
 166           (liece-nick-equal chnl liece-real-nickname))
 167       (liece-message "%s query from %s." message from)
 168     (liece-message "%s query from %s (%s)." message from chnl)
 169     (liece-insert-client
 170      (liece-pick-buffer chnl)
 171      (format "%s query from %s%s\n"
 172              message from (if rest (concat ":" rest) "")))))
 173
 174 (defun liece-ctcp-version-message (from chnl rest)
 175   "CTCP VERSION handler."
 176   (liece-send "NOTICE %s :\001VERSION %s :\001"
 177               from (liece-version))
 178   (setq chnl (liece-channel-virtual chnl))
 179   (liece-ctcp-insert "VERSION" from chnl rest))
 180
 181 (defun liece-ctcp-userinfo-message (from chnl rest)
 182   "CTCP USERINFO handler."
 183   (liece-send "NOTICE %s :\001USERINFO %s\001"
 184               from liece-ctcp-userinfo)
 185   (setq chnl (liece-channel-virtual chnl))
 186   (liece-ctcp-insert "USERINFO" from chnl))
 187
 188 (defun liece-ctcp-clientinfo-message (from chnl rest)
 189   "CTCP CLIENTINFO handler."
 190   (liece-send "NOTICE %s :\001CLIENTINFO %s\001"
 191               from
 192               (eval-when-compile
 193                 (mapconcat
 194                  (lambda (symbol) (upcase (symbol-name symbol)))
 195                  liece-ctcp-supported-symbols " ")))
 196   (setq chnl (liece-channel-virtual chnl))
 197   (liece-ctcp-insert "CLIENTINFO" from chnl))
 198
 199 (defvar liece-ctcp-help-message
 200   "This is a help message for CTCP requests.
 201 \"VERSION\" gives version of this client.
 202 \"USERINFO\" gives user supplied information if any.
 203 \"CLIENTINFO\" gives commands this client knows.
 204 \"PING\" returns the arguments it receives.
 205 \"TIME\" tells you the time on the user's host.
 206 \"FILE\" send a small file via IRC messages.
 207 \"X-FACE\" gives you user supplied X-Face.
 208 \"COMMENT\" returns string sent by other person.
 209 \"HELP\" gives this help message"
 210   "Help message for CTCP requests.")
 211
 212 (defun liece-ctcp-help-message (from chnl rest)
 213   "CTCP HELP handler."
 214   (liece-send
 215    "NOTICE %s :\001HELP %s\001"
 216    from (liece-quote-encode-string liece-ctcp-help-message))
 217   (setq chnl (liece-channel-virtual chnl))
 218   (liece-ctcp-insert "HELP" from chnl))
 219
 220 (defun liece-ctcp-comment-message (from chnl rest)
 221   "CTCP COMMENT handler."
 222   (setq chnl (liece-channel-virtual chnl))
 223   (liece-ctcp-insert "COMMENT" from chnl))
 224
 225 (defun liece-ctcp-ping-message (from chnl rest)
 226   "CTCP PING handler."
 227   (liece-send "NOTICE %s :\001PING %s\001" from rest)
 228   (setq chnl (liece-channel-virtual chnl))
 229   (liece-ctcp-insert "PING" from chnl))
 230
 231 (defun liece-ctcp-time-message (from chnl rest)
 232   "CTCP TIME handler."
 233   (liece-send "NOTICE %s :\001TIME %s\001"
 234               from (funcall liece-format-time-function
 235                             (current-time)))
 236   (setq chnl (liece-channel-virtual chnl))
 237   (liece-ctcp-insert "TIME" from chnl))
 238
 239 (defun liece-ctcp-x-face-message (from chnl rest)
 240   "CTCP X-FACE handler."
 241   (liece-send "NOTICE %s :\001X-FACE %s\001"
 242               from liece-ctcp-x-face)
 243   (setq chnl (liece-channel-virtual chnl))
 244   (liece-ctcp-insert "X-FACE" from chnl))
 245
 246 (liece-handler-define-backend "ctcp-notice")
 247
 248 (defmacro liece-register-ctcp-notice-handler (name)
 249   `(liece-handler-define-function
 250     ,name '(prefix rest "ctcp-notice")
 251     ',(intern (format "liece-ctcp-%s-notice" name))))
 252
 253 (liece-register-ctcp-notice-handler "version")
 254 (liece-register-ctcp-notice-handler "userinfo")
 255 (liece-register-ctcp-notice-handler "clientinfo")
 256 (liece-register-ctcp-notice-handler "ping")
 257 (liece-register-ctcp-notice-handler "time")
 258 (liece-register-ctcp-notice-handler "file")
 259 (liece-register-ctcp-notice-handler "x-face")
 260 (liece-register-ctcp-notice-handler "comment")
 261 (liece-register-ctcp-notice-handler "help")
 262 (liece-register-ctcp-notice-handler "dcc")
 263 (liece-register-ctcp-notice-handler "errmsg")
 264
 265 (defun* liece-ctcp-notice (prefix rest)
 266   (or (string-match "^\\([^\001]*\\)\001\\([^\001]*\\)\001" rest)
 267       (return-from liece-ctcp-notice))
 268   (let (hook after-hook data message)
 269     (setq data (match-string 2 rest)
 270           rest (concat
 271                 (match-string 1 rest)
 272                 (substring rest (match-end 0))))
 273     (if (string-match "^\\([^ ]*\\) *:?" data)
 274         (setq message (downcase (match-string 1 data))
 275               data (substring data (match-end 0)))
 276       (setq message "errmsg"
 277             data (_ "Couldn't figure out what was said.")))
 278     (setq hook
 279           (intern-soft
 280            (concat "liece-ctcp-" message "-notice-hook"))
 281           after-hook
 282           (intern-soft
 283            (concat "liece-after-ctcp-" message "-notice-hook")))
 284     (if (run-hook-with-args-until-success hook prefix data)
 285         (return-from liece-ctcp-notice rest))
 286     (let ((func
 287            (liece-handler-find-function
 288             message '(prefix data) "ctcp-notice")))
 289       (if func
 290           (funcall func prefix data)
 291         (liece-ctcp-notices message prefix data)))
 292     (run-hook-with-args after-hook prefix data)
 293     rest))
 294
 295 (defun liece-ctcp-notices (message prefix rest)
 296   (liece-message
 297    (_ "Unknown ctcp notice \":%s %s %s\"")
 298    prefix (upcase message) rest))
 299
 300 (liece-handler-define-backend "ctcp-file")
 301
 302 (defmacro liece-register-file-handler (name)
 303   `(liece-handler-define-function
 304     ,name '(prefix name data "ctcp-file")
 305     ',(intern (format "liece-file-%s" name))))
 306
 307 (liece-register-file-handler "start")
 308 (liece-register-file-handler "cont")
 309 (liece-register-file-handler "end")
 310
 311 (defun* liece-ctcp-file-notice (prefix rest)
 312   (when liece-file-accept
 313     (multiple-value-bind (message name data)
 314         (liece-split-line rest)
 315       (setq message (downcase message))
 316       (let ((hook
 317              (intern-soft
 318               (concat "liece-file-" message "-hook")))
 319             (after-hook
 320              (intern-soft
 321               (concat "liece-after-file-" message "-hook")))
 322             func)
 323         (if (run-hook-with-args-until-success hook prefix name)
 324             (return-from liece-ctcp-file-notice))
 325         (setq func (liece-handler-find-function
 326                     message '(prefix name data) 'ctcp-file))
 327         (if func
 328             (funcall func prefix name data)
 329           (liece-file-notices message prefix name data))
 330         (run-hook-with-args after-hook prefix name)))))
 331
 332 (defun liece-file-notices (message prefix name data)
 333   (liece-message
 334    (_ "Unknown FILE message \":%s %s %s %s\"")
 335    prefix (upcase message) name data))
 336
 337 (defun liece-file-start (prefix name data)
 338   "CTCP FILE start handler."
 339   (save-excursion
 340     (set-buffer
 341      (liece-get-buffer-create
 342       (format " *ctcp-file:%s*" name)))
 343     (buffer-disable-undo)
 344     (set-buffer-multibyte nil)
 345     (erase-buffer)
 346     (insert data)))
 347
 348 (defun liece-file-cont (prefix name data)
 349   "CTCP FILE cont handler."
 350   (save-excursion
 351     (set-buffer
 352      (liece-get-buffer-create
 353       (format " *ctcp-file:%s*" name)))
 354     (goto-char (point-max))
 355     (insert data)))
 356
 357 (defun liece-file-end (prefix name data)
 358   "CTCP FILE cont handler."
 359   (save-excursion
 360     (set-buffer
 361      (liece-get-buffer-create
 362       (format " *ctcp-file:%s*" name)))
 363     (goto-char (point-max))
 364     (insert data)
 365     (liece-quote-decode-region (point-min)(point-max))
 366     (goto-char (point-min))
 367     (when (or (null liece-file-confirm-save)
 368               (y-or-n-p "Save file? "))
 369       (or (file-directory-p liece-ctcp-file-save-directory)
 370           (make-directory liece-ctcp-file-save-directory))
 371       (write-region-as-binary
 372        (point-min)(point-max)
 373        (expand-file-name
 374         (file-name-nondirectory
 375          (concat name "-" prefix))
 376         liece-ctcp-file-save-directory))
 377       (kill-buffer (current-buffer)))))
 378
 379 (defun liece-ctcp-version-insert (buffer prefix name
 380                                          &optional version environment)
 381   (or (listp buffer)
 382       (setq buffer (list buffer)))
 383   (liece-insert buffer
 384                 (concat (format liece-ctcp-message
 385                                 "VERSION" prefix "")
 386                         name "\n"))
 387   (when version
 388     (liece-insert buffer
 389                   (concat (format liece-ctcp-message
 390                                   "VERSION" prefix "")
 391                           "\t" version
 392                           (if environment
 393                               (concat " " environment))
 394                           "\n"))))
 395
 396 (defun liece-ctcp-version-notice (prefix rest)
 397   "CTCP VERSION reply handler."
 398   (if (null rest)
 399       (liece-message (_ "Empty CLIENT version notice from \"%s\".") prefix)
 400     (cond
 401      ((string-match "^\\([^:]*\\):\\([^:]+\\):?\\([^:]*\\)" rest)
 402       (liece-ctcp-version-insert liece-ctcp-buffer
 403                                  prefix (match-string 1 rest)
 404                                  (match-string 2 rest)
 405                                  (match-string 3 rest)))
 406      ((string-match "^\\([^:]*\\):\\(.*\\)" rest)
 407       (liece-ctcp-version-insert liece-ctcp-buffer
 408                                  prefix (match-string 1 rest)))
 409      (t
 410       (liece-ctcp-version-insert liece-ctcp-buffer prefix rest)))))
 411
 412 (defun liece-ctcp-clientinfo-notice (prefix rest)
 413   "CTCP CLIENTINFO reply handler."
 414   (liece-insert liece-ctcp-buffer
 415                  (format (concat liece-ctcp-message "\n")
 416                          "CLIENTINFO" prefix rest)))
 417
 418 (defun liece-ctcp-userinfo-notice (prefix rest)
 419   "CTCP USERINFO reply handler."
 420   (liece-insert liece-ctcp-buffer
 421                  (format (concat liece-ctcp-message "\n")
 422                          "USERINFO" prefix rest)))
 423
 424 (defun liece-ctcp-help-notice (prefix rest)
 425   "CTCP HELP reply handler."
 426   (liece-insert liece-ctcp-buffer
 427                  (format (concat liece-ctcp-message "\n")
 428                          "HELP" prefix rest)))
 429
 430 (defun liece-ctcp-x-face-notice (prefix rest)
 431   "CTCP X-FACE reply handler."
 432   (let ((buffer liece-ctcp-buffer))
 433     (liece-insert buffer
 434                    (format liece-ctcp-message
 435                            "X-FACE" prefix ""))
 436     (if (and liece-use-x-face
 437              (string-match "[^ \t]" rest))
 438         (liece-x-face-insert
 439          buffer (replace-in-string rest "[ \t\r\n]+" "") prefix)
 440       (liece-insert buffer rest))
 441     (let (liece-display-time)
 442       (liece-insert buffer "\n"))))
 443
 444 (defun liece-ctcp-errmsg-notice (prefix rest)
 445   "CTCP ERRMSG reply handler."
 446   (liece-insert liece-ctcp-buffer
 447                  (format (concat liece-ctcp-message "\n")
 448                          "ERRMSG" prefix rest)))
 449
 450 (defun liece-ctcp-comment-notice (from rest)
 451   "CTCP COMMENT reply handler."
 452   (liece-insert liece-ctcp-buffer
 453                  (format (concat liece-ctcp-message "\n")
 454                          "COMMENT" from rest))
 455   (liece-message "COMMENT query from %s." from))
 456
 457 (defmacro liece-ctcp-prepare-ping-seconds (timenow)
 458   `(format (_ "%d sec")
 459            (+ (* 65536 (- (car ,timenow) (car liece-ctcp-ping-time)))
 460               (- (cadr ,timenow) (cadr liece-ctcp-ping-time)))))
 461
 462 (defun liece-ctcp-ping-notice (from rest)
 463   "CTCP PING reply handler."
 464   (let ((timenow (current-time)))
 465     (liece-insert liece-ctcp-buffer
 466                    (format (concat liece-ctcp-message "\n")
 467                            "PING" from
 468                            (liece-ctcp-prepare-ping-seconds timenow)))))
 469
 470 (defun liece-ctcp-time-notice (from rest)
 471   "CTCP TIME reply handler."
 472   (liece-insert liece-ctcp-buffer
 473                 (format (concat liece-ctcp-message "\n")
 474                         "TIME" from rest)))
 475
 476 (defmacro liece-complete-client ()
 477   '(let ((completion-ignore-case t) (nick liece-ctcp-last-nick))
 478      (liece-minibuffer-completing-read
 479       (_ "Whose client: ") liece-nick-alist nil nil nil nil
 480       (if nick (liece-channel-virtual nick)))))
 481
 482 (defun liece-minibuffer-complete-client-query ()
 483   (let* ((alist
 484           (eval-when-compile
 485             (list-to-alist
 486              (mapcar
 487               (lambda (symbol) (downcase (symbol-name symbol)))
 488               liece-ctcp-supported-symbols))))
 489          (candidate (liece-minibuffer-prepare-candidate))
 490          (completion (try-completion candidate alist))
 491          (all (all-completions candidate alist)))
 492     (liece-minibuffer-finalize-completion completion candidate all)))
 493
 494 (defmacro liece-complete-query ()
 495   '(let ((completion-ignore-case t)
 496          (liece-minibuffer-complete-function
 497           (function liece-minibuffer-complete-client-query)))
 498      (read-from-minibuffer
 499       (_ "Which query: ") liece-ctcp-last-command
 500       liece-minibuffer-map)))
 501
 502 (defun liece-ctcp-make-command-wrapper (symbol)
 503   (fset (intern (format "liece-command-ctcp-%s" symbol))
 504         `(lambda (client)
 505            (interactive (list (liece-complete-client)))
 506            (setq client (liece-channel-real client)
 507                  liece-ctcp-last-nick client
 508                  ,@(if (eq symbol 'ping)
 509                        '(liece-ctcp-ping-time
 510                          (current-time))))
 511            (liece-send "PRIVMSG %s :\001%s\001"
 512                        client (upcase (symbol-name ',symbol))))))
 513
 514 (dolist (symbol liece-ctcp-supported-symbols)
 515   (liece-ctcp-make-command-wrapper symbol))
 516
 517 (defun liece-command-ctcp-action (&optional arg)
 518   "Send CTCP action."
 519   (interactive
 520    (if current-prefix-arg
 521        (list current-prefix-arg)))
 522   (let ((completion-ignore-case t)
 523         (liece-message-type 'action)
 524         message)
 525     (if arg
 526         (setq liece-privmsg-partner
 527               (liece-channel-virtual
 528                (liece-minibuffer-completing-read
 529                 (_ "To whom: ")
 530                 (append liece-nick-alist liece-channel-alist)
 531                 nil nil nil nil liece-privmsg-partner))))
 532     (beginning-of-line)
 533     (setq message (buffer-substring (point)(progn (end-of-line)(point))))
 534     (if (string= message "")
 535         (setq message (read-string "Action: "))
 536       (liece-next-line 1))
 537     (liece-send "PRIVMSG %s :\001ACTION %s\001"
 538                  (if arg
 539                      liece-privmsg-partner
 540                    (liece-channel-real liece-current-channel))
 541                  message)
 542     (if arg
 543         (liece-own-private-message message)
 544       (liece-own-channel-message message))))
 545
 546 (define-obsolete-function-alias 'liece-command-send-action
 547   'liece-command-ctcp-action)
 548
 549 (defun liece-command-ctcp-generic (nick command)
 550   "Ask about someones client clientinfo."
 551   (interactive (list (liece-complete-client) (liece-complete-query)))
 552   (setq nick (liece-channel-real nick)
 553         liece-ctcp-last-nick nick
 554         liece-ctcp-last-command command)
 555   (if (string-equal-ignore-case liece-ctcp-last-command "ping")
 556       (setq liece-ctcp-ping-time (current-time)))
 557   (liece-send "PRIVMSG %s :\001%s\001" nick command))
 558
 559 (defun liece-command-ctcp-userinfo-from-minibuffer (info)
 560   "Ask about someones client clientinfo."
 561   (interactive
 562    (list (read-from-minibuffer "New userinfo: " liece-ctcp-userinfo)))
 563   (setq liece-ctcp-userinfo info))
 564
 565 (defun liece-command-ctcp-x-face-from-xbm-file (file)
 566   (interactive "fXBM File: ")
 567   (let (data)
 568     (and (file-exists-p file) (file-readable-p file)
 569          (setq data (liece-x-face-encode file))
 570          (setq liece-ctcp-x-face
 571                (replace-in-string (cadr (nth 3 data)) "[ \t\n]" "")))))
 572
 573 (defun liece-command-send-file (file to)
 574   "Send a file to given  user."
 575   (interactive "fFile name: \nsTo whom: ")
 576   (save-excursion
 577     (set-buffer (liece-get-buffer-create (format " *ctcp-file:%s*" file)))
 578     (buffer-disable-undo)
 579     (set-buffer-multibyte nil)
 580     (erase-buffer)
 581     (insert-file-contents-as-binary file)
 582     (liece-quote-encode-region (point-min)(point-max))
 583     (goto-char (point-min))
 584     (let ((bound (min (point-max) (+ 80 (point))))
 585           (liece-mime-charset-for-write 'binary))
 586       (liece-send
 587        "NOTICE %s :\001FILE START %s :%s\001"
 588        to file (buffer-substring (point) bound))
 589       (goto-char bound)
 590       (while (not (eobp))
 591         (if (= 1 (mod (point) 800))
 592             (sit-for 1))
 593         (setq bound (min (point-max) (+ 80 (point))))
 594         (liece-send "NOTICE %s :\001FILE CONT %s :%s\001"
 595                     to file (buffer-substring (point) bound))
 596         (goto-char bound)))
 597     (liece-send "NOTICE %s :\001FILE END %s : \001" to file)
 598     (kill-buffer (current-buffer))))
 599
 600 (provide 'liece-ctcp)
 601
 602 ;;; liece-ctcp.el ends here