X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=41d5116c864dfaeab3ebbaf7f7b333579d550ba1;hb=04aa4d466b5e1d5906632c748818fed207fd0c32;hp=2794ce3bfd86e401011b8cc669ead047d6f647aa;hpb=e85b83e8b076986fb7b0b0d805fbf3daec45e941;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 2794ce3..41d5116 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -1,7 +1,7 @@ ;;; gnus-xmas.el --- Gnus functions for XEmacs -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -34,7 +34,7 @@ :group 'gnus) (defcustom gnus-xmas-glyph-directory nil - "*Directory where Gnus logos and icons are located. + "Directory where Gnus logos and icons are located. If this variable is nil, Gnus will try to locate the directory automatically." :type '(choice (const :tag "autodetect" nil) @@ -57,7 +57,7 @@ automatically." "Color alist used for the Gnus logo.") (defcustom gnus-xmas-logo-color-style 'moss - "Color styles used for the Gnus logo." + "*Color styles used for the Gnus logo." :type '(choice (const flame) (const pine) (const moss) (const irish) (const sky) (const tin) (const velvet) (const grape) (const labia) @@ -73,7 +73,7 @@ automatically." (featurep 'xpm)) 'gnus-xmas-article-display-xface "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -") - "String or function to be executed to display an X-Face header. + "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type '(choice string function)) @@ -90,7 +90,6 @@ asynchronously. The compressed face will be piped to this command." (defvar gnus-active-hashtb) (defvar gnus-article-buffer) (defvar gnus-auto-center-summary) -(defvar gnus-buffer-list) (defvar gnus-current-headers) (defvar gnus-level-killed) (defvar gnus-level-zombie) @@ -153,7 +152,7 @@ It is provided only to ease porting of broken FSF Emacs programs." gnus-summary-selected-face))) (defcustom gnus-xmas-force-redisplay nil - "If non-nil, force a redisplay before recentering the summary buffer. + "*If non-nil, force a redisplay before recentering the summary buffer. This is ugly, but it works around a bug in `window-displayed-height'." :type 'boolean :group 'gnus-xmas) @@ -210,6 +209,8 @@ displayed, no centering will be performed." ;; selective display). (aset table ?\n nil) (aset table ?\r nil) + ;; We keep TAB as well. + (aset table ?\t nil) ;; 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) @@ -244,7 +245,13 @@ call it with the value of the `gnus-data' text property." (funcall fun data)))) (defun gnus-xmas-move-overlay (extent start end &optional buffer) - (set-extent-endpoints extent start end)) + (set-extent-endpoints extent start end buffer)) + +(defun gnus-xmas-kill-all-overlays () + "Delete all extents in the current buffer." + (map-extents (lambda (extent ignore) + (delete-extent extent) + nil))) ;; Fixed by Christopher Davis . (defun gnus-xmas-article-add-button (from to fun &optional data) @@ -342,10 +349,26 @@ call it with the value of the `gnus-data' text property." (gnus-xmas-menu-add binary gnus-binary-menu)) +(defun gnus-xmas-agent-summary-menu-add () + (gnus-xmas-menu-add agent-summary + gnus-agent-summary-menu)) + +(defun gnus-xmas-agent-group-menu-add () + (gnus-xmas-menu-add agent-group + gnus-agent-group-menu)) + +(defun gnus-xmas-agent-server-menu-add () + (gnus-xmas-menu-add agent-server + gnus-agent-server-menu)) + (defun gnus-xmas-tree-menu-add () (gnus-xmas-menu-add tree gnus-tree-menu)) +(defun gnus-xmas-draft-menu-add () + (gnus-xmas-menu-add draft + gnus-draft-menu)) + (defun gnus-xmas-server-menu-add () (gnus-xmas-menu-add menu gnus-server-server-menu gnus-server-connections-menu)) @@ -410,16 +433,17 @@ call it with the value of the `gnus-data' text property." (fset 'gnus-characterp 'characterp))) (fset 'gnus-make-overlay 'make-extent) + (fset 'gnus-delete-overlay 'delete-extent) (fset 'gnus-overlay-put 'set-extent-property) (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) (fset 'gnus-overlay-end 'extent-end-position) + (fset 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays) (fset 'gnus-extent-detached-p 'extent-detached-p) (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) (fset 'gnus-deactivate-mark 'ignore) (fset 'gnus-window-edges 'window-pixel-edges) - (require 'text-props) (if (and (<= emacs-major-version 19) (< emacs-minor-version 14)) (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) @@ -444,8 +468,8 @@ call it with the value of the `gnus-data' text property." (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." - (let ((fval (symbol-function func))) - (if (byte-code-function-p fval) + (let ((fval (indirect-function func))) + (if (compiled-function-p fval) (list 'funcall fval) (cons 'progn (cdr (cdr fval)))))) @@ -454,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." @@ -493,10 +540,98 @@ call it with the value of the `gnus-data' text property." (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) + (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add) + (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add) + (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add) + + (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. @@ -528,7 +663,8 @@ 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))) + (forward-line 1)) + (setq gnus-simple-splash nil)) (goto-char (point-min)) (let* ((pheight (+ 20 (count-lines (point-min) (point-max)))) (wheight (window-height)) @@ -721,12 +857,15 @@ XEmacs compatibility workaround." (make-glyph (vector 'xpm :data (buffer-string)))))) (t - (make-glyph [nothing]))))) + (make-glyph [nothing])))) + (ext (make-extent (progn + (goto-char (point-min)) + (re-search-forward "^From:" nil t) + (point)) + (1+ (point))))) (set-glyph-face xface-glyph 'gnus-x-face) - (goto-char (point-min)) - (re-search-forward "^From:" nil t) - (set-extent-begin-glyph - (make-extent (point) (1+ (point))) xface-glyph)))) + (set-extent-begin-glyph ext xface-glyph) + (set-extent-property ext 'duplicable t)))) ;;(defvar gnus-xmas-pointer-glyph ;; (progn