cgit.sxemacs.org Git - riece/blob - lisp/riece-ndcc.el

   1 ;;; riece-ndcc.el --- elisp native DCC add-on
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: IRC, riece
   6
   7 ;; This file is part of Riece.
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Code:
  25
  26 (require 'riece-globals)
  27 (require 'riece-options)
  28 (require 'riece-display)
  29
  30 (require 'calc)
  31
  32 (defgroup riece-ndcc nil
  33   "Elisp native DCC implementation"
  34   :prefix "riece-"
  35   :group 'riece)
  36
  37 (defcustom riece-ndcc-server-address "127.0.0.1"
  38   "Local address of the DCC server.
  39 Only used for sending files."
  40   :type 'vector
  41   :group 'riece-ndcc)
  42
  43 (defvar riece-ndcc-requests nil)
  44
  45 (defvar riece-ndcc-request-user nil)
  46 (defvar riece-ndcc-request-size nil)
  47
  48 (defun riece-ndcc-encode-address (address)
  49   (unless (string-match
  50            "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$"
  51            address)
  52     (error "% is not an IP address" address))
  53   (let ((calc-number-radix 10))
  54     (calc-eval (format "%s * (2 ** 24) + %s * (2 **16) + %s * (2 ** 8) + %s"
  55                        (match-string 1 address)
  56                        (match-string 2 address)
  57                        (match-string 3 address)
  58                        (match-string 4 address)))))
  59
  60 (defun riece-ndcc-decode-address (address)
  61   (format "%d.%d.%d.%d"
  62           (floor (string-to-number
  63                   (calc-eval (format "(%s / (2 ** 24)) %% 256" address))))
  64           (floor (string-to-number
  65                   (calc-eval (format "(%s / (2 ** 16)) %% 256" address))))
  66           (floor (string-to-number
  67                   (calc-eval (format "(%s / (2 ** 8)) %% 256" address))))
  68           (floor (string-to-number
  69                   (calc-eval (format "%s %% 256" address))))))
  70
  71 (defun riece-ndcc-server-sentinel (process status)
  72   (when (string-match "^open from " status)
  73     (let ((parent-name
  74            (if (string-match " <[^>]+>$" (process-name process))
  75                (substring (process-name process) 0 (match-beginning 0)))))
  76       (save-excursion
  77         (set-buffer (process-buffer (get-process parent-name)))
  78         (goto-char (point-min))
  79         (while (not (eobp))
  80           (process-send-region process
  81                                (point)
  82                                (goto-char (min (+ 1024 (point)) (point-max))))
  83           (message "Sending %s...(%d/%d)"
  84                    (buffer-file-name) (1- (point)) (buffer-size)))
  85         (message "Sending %s...done"
  86                  (buffer-file-name)))
  87       (kill-buffer (process-buffer (get-process parent-name))))
  88     (kill-buffer (process-buffer process))))
  89
  90 (defun riece-command-dcc-send (user file)
  91   (interactive
  92    (let ((completion-ignore-case t))
  93      (unless riece-ndcc-server-address
  94        (error "Set riece-ndcc-server-address to your host"))
  95      (list (riece-completing-read-identity
  96             "User: "
  97             (riece-get-users-on-server (riece-current-server-name)))
  98            (expand-file-name (read-file-name "File: ")))))
  99   (let* (selective-display
 100          (coding-system-for-read 'binary)
 101          format-alist
 102          jka-compr-compression-info-list
 103          (buffer (find-file-noselect file))
 104          process)
 105     (with-current-buffer buffer         ;To throw an error when the
 106       (setq buffer-read-only t))        ;process has input.
 107     (setq process (make-network-process :name "DCC" :buffer buffer
 108                                         :host riece-ndcc-server-address
 109                                         :server t :service t
 110                                         :coding 'binary
 111         &nbs