X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=2de022d67d8eeaa8c41c88892be8af5a8e97a92b;hb=ec0675c825f1dfb2cb225ddbcac984f8688b503e;hp=98197d7903a18be3e6f9ea951cf5431e301736d2;hpb=4217c945cb4682b2b982fb68b5670ef679bbce4c;p=gnus

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index 98197d790..2de022d67 100644
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -1,6 +1,6 @@
 ;;; gnus-xmas.el --- Gnus functions for XEmacs
 
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -27,10 +27,19 @@
 
 ;;; Code:
 
+(eval-when-compile
+  (autoload 'gnus-active "gnus" nil nil 'macro)
+  (autoload 'gnus-group-entry "gnus" nil nil 'macro)
+  (autoload 'gnus-info-level "gnus" nil nil 'macro)
+  (autoload 'gnus-info-marks "gnus" nil nil 'macro)
+  (autoload 'gnus-info-method "gnus" nil nil 'macro)
+  (autoload 'gnus-info-score "gnus" nil nil 'macro))
+
 (require 'text-props)
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
 (require 'wid-edit)
+(require 'run-at-time)
 
 (defgroup gnus-xmas nil
   "XEmacsoid support for Gnus"
@@ -95,27 +104,13 @@ Possibly the `etc' directory has not been installed.")))
 (defvar standard-display-table)
 (defvar gnus-tree-minimize-window)
 
-(defun gnus-xmas-set-text-properties (start end props &optional buffer)
-  "You should NEVER use this function.  It is ideologically blasphemous.
-It is provided only to ease porting of broken FSF Emacs programs."
-  (if (stringp buffer)
-      nil
-    (map-extents (lambda (extent ignored)
-		   (remove-text-properties
-		    start end
-		    (list (extent-property extent 'text-prop) nil)
-		    buffer)
-		   nil)
-		 buffer start end nil nil 'text-prop)
-    (gnus-add-text-properties start end props buffer)))
-
 (defun gnus-xmas-highlight-selected-summary ()
   ;; Highlight selected article in summary buffer
   (when gnus-summary-selected-face
     (when gnus-newsgroup-selected-overlay
       (delete-extent gnus-newsgroup-selected-overlay))
     (setq gnus-newsgroup-selected-overlay
-	  (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
+	  (make-extent (point-at-bol) (point-at-eol)))
     (set-extent-face gnus-newsgroup-selected-overlay
 		     gnus-summary-selected-face)))
 
@@ -248,7 +243,7 @@ call it with the value of the `gnus-data' text property."
 	  (select-window selected))))))
 
 ;; Select the lowest window on the frame.
