X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=41d5116c864dfaeab3ebbaf7f7b333579d550ba1;hb=bef10010d21318979c775fed02ae2fba5306fd12;hp=23eb31cfed4d8ed165b176b78d67444d9d1d66f2;hpb=8c620ff2178b0f9079eb742a56f82a17c65c30bb;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index 23eb31c..41d5116 100644
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -52,12 +52,11 @@ automatically."
     (grape "#b264cc" "#cf7df")
     (labia "#cc64c2" "#fd7dff")
     (berry "#cc6485" "#ff7db5")
-    (dino "#cc6485" "#ff7db5")
     (neutral "#b4b4b4" "#878787")
     (september "#bf9900" "#ffcc00"))
   "Color alist used for the Gnus logo.")
 
-(defcustom gnus-xmas-logo-color-style 'dino
+(defcustom gnus-xmas-logo-color-style 'moss
   "*Color styles used for the Gnus logo."
   :type '(choice (const flame) (const pine) (const moss)
 		 (const irish) (const sky) (const tin)
@@ -479,7 +478,30 @@ 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)))))
+
+  (when (featurep 'mule)
+    (defun gnus-tilde-pad-form (el pad-width)
+      "Return a form that pads EL to PAD-WIDTH."
+      (let ((pad (abs pad-width)))
+	(if (symbolp el)
+	    (if (< pad-width 0)
+		`(let ((val (format "%s" ,el)))
+		   (concat val (make-string
+				(max 0 (- ,pad (string-width val))) ?\ )))
+	      `(let ((val (format "%s" ,el)))
+		 (concat (make-string
+			  (max 0 (- ,pad (string-width val))) ?\ )
+			 val)))
+	  (if (< pad-width 0)
+	      `(let ((val (eval ,el)))
+		 (concat val (make-string
+			      (max 0 (- ,pad (string-width val))) ?\ )))
+	    `(let ((val (eval ,el)))
+	       (concat (make-string
+			(max 0 (- ,pad (string-width val))) ?\ )
+		       val))))))
+    ))
 
 (defun gnus-xmas-redefine ()
   "Redefine lots of Gnus functions for XEmacs."
@@ -525,8 +547,91 @@ call it with the value of the `gnus-data' text property."
   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
   (add-hook 'gnus-summary-mode-hook
 	    'gnus-xmas-switch-horizontal-scrollbar-off)
-  (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))
-
+  (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)
+
+  (when (featurep 'mule)
+    (defun gnus-truncate-string (str end-column &optional start-column padding)
+      "Truncate string STR to end at column END-COLUMN.
+The optional 2nd arg START-COLUMN, if non-nil, specifies
+the starting column; that means to return the characters occupying
+columns START-COLUMN ... END-COLUMN of STR.
+
+The optional 3rd arg PADDING, if non-nil, specifies a padding character
+to add at the end of the result if STR doesn't reach column END-COLUMN,
+or if END-COLUMN comes in the middle of a character in STR.
+PADDING is also added at the beginning of the result
+if column START-COLUMN appears in the middle of a character in STR.
+
+If PADDING is nil, no padding is added in these cases, so
+the resulting string may be narrower than END-COLUMN.
+\[Emacs 20.3 emulating function]"
+      (or start-column
+	  (setq start-column 0))
+      (let ((len (length str))
+	    (idx 0)
+	    (column 0)
+	    (head-padding "") (tail-padding "")
+	    ch last-column last-idx from-idx)
+	(condition-case nil
+	    (while (< column start-column)
+	      (setq ch (aref str idx)
+		    column (+ column (char-width ch))
+		    idx (1+ idx)))
+	  (args-out-of-range (setq idx len)))
+	(if (< column start-column)
+	    (if padding (make-string end-column padding) "")
+	  (if (and padding (> column start-column))
+	      (setq head-padding
+		    (make-string (- column start-column) padding)))
+	  (setq from-idx idx)
+	  (if (< end-column column)
+	      (setq idx from-idx)
+	    (condition-case nil
+		(while (< column end-column)
+		  (setq last-column column
+			last-idx idx
+			ch (aref str idx)
+			column (+ column (char-width ch))
+			idx (1+ idx)))
+	      (args-out-of-range (setq idx len)))
+	    (if (> column end-column)
+		(setq column last-column idx last-idx))
+	    (if (and padding (< column end-column))
+		(setq tail-padding
+		      (make-string (- end-column column) padding))))
+	  (setq str (substring str from-idx idx))
+	  (if padding
+	      (concat head-padding str tail-padding)
+	    str))))
+
+    (defun gnus-tilde-max-form (el max-width)
+      "Return a form that limits EL to MAX-WIDTH."
+      (let ((max (abs max-width)))
+	(if (symbolp el)
+	    (if (< max-width 0)
+		`(let ((width (string-width ,el)))
+		   (gnus-truncate-string ,el width (- width ,max)))
+	      `(gnus-truncate-string ,el ,max))
+	  (if (< max-width 0)
+	      `(let* ((val (eval ,el))
+		      (width (string-width val)))
+		 (gnus-truncate-string val width (- width ,max)))
+	    `(let ((val (eval ,el)))
+	       (gnus-truncate-string val ,max))))))
+
+    (defun gnus-tilde-cut-form (el cut-width)
+      "Return a form that cuts CUT-WIDTH off of EL."
+      (let ((cut (abs cut-width)))
+	(if (symbolp el)
+	    (if (< cut-width 0)
+		`(gnus-truncate-string ,el (- (string-width ,el) ,cut))
+	      `(gnus-truncate-string ,el (string-width ,el) ,cut))
+	  (if (< cut-width 0)
+	      `(let ((val (eval ,el)))
+		 (gnus-truncate-string val (- (string-width val) ,cut)))
+	    `(let ((val (eval ,el)))
+	       (gnus-truncate-string val (string-width val) ,cut))))))
+    ))
 
 ;;; XEmacs logo and toolbar.