X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=41108ab602e6b9b81dcc585dd273499cc9ff9139;hp=f2a2312c88fdf9eedc9d14949d4f7e6add087b49;hb=789c31bee0f2558e907a9d174afae38fc44092d6;hpb=fbb39486ab1ba934ef9fb4384127751309fefa6d

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index f2a2312c8..41108ab60 100644
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -1,7 +1,6 @@
 ;;; gnus-xmas.el --- Gnus functions for XEmacs
 
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2005
-;;        Free Software Foundation, Inc.
+;; Copyright (C) 1995-2012 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -10,7 +9,7 @@
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -39,7 +38,7 @@
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
 (require 'wid-edit)
-(require 'timer-funcs)
+(require 'gnus-util)
 
 (defgroup gnus-xmas nil
   "XEmacsoid support for Gnus"
@@ -103,6 +102,9 @@ Possibly the `etc' directory has not been installed.")))
 (defvar gnus-mouse-2)
 (defvar standard-display-table)
 (defvar gnus-tree-minimize-window)
+;;`gnus-agent-mode' in gnus-agent.el will define it.
+(defvar gnus-agent-summary-mode)
+(defvar gnus-draft-mode)
 
 (defun gnus-xmas-highlight-selected-summary ()
   ;; Highlight selected article in summary buffer
@@ -171,18 +173,18 @@ displayed, no centering will be performed."
 	(i 32))
     ;; Nix out all the control chars...
     (while (>= (setq i (1- i)) 0)
-      (aset table i [??]))
+      (gnus-put-display-table i [??] table))
     ;; ... but not newline and cr, of course.  (cr is necessary for the
     ;; selective display).
-    (aset table ?\n nil)
-    (aset table ?\r nil)
+    (gnus-put-display-table ?\n nil table)
+    (gnus-put-display-table ?\r nil table)
     ;; We keep TAB as well.
-    (aset table ?\t nil)
+    (gnus-put-display-table ?\t nil table)
     ;; We nix out any glyphs over 126 below ctl-arrow.
     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
       (while (>= (setq i (1- i)) 127)
-	(unless (aref table i)
-	  (aset table i [??]))))
+	(unless (gnus-get-display-table i table)
+	  (gnus-put-display-table i [??] table))))
     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 
