cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-ext.el

   1 ;;; mew-ext.el --- Message/External-Body support for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Nov 13, 1996
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-ext-version "mew-ext.el version 0.21")
  10
  11 (require 'mew)
  12 (eval-when-compile
  13   (cond
  14    ((mew-which-el "efs" load-path)
  15     (require 'efs))
  16    ((mew-which-el "ange-ftp" load-path)
  17     (require 'ange-ftp))))
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;;;
  21 ;;; customize variables
  22 ;;;
  23
  24 (defvar mew-ext-prog-url "netscape")
  25 (defvar mew-ext-prog-url-args '("-install"))
  26
  27 ;; If you want to use w3.el instead of "netscape", put the
  28 ;; following in .emacs.
  29 ;;(setq mew-ext-prog-url "w3")
  30 ;;(setq mew-ext-prog-url-args nil)
  31
  32 ;; If you want to use lynx instead of "netscape", put the
  33 ;; following in .emacs.
  34 ;;(setq mew-ext-prog-url "kterm")
  35 ;;(setq mew-ext-prog-url-args '("-e" "lynx" "-color"))
  36
  37 (defvar mew-ext-anon-ftp-method 'ftp
  38   "A method to get the message body for access-type=anon-ftp.
  39 If 'ftp is specified, ange-ftp or efs is used. If 'http is specified,
  40 w3 is used.")
  41
  42 ;;
  43 ;; encode
  44 ;;
  45
  46 (defvar mew-ext-default-access-type "anon-ftp")
  47
  48 (defvar mew-ext-ftp-server-list
  49   '("ftp.Mew.org" "sh.wide.ad.jp"))
  50
  51 (defvar mew-ext-encode-switch
  52   '(("ftp"         . mew-ext-encode-ftp)
  53 ;;    ("tftp"        . mew-ext-encode-tftp)
  54     ("anon-ftp"    . mew-ext-encode-anon-ftp)
  55     ("local-file"  . mew-ext-encode-local-file)
  56     ("mail-server" . mew-ext-encode-mail-server)
  57     ("url"         . mew-ext-encode-url)))
  58
  59 ;;
  60 ;; decode
  61 ;;
  62
  63 (defvar mew-ext-switch
  64   '(("ftp"         . mew-ext-ftp)
  65     ("tftp"        . mew-ext-tftp)
  66     ("anon-ftp"    . mew-ext-anon-ftp)
  67     ("mail-server" . mew-ext-mail-server)
  68     ("url"         . mew-ext-url))) ;; RFC2017
  69
  70 (defvar mew-ext-include-switch
  71   '(("local-file" . mew-ext-include-local-file)))
  72
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74 ;;;
  75 ;;; environment variables
  76 ;;;
  77
  78 (cond
  79  ((mew-which-el "efs" load-path)
  80   (defun mew-ext-file-name-completion (file path)
  81     (require 'efs)
  82     (let ((efs-tmp-name-template mew-temp-file))
  83       (efs-file-name-completion file path)))
  84   (defun mew-ext-file-name-all-completions (file path)
  85     (require 'efs)
  86     (let ((efs-tmp-name-template mew-temp-file))
  87       (efs-file-name-all-completions file path)))
  88   (defun mew-ext-expand-dir (host user dir)
  89     (require 'efs)
  90     (let ((efs-tmp-name-template mew-temp-file) exp)
  91       (setq exp (efs-expand-file-name (format "/%s@%s:%s" user host dir)))
  92       (if (string-match ".*:\\(.*\\)$" exp)
  93           (mew-match 1 exp))))
  94   (defun mew-ext-copy-file-internal (remote local passwd)
  95     (require 'efs)
  96     (let ((efs-tmp-name-template mew-temp-file)
  97           (efs-generate-anonymous-password passwd)
  98           (parsed (efs-ftp-path remote)))
  99       (efs-copy-file-internal remote parsed local nil
 100                               nil nil nil nil t 'image))))
 101  ((mew-which-el "ange-ftp" load-path)
 102   (defun mew-ext-file-name-completion (file path)
 103     (require 'ange-ftp)
 104     (let ((ange-ftp-tmp-name-template mew-temp-file))
 105       (ange-ftp-file-name-completion file path)))
 106   (defun mew-ext-file-name-all-completions (file path)
 107     (require 'ange-ftp)
 108     (let ((ange-ftp-tmp-name-template mew-temp-file))
 109       (ange-ftp-file-name-all-completions file path)))
 110   (defun mew-ext-expand-dir (host user dir)
 111     (require 'ange-ftp)
 112     (let ((ange-ftp-tmp-name-template mew-temp-file) exp)
 113       (setq exp (ange-ftp-expand-file-name (format "/%s@%s:%s" user host dir)))
 114       (if (string-match ".*:\\(.*\\)$" exp)
 115           (mew-match 1 exp))))
 116   (defun mew-ext-copy-file-internal (remote local passwd)
 117     (require 'ange-ftp)
 118     (let ((ange-ftp-tmp-name-template mew-temp-file)
 119           (ange-ftp-generate-anonymous-password passwd))
 120       (ange-ftp-copy-file-internal remote local t nil nil nil t))))
 121  )
 122
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 ;;;
 125 ;;; Encode
 126 ;;;
 127
 128 (defun mew-attach-external-body ()
 129   (interactive)
 130   (if (not (mew-attach-not-line012-1))
 131       (message "Can't insert external-body here")
 132     (let* ((nums (mew-syntax-nums))
 133            (subdir (mew-attach-expand-path mew-encode-syntax nums))
 134            (attachdir (mew-attachdir))
 135            file filepath ct)
 136       ;; attachdir / {subdir/} dir
 137       (if (not (equal subdir ""))
 138           (setq attachdir (expand-file-name subdir attachdir)))
 139       ;; attachdir / file
 140       (setq filepath (mew-random-filename attachdir mew-ext-suffix))
 141       (if (file-exists-p filepath)
 142           (message "Could not make a file for external-body, sorry.")
 143         (setq file (file-name-nondirectory filepath))
 144         (setq ct (mew-ext-encode filepath))
 145         (setq mew-encode-syntax
 146               (mew-syntax-insert-entry
 147                mew-encode-syntax
 148                nums
 149                (mew-encode-syntax-single file ct)))
 150         (mew-encode-syntax-print mew-encode-syntax)))))
 151
 152 (defun mew-create-content-id ()
 153   ;; this is not unique if used with very short interval.
 154   ;; but it's ok
 155   (format "<%s.%s.%s@%s>" (nth 0 (current-time)) (nth 1 (current-time))
 156           (emacs-pid) (system-name)))
 157
 158 (defun mew-ext-encode (filename)
 159   (let (buf ret access-type ct name)
 160     (save-excursion
 161       (set-buffer (get-buffer-create mew-buffer-ext))
 162       (setq buf (current-buffer))
 163       (mew-erase-buffer)
 164       ;;content-header
 165       (setq access-type (mew-input-general
 166                          "Access type" mew-ext-encode-switch t
 167                          mew-ext-default-access-type))
 168       (setq ret (funcall (cdr (assoc access-type mew-ext-encode-switch))))
 169       ;;message-header
 170       (cond
 171        ((string= access-type "url")
 172         (setq name "URL")
 173         (setq ct "Text/Html"))
 174        ((string= access-type "mail-server")
 175         (setq name "Mail server's file")
 176         (setq ct mew-ct-apo))
 177        (t
 178         (setq name (file-name-nondirectory
 179                     (mew-chop (mew-syntax-get-param ret "name"))))
 180         ;; name is quoted
 181         (if (equal name "")
 182             (setq ct mew-ct-apo)
 183           (setq ct (capitalize (mew-attr-get-ct (mew-attr-by-file name)))))))
 184       (setq ct (mew-input-type "Type for %s (%s): " name ct
 185                                mew-mime-content-type-list))
 186       (mew-header-insert mew-ct: ct)
 187       (mew-header-insert mew-cid: (mew-create-content-id))
 188       (insert "\n")
 189       (if (not (string= access-type "mail-server"))
 190           () ;; message-body is not necessary
 191         ;;message-body
 192         (insert (read-string "Input message to the mail-server: "))
 193         (insert "\n"))
 194       (write-file filename))
 195     (kill-buffer buf)
 196     (cons mew-ct-ext (cons (list "access-type" access-type) ret))))
 197
 198 (defun mew-ext-encode-ftp ()
 199   ;; "name" "site" "directory" "mode"
 200   (let ((mew-ext-host (mew-input-general
 201                        "FTP server"
 202                        (if mew-ext-ftp-server-list
 203                            (mapcar (function list)
 204                                    mew-ext-ftp-server-list))
 205                        nil
 206                        (car mew-ext-ftp-server-list)))
 207         mew-ext-user path dir file ret)
 208     (setq ret (list (list "site" mew-ext-host)))
 209     (setq mew-ext-user (read-string (format "User name at %s: " mew-ext-host)
 210                                 (user-login-name)))
 211     (setq path (mew-input-rfile "Filename :"))
 212     (setq file (file-name-nondirectory path))
 213     (setq dir (file-name-directory path))
 214     (if (and dir (string-match mew-home dir))
 215         (setq dir (mew-ext-expand-dir mew-ext-host mew-ext-user dir)))
 216     (cond
 217      (dir
 218       (setq ret (cons (list "directory" dir) ret))
 219       (setq ret (cons (list "name" file) ret)))
 220      (t
 221       (setq ret (cons (list "name" file) ret))))
 222     ret))
 223
 224 (defun mew-ext-encode-tftp ()
 225   ;; xxx not yet
 226   )
 227
 228 (defun mew-ext-encode-anon-ftp ()
 229   ;; "name" "site" "directory" "mode"
 230   (let ((mew-ext-user "anonymous")
 231         (mew-ext-host (mew-input-general
 232                        "FTP server"
 233                        (if mew-ext-ftp-server-list
 234                            (mapcar (function list)
 235                                    mew-ext-ftp-server-list))
 236                        nil
 237                        (car mew-ext-ftp-server-list)))
 238         path dir file ret)
 239     (setq ret (list (list "site" mew-ext-host)))
 240     (setq path (mew-input-rfile "Filename :"))
 241     (setq file (file-name-nondirectory path))
 242     (setq dir (file-name-directory path))
 243     (if (and dir (string-match mew-home dir))
 244         (setq dir (mew-ext-expand-dir mew-ext-host mew-ext-user dir)))
 245     (cond
 246      (dir
 247       (setq ret (cons (list "directory" dir) ret))
 248       (setq ret (cons (list "name" file) ret)))
 249      (t
 250       (setq ret (cons (list "name" file) ret))))
 251     ret))
 252
 253 (defun mew-ext-encode-local-file ()
 254   ;; "name" "site"
 255   (let ((file (mew-draft-input-file-name "File name: ")))
 256     (list (list "name" (expand-file-name file)))))
 257
 258 (defun mew-ext-encode-mail-server ()
 259   ;; "server" "subject"
 260   (let (server subject)
 261     (setq server (car (mew-input-address "Server address: ")))
 262     (setq subject (read-string (concat mew-subj: " ")))
 263     (list (list "server" server)
 264           (list "subject" subject))))
 265
 266 (defun mew-ext-encode-url ()
 267   ;; "url"
 268   (let ((url (read-string "URL: ")))
 269     (list (list "url" url))))
 270
 271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272 ;;;
 273 ;;; Decode
 274 ;;;
 275
 276 ;;
 277 ;; exclude
 278 ;;
 279
 280 (defun mew-mime-external-body (begin end params &optional execute)
 281   ;; message-buffer
 282   (let* ((access-type (mew-syntax-get-param params "access-type"))
 283          (program (cdr (mew-assoc-match access-type mew-ext-switch 0))))
 284     ;; xxx expire
 285     (if (and (symbolp program) (fboundp program))
 286         (funcall program begin end params execute))))
 287
 288 (defun mew-ext-ftp (begin end params execute)
 289   (mew-elet
 290    (let* ((site (mew-syntax-get-param params "site"))
 291           (directory (mew-syntax-get-param params "directory"))
 292           (name (mew-syntax-get-param params "name"))
 293           (size (mew-syntax-get-param params "size"))
 294           (getit t) (username "")
 295           filepath localfile lfname remotefile)
 296      (if directory
 297          (setq filepath (concat (file-name-as-directory directory) name))
 298        (setq filepath name))
 299      (if (and filepath (string-match "^[A-Za-z]:/.+" filepath)) ;; drive letter
 300          (setq filepath (substring filepath 2 (match-end 0))))
 301      (mew-erase-buffer)
 302      (insert " ####### ####### ######  \n"
 303              " #          #    #     # \n"
 304              " #          #    #     # \n"
 305              " #####      #    ######  \n"
 306              " #          #    #       \n"
 307              " #          #    #       \n"
 308              " #          #    #       \n"
 309              "\n\n")
 310      (insert "You can get the message content by FTP\n\n")
 311      (mew-insert "Site:\t%s\n" site)
 312      (mew-insert "File:\t%s\n" filepath)
 313      (mew-insert "Size:\t%s bytes\n" size)
 314      (if (null execute)
 315          (insert "\nTo get this file, type "
 316                  (substitute-command-keys
 317                   "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'."))
 318        (setq username (read-string (format "User name at %s: " site)
 319                                    (user-login-name)))
 320        (setq remotefile (format "/%s@%s:%s" username site filepath))
 321        (setq localfile (mew-summary-input-file-name "Save to: " name))
 322        (setq lfname (file-name-nondirectory localfile))
 323        (if (file-exists-p localfile)
 324            (if (y-or-n-p (format "%s exists. Overwrite? " lfname))
 325                (delete-file localfile)
 326              (setq getit nil)
 327              (message "The file wasn't retrieved")))
 328        (if getit (mew-ext-copy-file-internal remotefile localfile nil))))))
 329
 330 (defun mew-ext-tftp (begin end params execute)
 331   (message "access-type TFTP is not supported yet"))
 332
 333 (defun mew-ext-anon-ftp (begin end params execute)
 334   (mew-elet
 335    (let* ((site (mew-syntax-get-param params "site"))
 336           (directory (mew-syntax-get-param params "directory"))
 337           (name (mew-syntax-get-param params "name"))
 338           (size (mew-syntax-get-param params "size"))
 339           (getit t)
 340           filepath localfile lfname remotefile url)
 341      (if directory
 342          (setq filepath (concat (file-name-as-directory directory) name))
 343        (setq filepath name))
 344      (if (and filepath (string-match "^[A-Za-z]:/.+" filepath)) ;; drive letter
 345          (setq filepath (substring filepath 2 (match-end 0))))
 346      (mew-erase-buffer)
 347      (insert " Anonymous \n"
 348              " ####### ####### ######  \n"
 349              " #          #    #     # \n"
 350              " #          #    #     # \n"
 351              " #####      #    ######  \n"
 352              " #          #    #       \n"
 353              " #          #    #       \n"
 354              " #          #    #       \n"
 355              "\n\n")
 356      (insert "You can get the message content by FTP\n\n")
 357      (mew-insert "Site:\t%s\n" site)
 358      (mew-insert "File:\t%s\n" filepath)
 359      (mew-insert "Size:\t%s bytes\n" size)
 360      (if (null execute)
 361          (insert "\nTo get this file, type "
 362                  (substitute-command-keys
 363                   "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'."))
 364        (setq remotefile (format "/%s@%s:%s" "anonymous" site filepath))
 365        (if (string-match "^[/\:]" filepath)
 366            (setq url (format "ftp://%s%s" site filepath))
 367          (setq url (format "ftp://%s/%s" site filepath)))
 368        (setq localfile (mew-summary-input-file-name "Save to: " name))
 369        (setq lfname (file-name-nondirectory localfile))
 370        (if (file-exists-p localfile)
 371            (if (y-or-n-p (format "%s exists. Overwrite? " lfname))
 372                (delete-file localfile)
 373              (setq getit nil)
 374              (message "The file wasn't retrieved")))
 375        (if (not getit)
 376            ()
 377          (cond
 378           ((eq mew-ext-anon-ftp-method 'ftp)
 379            (mew-ext-copy-file-internal remotefile localfile mew-mail-address))
 380           ((eq mew-ext-anon-ftp-method 'http)
 381            (require 'w3)
 382            (w3-fetch url))))))))
 383
 384 (defun mew-ext-mail-server (begin end params execute)
 385   (mew-elet
 386    (let ((server (mew-syntax-get-param params "server"))
 387          (subject (mew-syntax-get-param params "subject"))
 388          (size (mew-syntax-get-param params "size"))
 389          (start nil))
 390      (mew-erase-buffer)
 391      (insert " #     #    #      ###   #\n"
 392              " ##   ##   # #      #    #\n"
 393              " # # # #  #   #     #    #\n"
 394              " #  #  # #     #    #    #\n"
 395              " #     # #######    #    #\n"
 396              " #     # #     #    #    #\n"
 397              " #     # #     #   ###   #######\n"
 398              "\n\n")
 399      (insert "You can get the message by e-mail\n\n")
 400      (mew-insert "Server:\t\t%s\n" server)
 401      (mew-insert "Size:\t%s bytes\n" size)
 402      (save-excursion
 403        (set-buffer (mew-current-get 'cache))
 404        (save-restriction
 405          (narrow-to-region begin end)
 406          (goto-char (point-min))
 407          ;; find a phantom body (in RFC1521)
 408          (re-search-forward "^$" nil t)
 409          (forward-line)
 410          (setq start (point))))
 411      ;; pickd up source from 'mew-send
 412      (if (null execute)
 413          (insert "\nTo send this mail, type "
 414                  (substitute-command-keys
 415                   "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'."))
 416        (mew-summary-send server nil subject)
 417        (goto-char (point-max))
 418        (insert-buffer-substring (mew-current-get 'cache) start end)
 419        (mew-draft-make-message)
 420        (if (y-or-n-p "Send this message? ")
 421            (mew-draft-real-send-letter))))))
 422
 423 (defun mew-ext-url (begin end params execute)
 424   (mew-elet
 425    (let ((url (mew-syntax-get-param params "url"))
 426          (size (mew-syntax-get-param params "size"))
 427          (process-connection-type mew-connection-type1))
 428      (mew-erase-buffer)
 429      (insert "#     # ######  #\n"
 430              "#     # #     # #\n"
 431              "#     # #     # #\n"
 432              "#     # ######  #\n"
 433              "#     # #   #   #\n"
 434              "#     # #    #  #\n"
 435              " #####  #     # #######\n"
 436              "\n\n")
 437      (mew-insert "URL:\t\t%s\n" url)
 438      (mew-insert "Size:\t%s bytes\n" size)
 439      (insert (format "Browser:\t%s\n"
 440                      (cond ((and (symbolp mew-ext-prog-url)
 441                                  (fboundp mew-ext-prog-url))
 442                             (symbol-name mew-ext-prog-url))
 443                            ((stringp mew-ext-prog-url) mew-ext-prog-url)
 444                            (t "none"))))
 445      (if (null execute)
 446          (insert "\nTo show this URL, type "
 447                  (substitute-command-keys
 448                   "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'."))
 449        (cond
 450         ((and (symbolp mew-ext-prog-url) (fboundp mew-ext-prog-url))
 451          (funcall mew-ext-prog-url url))
 452         ((equal mew-ext-prog-url "w3")
 453          (require 'w3)
 454          (w3-fetch-other-frame url))
 455         (t
 456          (apply (function start-process)
 457                 (format "*mew %s*" mew-ext-prog-url)
 458                 mew-buffer-tmp mew-ext-prog-url
 459                 (append mew-ext-prog-url-args (list url)))))))))
 460
 461 ;;
 462 ;; include
 463 ;;
 464
 465 (defun mew-ext-include-local-file (params)
 466   (mew-flet
 467    (let* ((file (mew-syntax-get-param params "name")))
 468      (if (file-exists-p file)
 469          (insert-file-contents file)))))
 470
 471 (provide 'mew-ext)
 472
 473 ;;; Copyright Notice:
 474
 475 ;; Copyright (C) 1996, 1997, 1998, 1999 Mew developing team.
 476 ;; All rights reserved.
 477
 478 ;; Redistribution and use in source and binary forms, with or without
 479 ;; modification, are permitted provided that the following conditions
 480 ;; are met:
 481 ;;
 482 ;; 1. Redistributions of source code must retain the above copyright
 483 ;;    notice, this list of conditions and the following disclaimer.
 484 ;; 2. Redistributions in binary form must reproduce the above copyright
 485 ;;    notice, this list of conditions and the following disclaimer in the
 486 ;;    documentation and/or other materials provided with the distribution.
 487 ;; 3. Neither the name of the team nor the names of its contributors
 488 ;;    may be used to endorse or promote products derived from this software
 489 ;;    without specific prior written permission.
 490 ;;
 491 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 492 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 493 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 494 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 495 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 496 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 497 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 498 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 499 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 500 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 501 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 502
 503 ;;; mew-ext.el ends here