X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=b73fbb8fd6ce6016a7fc8d009216183e79af2538;hb=9b6c272d50c6896583a69d40d9e9b15cabaf4247;hp=5338e943adc9ed2873844bdf8d7ff297882d2208;hpb=097cf341cfee92e9d5d30de9bdbc14a50ddfe414;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 5338e94..b73fbb8 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -1,7 +1,8 @@ ;;; gnus-xmas.el --- Gnus functions for XEmacs -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen +;; Katsumi Yamaoka ;; Keywords: news ;; This file is part of GNU Emacs. @@ -28,19 +29,22 @@ (require 'text-props) (defvar menu-bar-mode (featurep 'menubar)) (require 'messagexmas) +(require 'wid-edit) (defgroup gnus-xmas nil "XEmacsoid support for Gnus" :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) directory) :group 'gnus-xmas) +;;(format "%02x%02x%02x" 114 66 20) "724214" + (defvar gnus-xmas-logo-color-alist '((flame "#cc3300" "#ff2200") (pine "#c0cc93" "#f8ffb8") @@ -52,16 +56,18 @@ automatically." (grape "#b264cc" "#cf7df") (labia "#cc64c2" "#fd7dff") (berry "#cc6485" "#ff7db5") + (dino "#724214" "#1e3f03") (neutral "#b4b4b4" "#878787") (september "#bf9900" "#ffcc00")) "Color alist used for the Gnus logo.") -(defcustom gnus-xmas-logo-color-style 'moss - "Color styles used for the Gnus logo." +(defcustom gnus-xmas-logo-color-style 'dino + "*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) - (const berry) (const neutral) (const september)) + (const berry) (const neutral) (const september) + (const dino)) :group 'gnus-xmas) (defvar gnus-xmas-logo-colors @@ -73,7 +79,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 +96,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 +158,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) @@ -177,7 +182,9 @@ displayed, no centering will be performed." (- (window-height) 2))) (top (cond ((< height 4) 0) ((< height 7) 1) - (t 2))) + (t (if (numberp gnus-auto-center-summary) + gnus-auto-center-summary + 2)))) (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) (point))) @@ -210,6 +217,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) @@ -240,6 +249,7 @@ call it with the value of the `gnus-data' text property." (let* ((pos (event-closest-point event)) (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) + (goto-char pos) (when fun (funcall fun data)))) @@ -252,21 +262,6 @@ call it with the value of the `gnus-data' text property." (delete-extent extent) nil))) -;; Fixed by Christopher Davis . -(defun gnus-xmas-article-add-button (from to fun &optional data) - "Create a button between FROM and TO with callback FUN and data DATA." - (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to) - 'face gnus-article-button-face)) - (gnus-add-text-properties - from to - (nconc - (and gnus-article-mouse-face - (list 'mouse-face gnus-article-mouse-face)) - (list 'gnus-callback fun) - (and data (list 'gnus-data data)) - (list 'highlight t)))) - (defun gnus-xmas-window-top-edge (&optional window) (nth 1 (window-pixel-edges window))) @@ -364,6 +359,10 @@ call it with the value of the `gnus-data' text property." (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)) @@ -389,26 +388,10 @@ call it with the value of the `gnus-data' text property." (event-to-character event)) event))) -(defun gnus-xmas-seconds-since-epoch (date) - "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE." - (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti))) - (timezone-parse-date date))) - (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) - (timezone-parse-time - (aref (timezone-parse-date date) 3)))) - (edate (mapcar (lambda (ti) (and ti (string-to-int ti))) - (timezone-parse-date "Jan 1 12:00:00 1970"))) - (tday (- (timezone-absolute-from-gregorian - (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) - (timezone-absolute-from-gregorian - (nth 1 edate) (nth 2 edate) (nth 0 edate))))) - (+ (nth 2 ttime) - (* (nth 1 ttime) 60) - (* (float (nth 0 ttime)) 60 60) - (* (float tday) 60 60 24)))) - (defun gnus-xmas-define () (setq gnus-mouse-2 [button2]) + (setq gnus-mouse-3 [button3]) + (setq gnus-widget-button-keymap widget-button-keymap) (unless (memq 'underline (face-list)) (and (fboundp 'make-face) @@ -451,16 +434,6 @@ call it with the value of the `gnus-data' text property." (defvar gnus-mouse-face-prop 'highlight) - (unless (fboundp 'encode-time) - (defun encode-time (sec minute hour day month year &optional zone) - (let ((seconds - (gnus-xmas-seconds-since-epoch - (timezone-make-arpa-date - year month day (timezone-make-time-string hour minute sec) - zone)))) - (list (floor (/ seconds (expt 2 16))) - (round (mod seconds (expt 2 16))))))) - (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." (let ((fval (indirect-function func))) @@ -482,7 +455,6 @@ call it with the value of the `gnus-data' text property." (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter) (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open) (fset 'gnus-article-push-button 'gnus-xmas-article-push-button) - (fset 'gnus-article-add-button 'gnus-xmas-article-add-button) (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge) (fset 'gnus-read-event-char 'gnus-xmas-read-event-char) (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) @@ -495,6 +467,8 @@ call it with the value of the `gnus-data' text property." 'gnus-xmas-mode-line-buffer-identification) (fset 'gnus-key-press-event-p 'key-press-event-p) (fset 'gnus-region-active-p 'region-active-p) + (fset 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p) + (fset 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu) (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) @@ -515,11 +489,116 @@ call it with the value of the `gnus-data' text property." (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-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-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. @@ -551,7 +630,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)) @@ -727,50 +807,40 @@ XEmacs compatibility workaround." "Display any XFace headers in the current article." (save-excursion (let ((xface-glyph - (cond ((featurep 'xface) - (make-glyph (vector 'xface :data - (concat "X-Face: " - (buffer-substring beg end))))) - ((featurep 'xpm) - (let ((cur (current-buffer))) - (save-excursion - (gnus-set-work-buffer) - (insert (format "%s" (buffer-substring beg end cur))) - (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]))))) + (cond + ((featurep 'xface) + (make-glyph (vector 'xface :data + (concat "X-Face: " + (buffer-substring beg end))))) + ((featurep 'xpm) + (let ((cur (current-buffer))) + (save-excursion + (gnus-set-work-buffer) + (insert (format "%s" (buffer-substring beg end cur))) + (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])))) + (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)))) - -;;(defvar gnus-xmas-pointer-glyph -;; (progn -;; (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory -;; "gnus")) -;; (let ((file-xpm (expand-file-name "gnus-pointer.xpm" -;; gnus-xmas-glyph-directory)) -;; (file-xbm (expand-file-name "gnus-pointer.xbm" -;; gnus-xmas-glyph-directory))) -;; (make-pointer-glyph -;; (list (vector 'xpm ':file file-xpm) -;; (vector 'xbm ':file file-xbm)))))) + (set-extent-begin-glyph ext xface-glyph) + (set-extent-property ext 'duplicable t)))) (defvar gnus-xmas-modeline-left-extent (let ((ext (copy-extent modeline-buffer-id-left-extent))) -; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph) ext)) (defvar gnus-xmas-modeline-right-extent (let ((ext (copy-extent modeline-buffer-id-right-extent))) -; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph) ext)) (defvar gnus-xmas-modeline-glyph @@ -787,7 +857,7 @@ XEmacs compatibility workaround." `[xpm :file ,file-xpm]) ((featurep 'xbm) ;; Then a not-so-nifty XBM - [xbm :file ,file-xbm]) + `[xbm :file ,file-xbm]) ;; Then the simple string (t [string :data "Gnus:"]))))) (set-glyph-face glyph 'modeline-buffer-id) @@ -816,6 +886,23 @@ XEmacs compatibility workaround." (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) + (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) + "Construct a context-sensitive menu of MIME commands." + (interactive "e") + (let ((response (get-popup-menu-response + `("MIME Part" + ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t]) + gnus-mime-button-commands))))) + (set-buffer (event-buffer event)) + (goto-char (event-point event)) + (funcall (event-function response) (event-object response)))) + (provide 'gnus-xmas) ;;; gnus-xmas.el ends here