X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-spec.el;h=393c8a175e523bf77d0c8b1ffc80b923fcb490a3;hb=d9e28e3e79936d460820dfa09c278750eddc1649;hp=f493e9e9a1c8c54b560a6160c39bce614be5aed0;hpb=1372a8eaff0c093b7e513fd90966549b79558e42;p=gnus

diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el
index f493e9e9a..393c8a175 100644
--- a/lisp/gnus-spec.el
+++ b/lisp/gnus-spec.el
@@ -1,5 +1,5 @@
-;;; gnus-spec.el --- format spec functions for Gnus  -*- coding: iso-latin-1 -*-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;;; gnus-spec.el --- format spec functions for Gnus
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -30,11 +30,17 @@
 
 (require 'gnus)
 
-(defcustom gnus-use-correct-string-widths t
+(defcustom gnus-use-correct-string-widths (featurep 'xemacs)
   "*If non-nil, use correct functions for dealing with wide characters."
   :group 'gnus-format
   :type 'boolean)
 
+(defcustom gnus-make-format-preserve-properties (featurep 'xemacs)
+  "*If non-nil, use a replacement `format' function which preserves
+text properties. This is only needed on XEmacs, as FSF Emacs does this anyway."
+  :group 'gnus-format
+  :type 'boolean)
+
 ;;; Internal variables.
 
 (defvar gnus-summary-mark-positions nil)
@@ -74,6 +80,8 @@
 (defvar gnus-tmp-article-number)
 (defvar gnus-mouse-face)
 (defvar gnus-mouse-face-prop)
+(defvar gnus-tmp-header)
+(defvar gnus-tmp-from)
 
 (defun gnus-summary-line-format-spec ()
   (insert gnus-tmp-unread gnus-tmp-replied
@@ -82,13 +90,15 @@
    (point)
    (progn
      (insert
-      gnus-tmp-opening-bracket
-      (format "%4d: %-20s"
-	      gnus-tmp-lines
-	      (if (> (length gnus-tmp-name) 20)
-		  (substring gnus-tmp-name 0 20)
-		gnus-tmp-name))
-      gnus-tmp-closing-bracket)
+      (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines
+	      (let ((val
+		     (inline
+		       (gnus-summary-from-or-to-or-newsgroups
+			gnus-tmp-header gnus-tmp-from))))
+		(if (> (length val) 23)
+		    (substring val 0 23)
+		  val))
+	      gnus-tmp-closing-bracket))
      (point))
    gnus-mouse-face-prop gnus-mouse-face)
   (insert " " gnus-tmp-subject-or-nil "\n"))
@@ -129,10 +139,12 @@
     (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)
     (summary-dummy "*  %(:                          :%) %S\n"
 		   ,gnus-summary-dummy-line-format-spec)
-    (summary "%U\%R\%z\%I\%(%[%4L: %-23,23n%]%) %s\n"
+    (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
 	     ,gnus-summary-line-format-spec))
   "Alist of format specs.")
 
+(defvar gnus-default-format-specs gnus-format-specs)
+
 (defvar gnus-article-mode-line-format-spec nil)
 (defvar gnus-summary-mode-line-format-spec nil)
 (defvar gnus-group-mode-line-format-spec nil)
@@ -175,8 +187,9 @@
   ;; Make the indentation array.
   ;; See whether all the stored info needs to be flushed.
   (when (or force
+	    (not gnus-newsrc-file-version)
 	    (not (equal (gnus-continuum-version)
-			(cdr (assq 'gnus-version gnus-format-specs))))
+			(gnus-continuum-version gnus-newsrc-file-version)))
 	    (not (equal emacs-version
 			(cdr (assq 'version gnus-format-specs)))))
     (setq gnus-format-specs nil))
@@ -251,18 +264,28 @@
 (defun gnus-balloon-face-function (form type)
   `(gnus-put-text-property
     (point) (progn ,@form (point))
-    'balloon-help
+    ,(if (fboundp 'balloon-help-mode)
+	 ''balloon-help
+       ''help-echo)
     ,(intern (format "gnus-balloon-face-%d" type))))
 
 (defun gnus-spec-tab (column)
   (if (> column 0)
       `(insert (make-string (max (- ,column (current-column)) 0) ? ))
-    `(progn
-       (if (> (current-column) ,(abs column))
-	   (delete-region (point)
-			  (- (point) (- (current-column) ,(abs column))))
-	 (insert (make-string (max (- ,(abs column) (current-column)) 0)
-			      ? ))))))
+    (let ((column (abs column)))
+      (if gnus-use-correct-string-widths
+	  `(progn
+	     (if (> (current-column) ,column)
+		 (while (progn
+			  (delete-backward-char 1)
+			  (> (current-column) ,column))))
+	     (insert (make-string (max (- ,column (current-column)) 0) ? )))
+	`(progn
+	   (if (> (current-column) ,column)
+	       (delete-region (point)
+			      (- (point) (- (current-column) ,column)))
+	     (insert (make-string (max (- ,column (current-column)) 0)
+				  ? ))))))))
 
 (defun gnus-correct-length (string)
   "Return the correct width of STRING."
@@ -276,7 +299,7 @@
 	(wseek 0)
 	(seek 0)
 	(length (length string))
-	(string (concat string "\0"))) 
+	(string (concat string "\0")))
     ;; Find the start position.
     (while (and (< seek length)
 		(< wseek start))
@@ -292,15 +315,29 @@
     (setq wend seek)
     (substring string wstart (1- wend))))
 
+(defun gnus-string-width-function ()
+  (cond
+   (gnus-use-correct-string-widths
+    'gnus-correct-length)
+   ((fboundp 'string-width)
+    'string-width)
+   (t
+    'length)))
+
+(defun gnus-substring-function ()
+  (cond
+   (gnus-use-correct-string-widths
+    'gnus-correct-substring)
+   ((fboundp 'string-width)
+    'gnus-correct-substring)
+   (t
+    'substring)))
+
 (defun gnus-tilde-max-form (el max-width)
   "Return a form that limits EL to MAX-WIDTH."
   (let ((max (abs max-width))
-	(length-fun (if gnus-use-correct-string-widths
-		      'gnus-correct-length
-		    'length))
-	(substring-fun (if gnus-use-correct-string-widths
-		       'gnus-correct-substring
-		     'substring)))
+	(length-fun (gnus-string-width-function))
+	(substring-fun (gnus-substring-function)))
     (if (symbolp el)
 	`(if (> (,length-fun ,el) ,max)
 	     ,(if (< max-width 0)
@@ -317,12 +354,8 @@
 (defun gnus-tilde-cut-form (el cut-width)
   "Return a form that cuts CUT-WIDTH off of EL."
   (let ((cut (abs cut-width))
-	(length-fun (if gnus-use-correct-string-widths
-		      'gnus-correct-length
-		    'length))
-	(substring-fun (if gnus-use-correct-string-widths
-		       'gnus-correct-substring
-		     'substring)))
+	(length-fun (gnus-string-width-function))
+	(substring-fun (gnus-substring-function)))
     (if (symbolp el)
 	`(if (> (,length-fun ,el) ,cut)
 	     ,(if (< cut-width 0)
@@ -345,6 +378,28 @@
        (if (equal val ,ignore-value)
 	   "" val))))
 
+(defun gnus-pad-form (el pad-width)
+  "Return a form that pads EL to PAD-WIDTH accounting for multi-column
+characters correctly. This is because `format' may pad to columns or to
+characters when given a pad value."
+  (let ((pad (abs pad-width))
+	(side (< 0 pad-width))
+	(length-fun (gnus-string-width-function)))
+    (if (symbolp el)
+	`(let ((need (- ,pad (,length-fun ,el))))
+	   (if (> need 0)
+	       (concat ,(when side '(make-string need ?\ ))
+		       ,el
+		       ,(when (not side) '(make-string need ?\ )))
+	     ,el))
+      `(let* ((val (eval ,el))
+	      (need (- ,pad (,length-fun val))))
+	 (if (> need 0)
+	     (concat ,(when side '(make-string need ?\ ))
+		     val
+		     ,(when (not side) '(make-string need ?\ )))
+	   val)))))
+
 (defun gnus-parse-format (format spec-alist &optional insert)
   ;; This function parses the FORMAT string with the help of the
   ;; SPEC-ALIST and returns a list that can be eval'ed to return the
@@ -354,54 +409,60 @@
   ;; them will have the balloon-help text property.
   (let ((case-fold-search nil))
     (if (string-match
-       "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
-       format)
-      (gnus-parse-complex-format format spec-alist)
+	 "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*"
+	 format)
+	(gnus-parse-complex-format format spec-alist)
       ;; This is a simple format.
       (gnus-parse-simple-format format spec-alist insert))))
 
 (defun gnus-parse-complex-format (format spec-alist)
-  (save-excursion
-    (gnus-set-work-buffer)
-    (insert format)
-    (goto-char (point-min))
-    (while (re-search-forward "\"" nil t)
-      (replace-match "\\\"" nil t))
-    (goto-char (point-min))
-    (insert "(\"")
-    ;; Convert all font specs into font spec lists.
-    (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
-      (let ((number (if (match-beginning 1)
-			(match-string 1) "0"))
-	    (delim (aref (match-string 2) 0)))
-	(if (or (= delim ?\()
-		(= delim ?\{)
-		(= delim ?\«))
-	    (replace-match (concat "\"("
-				   (cond ((= delim ?\() "mouse")
-					 ((= delim ?\{) "face")
-					 (t "balloon"))
-				   " " number " \"")
-			   t t)
-	  (replace-match "\")\""))))
-    (goto-char (point-max))
-    (insert "\")")
-    ;; Convert point position commands.
-    (goto-char (point-min))
-    (let ((case-fold-search nil))
-      (while (re-search-forward "%\\([-0-9]+\\)?C" nil t)
-	(replace-match "\"(point)\"" t t)))
-    ;; Convert TAB commands.
-    (goto-char (point-min))
-    (while (re-search-forward "%\\([-0-9]+\\)=" nil t)
-      (replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
-    ;; Convert the buffer into the spec.
-    (goto-char (point-min))
-    (let ((form (read (current-buffer))))
-      ;; If the first element is '(point), we just remove it.
-      (when (equal (car form) '(point))
-	(pop form))
-      (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
+  (let ((cursor-spec nil))
+    (save-excursion
+      (gnus-set-work-buffer)
+      (insert format)
+      (goto-char (point-min))
+      (while (re-search-forward "\"" nil t)
+	(replace-match "\\\"" nil t))
+      (goto-char (point-min))
+      (insert "(\"")
+      ;; Convert all font specs into font spec lists.
+      (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
+	(let ((number (if (match-beginning 1)
+			  (match-string 1) "0"))
+	      (delim (aref (match-string 2) 0)))
+	  (if (or (= delim ?\()
+		  (= delim ?\{)
+		  (= delim ?\«))
+	      (replace-match (concat "\"("
+				     (cond ((= delim ?\() "mouse")
+					   ((= delim ?\{) "face")
+					   (t "balloon"))
+				     " " number " \"")
+			     t t)
+	    (replace-match "\")\""))))
+      (goto-char (point-max))
+      (insert "\")")
+      ;; Convert point position commands.
+      (goto-char (point-min))
+      (let ((case-fold-search nil))
+	(while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t)
+	  (replace-match "\"(point)\"" t t)
+	  (setq cursor-spec t)))
+      ;; Convert TAB commands.
+      (goto-char (point-min))
+      (while (re-search-forward "%\\([-0-9]+\\)=" nil t)
+	(replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
+      ;; Convert the buffer into the spec.
+      (goto-char (point-min))
+      (let ((form (read (current-buffer))))
+	(if cursor-spec
+	    `(let (gnus-position)
+	       ,@(gnus-complex-form-to-spec form spec-alist)
+	       (if gnus-position
+		   (gnus-put-text-property gnus-position (1+ gnus-position)
+					   'gnus-position t)))
+	  `(progn
+	     ,@(gnus-complex-form-to-spec form spec-alist)))))))
 
 (defun gnus-complex-form-to-spec (form spec-alist)
   (delq nil
@@ -411,7 +472,7 @@
 	    ((stringp sform)
 	     (gnus-parse-simple-format sform spec-alist t))
 	    ((eq (car sform) 'point)
-	     `(gnus-put-text-property (1- (point)) (point) 'gnus-position t))
+	     '(setq gnus-position (point)))
 	    ((eq (car sform) 'tab)
 	     (gnus-spec-tab (cadr sform)))
 	    (t
@@ -420,6 +481,41 @@
 		      (nth 1 sform)))))
 	 form)))
 
+
+(defun gnus-xmas-format (fstring &rest args)
+  "A version of `format' which preserves text properties.
+
+Required for XEmacs, where the built in `format' function strips all text
+properties from both the format string and any inserted strings.
+
+Only supports the format sequence %s, and %% for inserting
+literal % characters. A pad width and an optional - (to right pad)
+are supported for %s."
+  (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s")
+	(n (length args)))
+    (with-temp-buffer
+      (insert fstring)
+      (goto-char (point-min))
+      (while (re-search-forward re nil t)
+	(goto-char (match-end 0))
+	(cond
+	 ((string= (match-string 0) "%%")
+	  (delete-char -1))
+	 (t
+	  (if (null args)
+	      (error 'wrong-number-of-arguments #'my-format n fstring))
+	  (let* ((minlen (string-to-int (or (match-string 2) "")))
+		 (arg (car args))
+		 (str (if (stringp arg) arg (format "%s" arg)))
+		 (lpad (null (match-string 1)))
+		 (padlen (max 0 (- minlen (length str)))))
+	    (replace-match "")
+	    (if lpad (insert-char ?\  padlen))
+	    (insert str)
+	    (unless lpad (insert-char ?\  padlen))
+	    (setq args (cdr args))))))
+      (buffer-string))))
+
 (defun gnus-parse-simple-format (format spec-alist &optional insert)
   ;; This function parses the FORMAT string with the help of the
   ;; SPEC-ALIST and returns a list that can be eval'ed to return a
@@ -427,7 +523,7 @@
   (let ((max-width 0)
 	spec flist fstring elem result dontinsert user-defined
 	type value pad-width spec-beg cut-width ignore-value
-	tilde-form tilde elem-type)
+	tilde-form tilde elem-type extended-spec)
     (save-excursion
       (gnus-set-work-buffer)
       (insert format)
@@ -439,7 +535,8 @@
 	      max-width nil
 	      cut-width nil
 	      ignore-value nil
-	      tilde-form nil)
+	      tilde-form nil
+	      extended-spec nil)
 	(setq spec-beg (1- (point)))
 
 	;; Parse this spec fully.
@@ -480,10 +577,18 @@
 	      t)
 	     (t
 	      nil)))
-	;; User-defined spec -- find the spec name.
-	(when (eq (setq spec (char-after)) ?u)
+	(cond
+	 ;; User-defined spec -- find the spec name.
+	 ((eq (setq spec (char-after)) ?u)
 	  (forward-char 1)
-	  (setq user-defined (char-after)))
+	  (when (and (eq (setq user-defined (char-after)) ?&)
+		     (looking-at "&\\([^;]+\\);"))
+	    (setq user-defined (match-string 1))
+	    (goto-char (match-end 1))))
+	 ;; extended spec
+	 ((and (eq spec ?&) (looking-at "&\\([^;]+\\);"))
+	  (setq extended-spec (intern (match-string 1)))
+	  (goto-char (match-end 1))))
 	(forward-char 1)
 	(delete-region spec-beg (point))
 
@@ -501,20 +606,27 @@
 	   (user-defined
 	    (setq elem
 		  (list
-		   (list (intern (format "gnus-user-format-function-%c"
-					 user-defined))
+		   (list (intern (format
+				  (if (stringp user-defined)
+				      "gnus-user-format-function-%s"
+				    "gnus-user-format-function-%c")
+				  user-defined))
 			 'gnus-tmp-header)
 		   ?s)))
 	   ;; Find the specification from `spec-alist'.
-	   ((setq elem (cdr (assq spec spec-alist))))
+	   ((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
 	   (t
 	    (setq elem '("*" ?s))))
 	  (setq elem-type (cadr elem))
 	  ;; Insert the new format elements.
-	  (when pad-width
+	  (when (and pad-width
+		     (not (and (featurep 'xemacs)
+			       gnus-use-correct-string-widths)))
 	    (insert (number-to-string pad-width)))
 	  ;; Create the form to be evaled.
-	  (if (or max-width cut-width ignore-value)
+	  (if (or max-width cut-width ignore-value
+		  (and (featurep 'xemacs)
+		       gnus-use-correct-string-widths))
 	      (progn
 		(insert ?s)
 		(let ((el (car elem)))
@@ -528,16 +640,18 @@
 		    (setq el (gnus-tilde-cut-form el cut-width)))
 		  (when max-width
 		    (setq el (gnus-tilde-max-form el max-width)))
+		  (when pad-width
+		    (setq el (gnus-pad-form el pad-width)))
 		  (push el flist)))
 	    (insert elem-type)
 	    (push (car elem) flist))))
-      (setq fstring (buffer-string)))
+      (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
 
     ;; Do some postprocessing to increase efficiency.
     (setq
      result
      (cond
-      ;; Emptyness.
+      ;; Emptiness.
       ((string= fstring "")
        nil)
       ;; Not a format string.
@@ -567,6 +681,13 @@
       ;; A single string spec in the end of the spec.
       ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
        (list (match-string 1 fstring) (car flist)))
+      ;; Only string (and %) specs (XEmacs only!)
+      ((and (featurep 'xemacs)
+	    gnus-make-format-preserve-properties
+	    (string-match
+	     "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'"
+	     fstring))
+       (list (cons 'gnus-xmas-format (cons fstring (nreverse flist)))))
       ;; A more complex spec.
       (t
        (list (cons 'format (cons fstring (nreverse flist)))))))