X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=semi-def.el;h=d4b13e7329b0b64fca2254e8023fb751df140c23;hb=3576092ee59c7dc2925cf6491f04007376218644;hp=c7c5b172bafa3641239dbc57977c8d3213a8e8a3;hpb=48114547f447a7b5fc5c17e2325b6455b437dec7;p=elisp%2Fsemi.git

diff --git a/semi-def.el b/semi-def.el
index c7c5b17..d4b13e7 100644
--- a/semi-def.el
+++ b/semi-def.el
@@ -19,23 +19,22 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Code:
 
-(require 'poe)
-
 (eval-when-compile (require 'cl))
 
 (require 'custom)
 
-(defconst mime-user-interface-product ["REMI" (1 14 2) "Hokuhoku-Òshima"]
+(defconst mime-user-interface-product ["EMIKO" (1 14 1) "Choanoflagellata"]
   "Product name, version number and code name of MIME-kernel package.")
 
 (autoload 'mule-caesar-region "mule-caesar"
   "Caesar rotation of current region." t)
 
+(autoload 'widget-convert-button "wid-edit")
 
 ;;; @ constants
 ;;;
@@ -49,119 +48,107 @@
 ;;; @ button
 ;;;
 
-(defcustom mime-button-face 'bold
-  "Face used for content-button or URL-button of MIME-Preview buffer."
-  :group 'mime
-  :type 'face)
-
-(defcustom mime-button-mouse-face 'highlight
-  "Face used for MIME-preview buffer mouse highlighting."
-  :group 'mime
-  :type 'face)
-
-(defsubst mime-add-button (from to function &optional data)
-  "Create a button between FROM and TO with callback FUNCTION and DATA."
-  (and mime-button-face
-       (put-text-property from to 'face mime-button-face))
-  (and mime-button-mouse-face
-       (put-text-property from to 'mouse-face mime-button-mouse-face))
-  (put-text-property from to 'mime-button-callback function)
-  (and data
-       (put-text-property from to 'mime-button-data data))
-  )
+(define-widget 'mime-button 'link
+  "Widget for MIME button."
+  :action 'mime-button-action)
 
+(defun mime-button-action (widget &optional event)
+  (let ((function (widget-get widget :mime-button-callback))
+	(data (widget-get widget :mime-button-data)))
+    (when function
+      (funcall function data))))
+    
 (defsubst mime-insert-button (string function &optional data)
   "Insert STRING as button with callback FUNCTION and DATA."
   (save-restriction
     (narrow-to-region (point)(point))
-    (insert (concat "[" string "]\n"))
-    (mime-add-button (point-min)(point-max) function data)
-    ))
-
-(defvar mime-button-mother-dispatcher nil)
-
-(defun mime-button-dispatcher (event)
-  "Select the button under point."
-  (interactive "e")
-  (let (buf point func data)
-    (save-window-excursion
-      (mouse-set-point event)
-      (setq buf (current-buffer)
-	    point (point)
-	    func (get-text-property (point) 'mime-button-callback)
-	    data (get-text-property (point) 'mime-button-data)
-	    ))
-    (save-excursion
-      (set-buffer buf)
-      (goto-char point)
-      (if func
-	  (apply func data)
-	(if (fboundp mime-button-mother-dispatcher)
-	    (funcall mime-button-mother-dispatcher event)
-	  )))))
+    ;; Maybe we should introduce button formatter such as
+    ;; `gnus-mime-button-line-format'.
+    (insert "[" string "]")
+    ;; XEmacs -- when `widget-glyph-enable' is non nil, widget values are not
+    ;; guaranteed to be underlain.
+    (widget-convert-button 'mime-button (point-min)(point-max)
+			   :mime-button-callback function
+			   :mime-button-data data)
+    (insert "\n")))
 
 
 ;;; @ for URL
 ;;;
 
 (defcustom mime-browse-url-regexp
-  (concat "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):"
+  (concat "\\(https?\\|ftps?\\|file\\|gopher\\|news\\|nntps?\\|telnets?\\|wais\\|mailto\\):"
 	  "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
-	  "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
-  "*Regexp to match URL in text body."
+	  "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,;]*[-a-zA-Z0-9_=#$@~`%&*+|\\/;]")
+  "Regexp to match URL in text body."
   :group 'mime
   :type 'regexp)
 
 (defcustom mime-browse-url-function (function browse-url)
-  "*Function to browse URL."
+  "Function to browse URL."
   :group 'mime
   :type 'function)
 
+(define-widget 'mime-url-link 'url-link
+  "A link to an www page.")
+
 (defsubst mime-add-url-buttons ()
   "Add URL-buttons for text body."
   (goto-char (point-min))
   (while (re-search-forward mime-browse-url-regexp nil t)
-    (let ((beg (match-beginning 0))
-	  (end (match-end 0)))
-      (mime-add-button beg end mime-browse-url-function
-		       (list (buffer-substring beg end))))))
+    (widget-convert-button 'mime-url-link (match-beginning 0)(match-end 0)
+			   (match-string-no-properties 0))))
 
 
 ;;; @ menu
 ;;;
 
-(if window-system
-    (if (featurep 'xemacs)
-	(defun select-menu-alist (title menu-alist)
-	  (let (ret)
-	    (popup-menu
-	     (list* title
-		    "---"
-		    (mapcar (function
-			     (lambda (cell)
-			       (vector (car cell)
-				       `(progn
-					  (setq ret ',(cdr cell))
-					  (throw 'exit nil)
-					  )
-				       t)
-			       ))
-			    menu-alist)
-		    ))
-	    (recursive-edit)
-	    ret))
-      (defun select-menu-alist (title menu-alist)
-	(x-popup-menu
-	 (list '(1 1) (selected-window))
-	 (list title (cons title menu-alist))
-	 ))
-      )
-  (defun select-menu-alist (title menu-alist)
-    (cdr
-     (assoc (completing-read (concat title " : ") menu-alist)
-	    menu-alist)
-     ))
-  )
+(defmacro mime-popup-menu-bogus-filter-constructor (menu)
+  ;; #### Kludge for FSF Emacs-style menu.
+  (let ((bogus-menu (make-symbol "bogus-menu")))
+    `(let (,bogus-menu selection function)
+       (easy-menu-define ,bogus-menu nil nil ,menu)
+       (setq selection (x-popup-menu t ,bogus-menu))
+       (when selection
+	 (setq function (lookup-key ,bogus-menu (apply #'vector selection)))
+	 ;; If a callback entry has no name, easy-menu wraps its value.
+	 ;; See `easy-menu-make-symbol'.
+	 (if (eq t (compare-strings "menu-function-" 0 nil
+				    (symbol-name function) 0 14))
+	     (car (last (symbol-function function)))
+	   function)))))
+
+;;; While XEmacs can have both X and tty frames at the same time with
+;;; gnuclient, we shouldn't emulate in text-mode here.
+
+(static-if (featurep 'xemacs)
+    (defalias 'mime-popup-menu-popup 'popup-menu)
+  (defun mime-popup-menu-popup (menu &optional event)
+    (let ((function (mime-popup-menu-bogus-filter-constructor menu)))
+      (when (symbolp function)
+	(funcall function)))))
+
+(static-if (featurep 'xemacs)
+    (defun mime-popup-menu-select (menu &optional event)
+      (let ((selection (get-popup-menu-response menu event)))
+	(event-object selection)))
+  (defun mime-popup-menu-select (menu &optional event)
+    (mime-popup-menu-bogus-filter-constructor menu)))
+
+(static-if (featurep 'xemacs)
+    (defun mime-should-use-popup-menu ()
+      (mouse-event-p last-command-event))
+  (defun mime-should-use-popup-menu ()
+    (memq (event-basic-type last-command-event) '(mouse-1 mouse-2 mouse-3))))
+
+(defun mime-menu-select (prompt menu &optional event)
+  (if (mime-should-use-popup-menu)
+      (mime-popup-menu-select menu event)
+    (let ((rest (cdr menu)))
+      (while rest
+	(setcar rest (append (car rest) nil))
+	(setq rest (cdr rest)))
+      (nth 1 (assoc (completing-read prompt (cdr menu)) (cdr menu))))))
 
 
 ;;; @ Other Utility
@@ -193,13 +180,9 @@ activate."
 		(funcall func sym condition)
 		(if file
 		    (let ((method (cdr (assq 'method condition))))
-		      (autoload method file)
-		      ))
-		)
-	    (error "Function for mode `%s' is not found." mode)
-	    ))
-      (error "Variable for target-type `%s' is not found." target-type)
-      )))
+		      (autoload method file))))
+	    (error "Function for mode `%s' is not found." mode)))
+      (error "Variable for target-type `%s' is not found." target-type))))
 
 
 ;;; @ end