tm-def.el

   1 ;;;
   2 ;;; tm-def.el --- definition module for tm
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version:
   9 ;;;     $Id: tm-def.el,v 7.55 1996/07/11 15:26:54 morioka Exp $
  10 ;;; Keywords: mail, news, MIME, multimedia, definition
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14 ;;; This program is free software; you can redistribute it and/or
  15 ;;; modify it under the terms of the GNU General Public License as
  16 ;;; published by the Free Software Foundation; either version 2, or
  17 ;;; (at your option) any later version.
  18 ;;;
  19 ;;; This program is distributed in the hope that it will be useful,
  20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;;; General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with This program.  If not, write to the Free Software
  26 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27 ;;;
  28 ;;; Code:
  29
  30 (require 'emu)
  31 (require 'tl-822)
  32
  33
  34 ;;; @ variables
  35 ;;;
  36
  37 (defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/"))
  38
  39 (defvar mime/use-multi-frame
  40   (and (>= emacs-major-version 19) window-system))
  41
  42 (defvar mime/find-file-function
  43   (if mime/use-multi-frame
  44       (function find-file-other-frame)
  45     (function find-file)
  46     ))
  47
  48
  49 ;;; @ constants
  50 ;;;
  51
  52 (defconst mime/output-buffer-name "*MIME-out*")
  53 (defconst mime/temp-buffer-name " *MIME-temp*")
  54
  55
  56 ;;; @ charset and encoding
  57 ;;;
  58
  59 (defvar mime-charset-type-list
  60   '((us-ascii           7 nil)
  61     (iso-8859-1         8 "quoted-printable")
  62     (iso-8859-2         8 "quoted-printable")
  63     (iso-8859-3         8 "quoted-printable")
  64     (iso-8859-4         8 "quoted-printable")
  65     (iso-8859-5         8 "quoted-printable")
  66     (koi8-r             8 "quoted-printable")
  67     (iso-8859-7         8 "quoted-printable")
  68     (iso-8859-8         8 "quoted-printable")
  69     (iso-8859-9         8 "quoted-printable")
  70     (iso-2022-jp        7 "base64")
  71     (iso-2022-kr        7 "base64")
  72     (euc-kr             8 "base64")
  73     (big5               8 "base64")
  74     (iso-2022-jp-2      7 "base64")
  75     (iso-2022-int-1     7 "base64")
  76     ))
  77
  78 (defun mime/encoding-name (transfer-level &optional not-omit)
  79   (cond ((> transfer-level 8) "binary")
  80         ((= transfer-level 8) "8bit")
  81         (not-omit "7bit")
  82         ))
  83
  84 (defun mime/make-charset-default-encoding-alist (transfer-level)
  85   (mapcar (function
  86            (lambda (charset-type)
  87              (let ((charset  (upcase (symbol-name (car charset-type))))
  88                    (type     (nth 1 charset-type))
  89                    (encoding (nth 2 charset-type))
  90                    )
  91                (if (<= type transfer-level)
  92                    (cons charset (mime/encoding-name type))
  93                  (cons charset encoding)
  94                  ))))
  95           mime-charset-type-list))
  96
  97
  98 ;;; @ coding-system
  99 ;;;
 100
 101 (defvar mime/charset-coding-system-alist
 102   (let* (csl
 103          (f (if (and running-xemacs-20 (featurep 'mule))
 104                 (progn
 105                   (setq csl (coding-system-list))
 106                   (function
 107                    (lambda (a cell)
 108                      (if (memq (cdr cell) csl)
 109                          (cons cell a)
 110                        a))))
 111               (function
 112                (lambda (a cell)
 113                  (let ((sym (symbol-concat "*" (cdr cell) "*")))
 114                    (if (boundp sym)
 115                        (cons (cons (car cell) (symbol-value sym)) a)
 116                      a))))
 117               )))
 118     (foldr f nil
 119            '(("ISO-2022-JP"     . junet)
 120              ("ISO-2022-KR"     . iso-2022-kr)
 121              ("EUC-KR"          . euc-kr)
 122              ("GB2312"          . euc-china)
 123              ("ISO-8859-1"      . ctext)
 124              ("ISO-8859-2"      . iso-8859-2)
 125              ("ISO-8859-3"      . iso-8859-3)
 126              ("ISO-8859-4"      . iso-8859-4)
 127              ("ISO-8859-5"      . iso-8859-5)
 128              ("KOI8-R"          . koi8)
 129              ("ISO-8859-7"      . iso-8859-7)
 130              ("ISO-8859-8"      . iso-8859-8)
 131              ("ISO-8859-9"      . iso-8859-9)
 132              ("ISO-2022-JP-2"   . iso-2022-ss2-7)
 133              ("X-ISO-2022-JP-2" . iso-2022-ss2-7)
 134              ("ISO-2022-INT-1"  . iso-2022-int-1)
 135              ("SHIFT_JIS"       . sjis)
 136              ("X-SHIFTJIS"      . sjis)
 137              ("BIG5"            . big5)
 138              ))))
 139
 140 (defvar mime/default-coding-system *ctext*)
 141
 142 (defun mime-charset-decode-string (str charset)
 143   (let ((cs (assoc charset mime/charset-coding-system-alist)))
 144     (if cs
 145         (character-decode-string str (cdr cs))
 146       )))
 147
 148 (defun mime-charset-decode-region (beg end charset &optional encoding)
 149   (let ((ct
 150          (if (stringp charset)
 151              (cdr (assoc (upcase charset) mime/charset-coding-system-alist))
 152            mime/default-coding-system)))
 153     (if ct
 154         (character-decode-region beg end ct)
 155       )))
 156
 157
 158 ;;; @ button
 159 ;;;
 160
 161 (defun tm:set-face-region (b e face)
 162   (let ((overlay (tl:make-overlay b e)))
 163     (tl:overlay-put overlay 'face face)
 164     ))
 165
 166 (setq tm:button-face 'bold)
 167 (setq tm:mouse-face 'highlight)
 168
 169 (defun tm:add-button (from to func &optional data)
 170   "Create a button between FROM and TO with callback FUNC and data DATA."
 171   (and tm:button-face
 172        (tl:overlay-put (tl:make-overlay from to) 'face tm:button-face))
 173   (tl:add-text-properties from to
 174                           (append (and tm:mouse-face
 175                                        (list 'mouse-face tm:mouse-face))
 176                                   (list 'tm-callback func)
 177                                   (and data (list 'tm-data data))
 178                                   ))
 179   )
 180
 181 (defvar tm:mother-button-dispatcher nil)
 182
 183 (defun tm:button-dispatcher (event)
 184   "Select the button under point."
 185   (interactive "e")
 186   (save-window-excursion
 187     (mouse-set-point event)
 188     (let ((func (get-text-property (point) 'tm-callback))
 189           (data (get-text-property (point) 'tm-data))
 190           )
 191       (if func
 192           (apply func data)
 193         (if (fboundp tm:mother-button-dispatcher)
 194             (funcall tm:mother-button-dispatcher event)
 195           )
 196         ))))
 197
 198
 199 ;;; @ for URL
 200 ;;;
 201
 202 (defvar tm:URL-regexp
 203   "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
 204
 205 (defvar browse-url-browser-function nil)
 206
 207 (defun tm:browse-url (&optional url)
 208   (if (fboundp browse-url-browser-function)
 209       (if url
 210         (funcall browse-url-browser-function url)
 211       (call-interactively browse-url-browser-function))
 212     (if (fboundp tm:mother-button-dispatcher)
 213         (call-interactively tm:mother-button-dispatcher)
 214       )
 215     ))
 216
 217
 218 ;;; @ definitions about MIME
 219 ;;;
 220
 221 (defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
 222 (defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
 223 (defconst mime/charset-regexp mime/token-regexp)
 224
 225 (defconst mime/content-type-subtype-regexp
 226   (concat mime/token-regexp "/" mime/token-regexp))
 227 (defconst mime/content-parameter-value-regexp
 228   (concat "\\("
 229           rfc822/quoted-string-regexp
 230           "\\|[^; \t\n]*\\)"))
 231
 232 (defconst mime/disposition-type-regexp mime/token-regexp)
 233
 234
 235 ;;; @@ Base64
 236 ;;;
 237
 238 (defconst base64-token-regexp "[A-Za-z0-9+/=]")
 239
 240 (defconst mime/B-encoded-text-regexp
 241   (concat "\\("
 242           base64-token-regexp
 243           base64-token-regexp
 244           base64-token-regexp
 245           base64-token-regexp
 246           "\\)+"))
 247 (defconst mime/B-encoding-and-encoded-text-regexp
 248   (concat "\\(B\\)\\?" mime/B-encoded-text-regexp))
 249
 250
 251 ;;; @@ Quoted-Printable
 252 ;;;
 253
 254 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
 255 (defconst quoted-printable-octet-regexp
 256   (concat "=[" quoted-printable-hex-chars
 257           "][" quoted-printable-hex-chars "]"))
 258
 259 (defconst mime/Q-encoded-text-regexp
 260   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
 261 (defconst mime/Q-encoding-and-encoded-text-regexp
 262   (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp))
 263
 264
 265 ;;; @ rot13-47
 266 ;;;
 267 ;; caesar-region written by phr@prep.ai.mit.edu  Nov 86
 268 ;; modified by tower@prep Nov 86
 269 ;; gnus-caesar-region
 270 ;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47.
 271 (defun tm:caesar-region (&optional n)
 272   "Caesar rotation of region by N, default 13, for decrypting netnews.
 273 ROT47 will be performed for Japanese text in any case."
 274   (interactive (if current-prefix-arg   ; Was there a prefix arg?
 275                    (list (prefix-numeric-value current-prefix-arg))
 276                  (list nil)))
 277   (cond ((not (numberp n)) (setq n 13))
 278         (t (setq n (mod n 26))))        ;canonicalize N
 279   (if (not (zerop n))           ; no action needed for a rot of 0
 280       (progn
 281         (if (or (not (boundp 'caesar-translate-table))
 282                 (/= (aref caesar-translate-table ?a) (+ ?a n)))
 283             (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
 284               (message "Building caesar-translate-table...")
 285               (setq caesar-translate-table (make-vector 256 0))
 286               (while (< i 256)
 287                 (aset caesar-translate-table i i)
 288                 (setq i (1+ i)))
 289               (setq lower (concat lower lower) upper (upcase lower) i 0)
 290               (while (< i 26)
 291                 (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
 292                 (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
 293                 (setq i (1+ i)))
 294               ;; ROT47 for Japanese text.
 295               ;; Thanks to ichikawa@flab.fujitsu.junet.
 296               (setq i 161)
 297               (let ((t1 (logior ?O 128))
 298                     (t2 (logior ?! 128))
 299                     (t3 (logior ?~ 128)))
 300                 (while (< i 256)
 301                   (aset caesar-translate-table i
 302                         (let ((v (aref caesar-translate-table i)))
 303                           (if (<= v t1) (if (< v t2) v (+ v 47))
 304                             (if (<= v t3) (- v 47) v))))
 305                   (setq i (1+ i))))
 306               (message "Building caesar-translate-table...done")))
 307         (let ((from (region-beginning))
 308               (to (region-end))
 309               (i 0) str len)
 310           (setq str (buffer-substring from to))
 311           (setq len (length str))
 312           (while (< i len)
 313             (aset str i (aref caesar-translate-table (aref str i)))
 314             (setq i (1+ i)))
 315           (goto-char from)
 316           (delete-region from to)
 317           (insert str)))))
 318
 319
 320 ;;; @ field
 321 ;;;
 322
 323 (defun tm:set-fields (sym field-list &optional regexp-sym)
 324   (or regexp-sym
 325       (setq regexp-sym
 326             (let ((name (symbol-name sym)))
 327               (intern
 328                (concat (if (string-match "\\(.*\\)-list" name)
 329                            (substring name 0 (match-end 1))
 330                          name)
 331                        "-regexp")
 332                )))
 333       )
 334   (set sym field-list)
 335   (set regexp-sym
 336        (concat "^" (apply (function regexp-or) field-list) ":"))
 337   )
 338
 339 (defun tm:add-fields (sym field-list &optional regexp-sym)
 340   (or regexp-sym
 341       (setq regexp-sym
 342             (let ((name (symbol-name sym)))
 343               (intern
 344                (concat (if (string-match "\\(.*\\)-list" name)
 345                            (substring name 0 (match-end 1))
 346                          name)
 347                        "-regexp")
 348                )))
 349       )
 350   (let ((fields (eval sym)))
 351     (mapcar (function
 352              (lambda (field)
 353                (or (member field fields)
 354                    (setq fields (cons field fields))
 355                    )
 356                ))
 357             (reverse field-list)
 358             )
 359     (set regexp-sym
 360          (concat "^" (apply (function regexp-or) fields) ":"))
 361     (set sym fields)
 362     ))
 363
 364 (defun tm:delete-fields (sym field-list &optional regexp-sym)
 365   (or regexp-sym
 366       (setq regexp-sym
 367             (let ((name (symbol-name sym)))
 368               (intern
 369                (concat (if (string-match "\\(.*\\)-list" name)
 370                            (substring name 0 (match-end 1))
 371                          name)
 372                        "-regexp")
 373                )))
 374       )
 375   (let ((fields (eval sym)))
 376     (mapcar (function
 377              (lambda (field)
 378                (setq fields (delete field fields))
 379                ))
 380             field-list)
 381     (set regexp-sym
 382          (concat "^" (apply (function regexp-or) fields) ":"))
 383     (set sym fields)
 384     ))
 385
 386
 387 ;;; @ end
 388 ;;;
 389
 390 (provide 'tm-def)
 391
 392 ;;; tm-def.el ends here