tm 7.38.

[elisp/tm.git] / tm-def.el

diff --git a/tm-def.el b/tm-def.el
index 5b6d5fb..d672cbe 100644 (file)
--- a/tm-def.el
+++ b/tm-def.el
@@ -6,13 +6,14 @@
 ;;;
 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;;; Version:
-;;;    $Id: tm-def.el,v 6.6 1995/09/24 22:24:17 morioka Exp $
+;;;    $Id: tm-def.el,v 7.7 1995/12/21 18:17:03 morioka Exp $
 ;;; Keywords: mail, news, MIME, multimedia, definition
 ;;;
 ;;; This file is part of tm (Tools for MIME).
 ;;;
 
 (require 'emu)
+(require 'tl-822)
 
 
 ;;; @ variables
@@ -30,6 +31,13 @@
     ))
 
 
+;;; @ constants
+;;;
+
+(defconst mime/output-buffer-name "*MIME-out*")
+(defconst mime/temp-buffer-name " *MIME-temp*")
+
+
 ;;; @ for various Emacs variants
 ;;;
 
@@ -91,7 +99,7 @@
   (if (fboundp browse-url-browser-function)
       (call-interactively browse-url-browser-function)
     (if (fboundp tm:mother-button-dispatcher)
-       (funcall tm:mother-button-dispatcher event)
+       (call-interactively tm:mother-button-dispatcher)
       )
     ))
 
@@ -103,6 +111,15 @@
 (defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
 (defconst mime/charset-regexp mime/token-regexp)
 
+(defconst mime/content-type-subtype-regexp
+  (concat mime/token-regexp "/" mime/token-regexp))
+(defconst mime/content-parameter-value-regexp
+  (concat "\\("
+         rfc822/quoted-string-regexp
+         "\\|[^; \t\n]*\\)"))
+
+(defconst mime/disposition-type-regexp mime/token-regexp)
+
 
 ;;; @@ Base64
 ;;;
@@ -134,6 +151,128 @@
   (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp))
 
 
+;;; @ rot13-47
+;;;
+;; caesar-region written by phr@prep.ai.mit.edu  Nov 86
+;; modified by tower@prep Nov 86
+;; gnus-caesar-region
+;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47.
+(defun tm:caesar-region (&optional n)
+  "Caesar rotation of region by N, default 13, for decrypting netnews.
+ROT47 will be performed for Japanese text in any case."
+  (interactive (if current-prefix-arg  ; Was there a prefix arg?
+                  (list (prefix-numeric-value current-prefix-arg))
+                (list nil)))
+  (cond ((not (numberp n)) (setq n 13))
+       (t (setq n (mod n 26))))        ;canonicalize N
+  (if (not (zerop n))          ; no action needed for a rot of 0
+      (progn
+       (if (or (not (boundp 'caesar-translate-table))
+               (/= (aref caesar-translate-table ?a) (+ ?a n)))
+           (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
+             (message "Building caesar-translate-table...")
+             (setq caesar-translate-table (make-vector 256 0))
+             (while (< i 256)
+               (aset caesar-translate-table i i)
+               (setq i (1+ i)))
+             (setq lower (concat lower lower) upper (upcase lower) i 0)
+             (while (< i 26)
+               (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
+               (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
+               (setq i (1+ i)))
+             ;; ROT47 for Japanese text.
+             ;; Thanks to ichikawa@flab.fujitsu.junet.
+             (setq i 161)
+             (let ((t1 (logior ?O 128))
+                   (t2 (logior ?! 128))
+                   (t3 (logior ?~ 128)))
+               (while (< i 256)
+                 (aset caesar-translate-table i
+                       (let ((v (aref caesar-translate-table i)))
+                         (if (<= v t1) (if (< v t2) v (+ v 47))
+                           (if (<= v t3) (- v 47) v))))
+                 (setq i (1+ i))))
+             (message "Building caesar-translate-table...done")))
+       (let ((from (region-beginning))
+             (to (region-end))
+             (i 0) str len)
+         (setq str (buffer-substring from to))
+         (setq len (length str))
+         (while (< i len)
+           (aset str i (aref caesar-translate-table (aref str i)))
+           (setq i (1+ i)))
+         (goto-char from)
+         (delete-region from to)
+         (insert str)))))
+
+
+;;; @ field
+;;;
+
+(defun tm:set-fields (sym field-list &optional regexp-sym)
+  (or regexp-sym
+      (setq regexp-sym
+           (let ((name (symbol-name sym)))
+             (intern
+              (concat (if (string-match "\\(.*\\)-list" name)
+                          (substring name 0 (match-end 1))
+                        name)
+                      "-regexp")
+              )))
+      )
+  (set sym field-list)
+  (set regexp-sym
+       (concat "^" (apply (function regexp-or) field-list) ":"))
+  )
+
+(defun tm:add-fields (sym field-list &optional regexp-sym)
+  (or regexp-sym
+      (setq regexp-sym
+           (let ((name (symbol-name sym)))
+             (intern
+              (concat (if (string-match "\\(.*\\)-list" name)
+                          (substring name 0 (match-end 1))
+                        name)
+                      "-regexp")
+              )))
+      )
+  (let ((fields (eval sym)))
+    (mapcar (function
+            (lambda (field)
+              (or (member field fields)
+                  (setq fields (cons field fields))
+                  )
+              ))
+           (reverse field-list)
+           )
+    (set regexp-sym
+        (concat "^" (apply (function regexp-or) fields) ":"))
+    (set sym fields)
+    ))
+
+(defun tm:delete-fields (sym field-list &optional regexp-sym)
+  (or regexp-sym
+      (setq regexp-sym
+           (let ((name (symbol-name sym)))
+             (intern
+              (concat (if (string-match "\\(.*\\)-list" name)
+                          (substring name 0 (match-end 1))
+                        name)
+                      "-regexp")
+              )))
+      )
+  (let ((fields (eval sym)))
+    (mapcar (function
+            (lambda (field)
+              (setq fields (delete field fields))
+              ))
+           field-list)
+    (set regexp-sym
+        (concat "^" (apply (function regexp-or) fields) ":"))
+    (set sym fields)
+    ))
+
+
 ;;; @ end
 ;;;