@@ -221,6 +223,10 @@ call it with the value of the `gnus-data' text property."
 		 (delete-extent extent)
 		 nil)))
 
+(defun gnus-xmas-overlays-in (beg end)
+  "Return a list of the extents that overlap the region BEG ... END."
+  (mapcar-extents #'identity nil nil beg end))
+
 (defun gnus-xmas-window-top-edge (&optional window)
   (nth 1 (window-pixel-edges window)))
 
@@ -334,7 +340,7 @@ call it with the value of the `gnus-data' text property."
 (defun gnus-xmas-read-event-char (&optional prompt)
   "Get the next event."
   (when prompt
-    (message "%s" prompt))
+    (display-message 'no-log (format "%s" prompt)))
   (let ((event (next-command-event)))
     (sit-for 0)
     ;; We junk all non-key events.  Is this naughty?
@@ -346,6 +352,45 @@ call it with the value of the `gnus-data' text property."
 	       (event-to-character event))
 	  event)))
 
+(defun gnus-xmas-article-describe-bindings (&optional prefix)
+  "Show a list of all defined keys, and their definitions.
+The optional argument PREFIX, if non-nil, should be a key sequence;
+then we display only bindings that start with that prefix."
+  (interactive)
+  (gnus-article-check-buffer)
+  (let ((keymap (copy-keymap gnus-article-mode-map))
+	(map (copy-keymap gnus-article-send-map))
+	(sumkeys (where-is-internal 'gnus-article-read-summary-keys))
+	parent agent draft)
+    (define-key keymap "S" map)
+    (set-keymap-default-binding map nil)
+    (with-current-buffer gnus-article-current-summary
+      (set-keymap-parent
+       keymap
+       (if (setq parent (keymap-parent gnus-article-mode-map))
+	   (prog1
+	       (setq parent (copy-keymap parent))
+	     (set-keymap-parent parent (current-local-map)))
+	 (current-local-map)))
+      (let ((def (key-binding "S"))
+	    gnus-pick-mode)
+	(set-keymap-parent map (if (symbolp def)
+				   (symbol-value def)
+				 def))
+	(dolist (key sumkeys)
+	  (when (setq def (key-binding key))
+	    (define-key keymap key def))))
+      (when (boundp 'gnus-agent-summary-mode)
+	(setq agent gnus-agent-summary-mode))
+      (when (boundp 'gnus-draft-mode)
+	(setq draft gnus-draft-mode)))
+    (with-temp-buffer
+      (setq major-mode 'gnus-article-mode)
+      (use-local-map keymap)
+      (set (make-local-variable 'gnus-agent-summary-mode) agent)
+      (set (make-local-variable 'gnus-draft-mode) draft)
+      (describe-bindings prefix))))
+
 (defun gnus-xmas-define ()
   (setq gnus-mouse-2 [button2])
   (setq gnus-mouse-3 [button3])
@@ -360,21 +405,20 @@ call it with the value of the `gnus-data' text property."
   (unless (face-differs-from-default-p 'underline)
     (funcall (intern "set-face-underline-p") 'underline t))
 
-  (cond
-   ((fboundp 'char-or-char-int-p)
-    ;; Handle both types of marks for XEmacs-20.x.
-    (defalias 'gnus-characterp 'char-or-char-int-p))
-   ;; V19 of XEmacs, probably.
-   (t
-    (defalias 'gnus-characterp 'characterp)))
+  (defalias 'gnus-make-overlay
+    (lambda (beg end &optional buffer front-advance rear-advance)
+      "Create a new overlay with range BEG to END in BUFFER.
+FRONT-ADVANCE and REAR-ADVANCE are ignored."
+      (make-extent beg end buffer)))
 
-  (defalias 'gnus-make-overlay 'make-extent)
   (defalias 'gnus-delete-overlay 'delete-extent)
+  (defalias 'gnus-overlay-get 'extent-property)
   (defalias 'gnus-overlay-put 'set-extent-property)
   (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
   (defalias 'gnus-overlay-buffer 'extent-object)
   (defalias 'gnus-overlay-start 'extent-start-position)
   (defalias 'gnus-overlay-end 'extent-end-position)
+  (defalias 'gnus-overlays-in 'gnus-xmas-overlays-in)
   (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
   (defalias 'gnus-extent-detached-p 'extent-detached-p)
   (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
@@ -383,6 +427,14 @@ call it with the value of the `gnus-data' text property."
   (defalias 'gnus-window-edges 'window-pixel-edges)
   (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all)
 
+  (unless (fboundp 'member-ignore-case)
+    (defun member-ignore-case (elt list)
+      (while (and list
+		  (or (not (stringp (car list)))
+		      (not (string= (downcase elt) (downcase (car list))))))
+	(setq list (cdr list)))
+      list))
+
   (unless (boundp 'standard-display-table)
     (setq standard-display-table nil))
 
@@ -398,13 +450,6 @@ call it with the value of the `gnus-data' text property."
   (unless (fboundp 'match-string-no-properties)
     (defalias 'match-string-no-properties 'match-string))
 
-  (defalias 'gnus-x-color-values
-	(if (fboundp 'x-color-values)
-	    'x-color-values
-	  (lambda (color)
-	    (color-instance-rgb-components
-	     (make-color-instance color)))))
-
   (unless (fboundp 'char-width)
     (defalias 'char-width (lambda (ch) 1))))
 
@@ -430,10 +475,14 @@ call it with the value of the `gnus-data' text property."
   (defalias 'gnus-mark-active-p 'region-exists-p)
   (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
   (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
+  (defalias 'gnus-mime-security-button-menu
+    'gnus-xmas-mime-security-button-menu)
   (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p)
   (defalias 'gnus-put-image 'gnus-xmas-put-image)
   (defalias 'gnus-create-image 'gnus-xmas-create-image)
   (defalias 'gnus-remove-image 'gnus-xmas-remove-image)
+  (defalias 'gnus-article-describe-bindings
+    'gnus-xmas-article-describe-bindings)
 
   ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
   ;; probably should. If that is done, the code below should then be moved
@@ -477,8 +526,7 @@ call it with the value of the `gnus-data' text property."
       (while (not (eobp))
 	(insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 			     ?\ ))
-	(forward-line 1))
-      (setq gnus-simple-splash nil))
+	(forward-line 1)))
     (goto-char (point-min))
     (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 	   (wheight (window-height))
@@ -657,38 +705,45 @@ the width is used for the toolbar displayed on the right or the left."
   (when (featurep 'toolbar)
     (if (and gnus-use-toolbar
 	     (message-xmas-setup-toolbar toolbar nil "gnus"))
-	(let* ((bar (or (intern-soft (format "%s-toolbar" gnus-use-toolbar))
-			'default-toolbar))
-	       (bars (delq bar (list 'top-toolbar 'bottom-toolbar
-				     'right-toolbar 'left-toolbar)))
-	       hw)
-	  (while bars
-	    (remove-specifier (symbol-value (pop bars)) (current-buffer)))
-	  (unless (eq bar 'default-toolbar)
-	    (set-specifier default-toolbar nil (current-buffer)))
-	  (set-specifier (symbol-value bar) toolbar (current-buffer))
-	  (when (setq hw (cdr (assq gnus-use-toolbar
-				    '((default . default-toolbar-height)
-				      (top . top-toolbar-height)
-				      (bottom . bottom-toolbar-height)))))
-	    (set-specifier (symbol-value hw) (car gnus-toolbar-thickness)
-			   (current-buffer)))
-	  (when (setq hw (cdr (assq gnus-use-toolbar
-				    '((default . default-toolbar-width)
-				      (right . right-toolbar-width)
-				      (left . left-toolbar-width)))))
-	    (set-specifier (symbol-value hw) (cdr gnus-toolbar-thickness)
-			   (current-buffer))))
-      (set-specifier default-toolbar nil (current-buffer))
-      (remove-specifier top-toolbar (current-buffer))
-      (remove-specifier bottom-toolbar (current-buffer))
-      (remove-specifier right-toolbar (current-buffer))
-      (remove-specifier left-toolbar (current-buffer)))
-    (set-specifier default-toolbar-visible-p t (current-buffer))
-    (set-specifier top-toolbar-visible-p t (current-buffer))
-    (set-specifier bottom-toolbar-visible-p t (current-buffer))
-    (set-specifier right-toolbar-visible-p t (current-buffer))
-    (set-specifier left-toolbar-visible-p t (current-buffer))))
+	(let ((bar (or (intern-soft (format "%s-toolbar" gnus-use-toolbar))
+		       'default-toolbar))
+	      (height (car gnus-toolbar-thickness))
+	      (width (cdr gnus-toolbar-thickness))
+	      (cur (current-buffer))
+	      bars)
+	  (set-specifier (symbol-value bar) toolbar cur)
+	  (set-specifier default-toolbar-height height cur)
+	  (set-specifier default-toolbar-width width cur)
+	  (set-specifier top-toolbar-height height cur)
+	  (set-specifier bottom-toolbar-height height cur)
+	  (set-specifier right-toolbar-width width cur)
+	  (set-specifier left-toolbar-width width cur)
+	  (if (eq bar 'default-toolbar)
+	      (progn
+		(remove-specifier default-toolbar-visible-p cur)
+		(remove-specifier top-toolbar cur)
+		(remove-specifier top-toolbar-visible-p cur)
+		(remove-specifier bottom-toolbar cur)
+		(remove-specifier bottom-toolbar-visible-p cur)
+		(remove-specifier right-toolbar cur)
+		(remove-specifier right-toolbar-visible-p cur)
+		(remove-specifier left-toolbar cur)
+		(remove-specifier left-toolbar-visible-p cur))
+	    (set-specifier (symbol-value (intern (format "%s-visible-p" bar)))
+			   t cur)
+	    (setq bars (delq bar (list 'default-toolbar
+				       'bottom-toolbar 'top-toolbar
+				       'right-toolbar 'left-toolbar)))
+	    (while bars
+	      (set-specifier (symbol-value (intern (format "%s-visible-p"
+							   (pop bars))))
+			     nil cur))))
+      (let ((cur (current-buffer)))
+	(set-specifier default-toolbar-visible-p nil cur)
+	(set-specifier top-toolbar-visible-p nil cur)
+	(set-specifier bottom-toolbar-visible-p nil cur)
+	(set-specifier right-toolbar-visible-p nil cur)
+	(set-specifier left-toolbar-visible-p nil cur)))))
 
 (defun gnus-xmas-setup-group-toolbar ()
   (gnus-xmas-setup-toolbar gnus-group-toolbar))
@@ -756,10 +811,6 @@ XEmacs compatibility workaround."
 	 (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 
-(defun gnus-xmas-splash ()
-  (when (eq (device-type) 'x)
-    (gnus-splash)))
-
 (defun gnus-xmas-annotation-in-region-p (b e)
   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
       (if (= b e)
@@ -777,86 +828,38 @@ XEmacs compatibility workaround."
     (goto-char (event-point event))
     (funcall (event-function response) (event-object response))))
 
-(defun gnus-group-add-icon ()
-  "Add an icon to the current line according to `gnus-group-icon-list'."
-  (let* ((p (point))
-	 (end (point-at-eol))
-	 ;; now find out where the line starts and leave point there.
-	 (beg (progn (beginning-of-line) (point))))
-    (save-restriction
-      (narrow-to-region beg end)
-      (goto-char beg)
-      (when (search-forward "==&&==" nil t)
-	(let* ((group (gnus-group-group-name))
-	       (entry (gnus-group-entry group))
-	       (unread (if (numberp (car entry)) (car entry) 0))
-	       (active (gnus-active group))
-	       (total (if active (1+ (- (cdr active) (car active))) 0))
-	       (info (nth 2 entry))
-	       (method (gnus-server-get-method group (gnus-info-method info)))
-	       (marked (gnus-info-marks info))
-	       (mailp (memq 'mail (assoc (symbol-name
-					  (car (or method gnus-select-method)))
-					 gnus-valid-select-methods)))
-	       (level (or (gnus-info-level info) gnus-level-killed))
-	       (score (or (gnus-info-score info) 0))
-	       (ticked (gnus-range-length (cdr (assq 'tick marked))))
-	       (group-age (gnus-group-timestamp-delta group))
-	       (inhibit-read-only t)
-	       (list gnus-group-icon-list)
-	       (mystart (match-beginning 0))
-	       (myend (match-end 0)))
-	  (goto-char (point-min))
-	  (while (and list
-		      (not (eval (caar list))))
-	    (setq list (cdr list)))
-	  (if list
-	      (let* ((file (cdar list))
-		     (glyph (gnus-group-icon-create-glyph
-			     (buffer-substring mystart myend)
-			     file)))
-		(if glyph
-		    (progn
-		      (mapcar 'delete-annotation (annotations-at myend))
-		      (let ((ext (make-extent mystart myend))
-			    (ant (make-annotation glyph myend 'text)))
-			;; set text extent params
-			(set-extent-property ext 'end-open t)
-			(set-extent-property ext 'start-open t)
-			(set-extent-property ext 'invisible t)))
-		  (delete-region mystart myend)))
-	    (delete-region mystart myend))))
-      (widen))
-    (goto-char p)))
-
-(defun gnus-group-icon-create-glyph (substring pixmap)
-  "Create a glyph for insertion into a group line."
-  (or
-   (cdr-safe (assoc pixmap gnus-group-icon-cache))
-   (let* ((glyph (make-glyph
-		  (list
-		   (cons 'x
-			 (expand-file-name pixmap gnus-xmas-glyph-directory))
-		   (cons 'mswindows
-			 (expand-file-name pixmap gnus-xmas-glyph-directory))
-		   (cons 'tty substring)))))
-     (setq gnus-group-icon-cache
-	   (cons (cons pixmap glyph) gnus-group-icon-cache))
-     (set-glyph-face glyph 'default)
-     glyph)))
+(defun gnus-xmas-mime-security-button-menu (event prefix)
+  "Construct a context-sensitive menu of security commands."
+  (interactive "e\nP")
+  (let ((response
+	 (get-popup-menu-response
+	  `("Security Part"
+	    ,@(delq nil
+		    (mapcar (lambda (c)
+			      (unless (eq (car c) 'undefined)
+				`[,(caddr c) ,(car c) t]))
+			    gnus-mime-security-button-commands))))))
+    (set-buffer (event-buffer event))
+    (goto-char (event-point event))
+    (funcall (event-function response) (event-object response))))
 
 (defun gnus-xmas-mailing-list-menu-add ()
   (gnus-xmas-menu-add mailing-list
 		      gnus-mailing-list-menu))
 
 (defun gnus-xmas-image-type-available-p (type)
-  (and window-system
+  (and (if (fboundp 'display-images-p)
+	   (display-images-p)
+	 window-system)
        (featurep (if (eq type 'pbm) 'xbm type))))
 
 (defun gnus-xmas-create-image (file &optional type data-p &rest props)
-  (let ((type (if type
-		  (symbol-name type)
-		(car (last (split-string file "[.]")))))
+  (let ((type (cond
+	       (type
+		(symbol-name type))
+	       ((and (not data-p)
+		     (string-match "[.]" file))
+		(car (last (split-string file "[.]"))))))
 	(face (plist-get props :face))
 	glyph)
     (when (equal type "pbm")
@@ -878,8 +881,9 @@ XEmacs compatibility workaround."
 		(insert-file-contents-literally file))
 	      (make-glyph
 	       (vector
-		(or (intern type)
-		    (mm-image-type-from-buffer))
+		(if type
+		    (intern type)
+		  (mm-image-type-from-buffer))
 		:data (buffer-string))))))
     (when face
       (set-glyph-face glyph face))
@@ -921,5 +925,4 @@ Warning: Don't insert text immediately after the image."
 
 (provide 'gnus-xmas)
 
-;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef
 ;;; gnus-xmas.el ends here