-(defun gnus-xmas-appt-select-lowest-window ()
+(defun gnus-xmas-select-lowest-window ()
   (let* ((lowest-window (selected-window))
 	 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 	 (last-window (previous-window))
@@ -336,12 +331,10 @@ call it with the value of the `gnus-data' text property."
   (gnus-xmas-menu-add browse
     gnus-browse-menu))
 
-(defun gnus-xmas-grouplens-menu-add ()
-  (gnus-xmas-menu-add grouplens
-    gnus-grouplens-menu))
-
-(defun gnus-xmas-read-event-char ()
+(defun gnus-xmas-read-event-char (&optional prompt)
   "Get the next event."
+  (when prompt
+    (message "%s" prompt))
   (let ((event (next-command-event)))
     (sit-for 0)
     ;; We junk all non-key events.  Is this naughty?
@@ -388,10 +381,7 @@ call it with the value of the `gnus-data' text property."
   (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
   (defalias 'gnus-deactivate-mark 'ignore)
   (defalias 'gnus-window-edges 'window-pixel-edges)
-  
-  (if (and (<= emacs-major-version 19)
- 	   (< emacs-minor-version 14))
-      (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
+  (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all)
 
   (unless (boundp 'standard-display-table)
     (setq standard-display-table nil))
@@ -413,7 +403,10 @@ call it with the value of the `gnus-data' text property."
 	    'x-color-values
 	  (lambda (color)
 	    (color-instance-rgb-components
-	     (make-color-instance color))))))
+	     (make-color-instance color)))))
+
+  (unless (fboundp 'char-width)
+    (defalias 'char-width (lambda (ch) 1))))
 
 (defun gnus-xmas-redefine ()
   "Redefine lots of Gnus functions for XEmacs."
@@ -426,14 +419,15 @@ call it with the value of the `gnus-data' text property."
   (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
   (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
   (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
-  (defalias 'gnus-appt-select-lowest-window
-	'gnus-xmas-appt-select-lowest-window)
+  (defalias 'gnus-select-lowest-window
+    'gnus-xmas-select-lowest-window)
   (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
   (defalias 'gnus-character-to-event 'character-to-event)
   (defalias 'gnus-mode-line-buffer-identification
-	'gnus-xmas-mode-line-buffer-identification)
+    'gnus-xmas-mode-line-buffer-identification)
   (defalias 'gnus-key-press-event-p 'key-press-event-p)
   (defalias 'gnus-region-active-p 'region-active-p)
+  (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-image-type-available-p 'gnus-xmas-image-type-available-p)
@@ -447,7 +441,6 @@ call it with the value of the `gnus-data' text property."
   ;; -- didier
   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
-  (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
@@ -473,6 +466,7 @@ call it with the value of the `gnus-data' text property."
 			    :color-symbols
 			    (("thing" . ,(car gnus-logo-colors))
 			     ("shadow" . ,(cadr gnus-logo-colors))
+			     ("oort" . "#eeeeee")
 			     ("background" . ,(face-background 'default)))])
 			 ((featurep 'xbm)
 			  `[xbm :file ,logo-xbm])
@@ -555,6 +549,8 @@ If it is non-nil, it must be a toolbar.  The five valid values are
     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
+    [gnus-summary-mail-save
+     gnus-group-save-newsrc t "Save .newsrc files"] ; borrowed icon.
     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
   "The group buffer toolbar.")
 
@@ -612,6 +608,8 @@ If it is non-nil, it must be a toolbar.  The five valid values are
      gnus-summary-save-article-file t "Save article in file"]
     [gnus-summary-save-article
      gnus-summary-save-article t "Save article"]
+    [gnus-summary-cancel-article ; usenet : cancellation :: mail : deletion.
+     gnus-summary-delete-article t "Delete message"]
     [gnus-summary-catchup
      gnus-summary-catchup t "Catchup"]
     [gnus-summary-catchup-and-exit
@@ -645,41 +643,6 @@ XEmacs compatibility workaround."
    'call-process-region (point-min) (point-max) command t '(t nil) nil
    args))
 
-(defface gnus-x-face '((t (:foreground "black" :background "white")))
-  "Face to show X face"
-  :group 'gnus-xmas)
-
-(defun gnus-xmas-article-display-xface (data)
-  "Display the XFace in DATA."
-  (save-excursion
-    (let ((xface-glyph
-	   (cond
-	    ((featurep 'xface)
-	     (make-glyph (vector 'xface :data
-				 (concat "X-Face: " data))))
-	    ((featurep 'xpm)
-	     (let ((cur (current-buffer)))
-	       (save-excursion
-		 (gnus-set-work-buffer)
-		 (insert data)
-		 (let ((coding-system-for-read 'binary)
-		       (coding-system-for-write 'binary))
-		   (gnus-xmas-call-region "uncompface")
-		   (goto-char (point-min))
-		   (insert "/* Width=48, Height=48 */\n")
-		   (gnus-xmas-call-region "icontopbm")
-		   (gnus-xmas-call-region "ppmtoxpm")
-		   (make-glyph
-		    (vector 'xpm :data (buffer-string)))))))
-	    (t
-	     (make-glyph [nothing])))))
-      (set-glyph-face xface-glyph 'gnus-x-face)
-
-      (gnus-article-goto-header "from")
-      (gnus-put-image xface-glyph)
-      (gnus-add-wash-type 'xface)
-      (gnus-add-image 'xface xface-glyph))))
-
 (defvar gnus-xmas-modeline-left-extent
   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
     ext))
@@ -736,9 +699,9 @@ XEmacs compatibility workaround."
 	  (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
 	(text-property-any b e 'gnus-undeletable t))))
 
-(defun gnus-xmas-mime-button-menu (event)
+(defun gnus-xmas-mime-button-menu (event prefix)
   "Construct a context-sensitive menu of MIME commands."
-  (interactive "e")
+  (interactive "e\nP")
   (let ((response (get-popup-menu-response
 		   `("MIME Part"
 		     ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
@@ -750,7 +713,7 @@ XEmacs compatibility workaround."
 (defun gnus-group-add-icon ()
   "Add an icon to the current line according to `gnus-group-icon-list'."
   (let* ((p (point))
-	 (end (progn (end-of-line) (point)))
+	 (end (point-at-eol))
 	 ;; now find out where the line starts and leave point there.
 	 (beg (progn (beginning-of-line) (point))))
     (save-restriction
@@ -820,48 +783,76 @@ XEmacs compatibility workaround."
 		      gnus-mailing-list-menu))
 
 (defun gnus-xmas-image-type-available-p (type)
-  (featurep type))
+  (and window-system
+       (featurep (if (eq type 'pbm) 'xbm type))))
 
-(defun gnus-xmas-create-image (file &optional type data-p)
+(defun gnus-xmas-create-image (file &optional type data-p &rest props)
   (let ((type (if type
 		  (symbol-name type)
-		(car (last (split-string file "[.]"))))))
-    (if (equal type "xbm")
-	(make-glyph (list (cons 'x file)))
+		(car (last (split-string file "[.]")))))
+	(face (plist-get props :face))
+	glyph)
+    (when (equal type "pbm")
       (with-temp-buffer
-       (if data-p
-	   (insert file)
-	 (insert-file-contents file))
-       (make-glyph
-	(vector 
-	 (or (mm-image-type-from-buffer)
-	     (intern type))
-	 :data (buffer-string)))))))
-
-(defun gnus-xmas-put-image (glyph &optional string)
+	(if data-p
+	    (insert file)
+	  (insert-file-contents-literally file))
+	(shell-command-on-region (point-min) (point-max)
+				 "ppmtoxpm 2>/dev/null" t)
+	(setq file (buffer-string)
+	      type "xpm"
+	      data-p t)))
+    (setq glyph
+	  (if (equal type "xbm")
+	      (make-glyph (list (cons 'x file)))
+	    (with-temp-buffer
+	      (if data-p
+		  (insert file)
+		(insert-file-contents-literally file))
+	      (make-glyph
+	       (vector
+		(or (intern type)
+		    (mm-image-type-from-buffer))
+		:data (buffer-string))))))
+    (when face
+      (set-glyph-face glyph face))
+    glyph))
+
+(defun gnus-xmas-put-image (glyph &optional string category)
   "Insert STRING, but display GLYPH.
 Warning: Don't insert text immediately after the image."
   (let ((begin (point))
 	extent)
-    (if string 
+    (if (and (bobp) (not string))
+	(setq string " "))
+    (if string
 	(insert string)
       (setq begin (1- begin)))
     (setq extent (make-extent begin (point)))
-    (set-extent-property extent 'gnus-image t)
+    (set-extent-property extent 'gnus-image category)
     (set-extent-property extent 'duplicable t)
     (if string
 	(set-extent-property extent 'invisible t))
-    (set-extent-property extent 'end-glyph glyph)))
+    (set-extent-property extent 'end-glyph glyph))
+  glyph)
 
-(defun gnus-xmas-remove-image (image)
+(defun gnus-xmas-remove-image (image &optional category)
+  "Remove the image matching IMAGE and CATEGORY found first."
   (map-extents
    (lambda (ext unused)
      (when (equal (extent-end-glyph ext) image)
        (set-extent-property ext 'invisible nil)
-       (set-extent-property ext 'end-glyph nil))
-     nil)
-   nil nil nil nil nil 'gnus-image))
+       (set-extent-property ext 'end-glyph nil)
+       t))
+   nil nil nil nil nil 'gnus-image category))
+
+(defun gnus-xmas-assq-delete-all (key alist)
+  (let ((elem nil))
+    (while (setq elem (assq key alist))
+      (setq alist (delq elem alist)))
+    alist))
 
 (provide 'gnus-xmas)
 
+;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef
 ;;; gnus-xmas.el ends here