Mercurial > hg > xemacs-beta
comparison lisp/gnus/gnus-xmas.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; gnus-xmas.el --- Gnus functions for XEmacs | |
| 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. | |
| 3 | |
| 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
| 5 ;; Keywords: news | |
| 6 | |
| 7 ;; This file is part of GNU Emacs. | |
| 8 | |
| 9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 10 ;; it under the terms of the GNU General Public License as published by | |
| 11 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 12 ;; any later version. | |
| 13 | |
| 14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 17 ;; GNU General Public License for more details. | |
| 18 | |
| 19 ;; You should have received a copy of the GNU General Public License | |
| 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 ;; Boston, MA 02111-1307, USA. | |
| 23 | |
| 24 ;;; Commentary: | |
| 25 | |
| 26 ;;; Code: | |
| 27 | |
| 28 (require 'text-props) | |
| 29 (eval-when-compile (require 'cl)) | |
| 30 (defvar menu-bar-mode (featurep 'menubar)) | |
| 31 (require 'messagexmas) | |
| 32 | |
| 33 (defvar gnus-xmas-glyph-directory nil | |
| 34 "*Directory where Gnus logos and icons are located. | |
| 35 If this variable is nil, Gnus will try to locate the directory | |
| 36 automatically.") | |
| 37 | |
| 38 (defvar gnus-xmas-logo-color-alist | |
| 39 '((flame "#cc3300" "#ff2200") | |
| 40 (pine "#c0cc93" "#f8ffb8") | |
| 41 (moss "#a1cc93" "#d2ffb8") | |
| 42 (irish "#04cc90" "#05ff97") | |
| 43 (sky "#049acc" "#05deff") | |
| 44 (tin "#6886cc" "#82b6ff") | |
| 45 (velvet "#7c68cc" "#8c82ff") | |
| 46 (grape "#b264cc" "#cf7df") | |
| 47 (labia "#cc64c2" "#fd7dff") | |
| 48 (berry "#cc6485" "#ff7db5") | |
| 49 (neutral "#b4b4b4" "#878787") | |
| 50 (september "#bf9900" "#ffcc00")) | |
| 51 "Color alist used for the Gnus logo.") | |
| 52 | |
| 53 (defvar gnus-xmas-logo-color-style 'september | |
| 54 "Color styles used for the Gnus logo.") | |
| 55 | |
| 56 (defvar gnus-xmas-logo-colors | |
| 57 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist)) | |
| 58 "Colors used for the Gnus logo.") | |
| 59 | |
| 60 (defvar gnus-article-x-face-command | |
| 61 (if (featurep 'xface) | |
| 62 'gnus-xmas-article-display-xface | |
| 63 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -") | |
| 64 "String or function to be executed to display an X-Face header. | |
| 65 If it is a string, the command will be executed in a sub-shell | |
| 66 asynchronously. The compressed face will be piped to this command.") | |
| 67 | |
| 68 ;;; Internal variables. | |
| 69 | |
| 70 ;; Don't warn about these undefined variables. | |
| 71 | |
| 72 (defvar gnus-group-mode-hook) | |
| 73 (defvar gnus-summary-mode-hook) | |
| 74 (defvar gnus-article-mode-hook) | |
| 75 | |
| 76 ;;defined in gnus.el | |
| 77 (defvar gnus-active-hashtb) | |
| 78 (defvar gnus-article-buffer) | |
| 79 (defvar gnus-auto-center-summary) | |
| 80 (defvar gnus-buffer-list) | |
| 81 (defvar gnus-current-headers) | |
| 82 (defvar gnus-level-killed) | |
| 83 (defvar gnus-level-zombie) | |
| 84 (defvar gnus-newsgroup-bookmarks) | |
| 85 (defvar gnus-newsgroup-dependencies) | |
| 86 (defvar gnus-newsgroup-selected-overlay) | |
| 87 (defvar gnus-newsrc-hashtb) | |
| 88 (defvar gnus-read-mark) | |
| 89 (defvar gnus-refer-article-method) | |
| 90 (defvar gnus-reffed-article-number) | |
| 91 (defvar gnus-unread-mark) | |
| 92 (defvar gnus-version) | |
| 93 (defvar gnus-view-pseudos) | |
| 94 (defvar gnus-view-pseudos-separately) | |
| 95 (defvar gnus-visual) | |
| 96 (defvar gnus-zombie-list) | |
| 97 ;;defined in gnus-msg.el | |
| 98 (defvar gnus-article-copy) | |
| 99 (defvar gnus-check-before-posting) | |
| 100 ;;defined in gnus-vis.el | |
| 101 (defvar gnus-article-button-face) | |
| 102 (defvar gnus-article-mouse-face) | |
| 103 (defvar gnus-summary-selected-face) | |
| 104 (defvar gnus-group-reading-menu) | |
| 105 (defvar gnus-group-group-menu) | |
| 106 (defvar gnus-group-misc-menu) | |
| 107 (defvar gnus-summary-article-menu) | |
| 108 (defvar gnus-summary-thread-menu) | |
| 109 (defvar gnus-summary-misc-menu) | |
| 110 (defvar gnus-summary-post-menu) | |
| 111 (defvar gnus-summary-kill-menu) | |
| 112 (defvar gnus-article-article-menu) | |
| 113 (defvar gnus-article-treatment-menu) | |
| 114 (defvar gnus-mouse-2) | |
| 115 (defvar standard-display-table) | |
| 116 (defvar gnus-tree-minimize-window) | |
| 117 | |
| 118 (defun gnus-xmas-set-text-properties (start end props &optional buffer) | |
| 119 "You should NEVER use this function. It is ideologically blasphemous. | |
| 120 It is provided only to ease porting of broken FSF Emacs programs." | |
| 121 (if (stringp buffer) | |
| 122 nil | |
| 123 (map-extents (lambda (extent ignored) | |
| 124 (remove-text-properties | |
| 125 start end | |
| 126 (list (extent-property extent 'text-prop) nil) | |
| 127 buffer)) | |
| 128 buffer start end nil nil 'text-prop) | |
| 129 (gnus-add-text-properties start end props buffer))) | |
| 130 | |
| 131 (defun gnus-xmas-highlight-selected-summary () | |
| 132 ;; Highlight selected article in summary buffer | |
| 133 (when gnus-summary-selected-face | |
| 134 (if gnus-newsgroup-selected-overlay | |
| 135 (delete-extent gnus-newsgroup-selected-overlay)) | |
| 136 (setq gnus-newsgroup-selected-overlay | |
| 137 (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) | |
| 138 (set-extent-face gnus-newsgroup-selected-overlay | |
| 139 gnus-summary-selected-face))) | |
| 140 | |
| 141 (defun gnus-xmas-summary-recenter () | |
| 142 "\"Center\" point in the summary window. | |
| 143 If `gnus-auto-center-summary' is nil, or the article buffer isn't | |
| 144 displayed, no centering will be performed." | |
| 145 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). | |
| 146 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. | |
| 147 (when gnus-auto-center-summary | |
| 148 (let* ((height (if (fboundp 'window-displayed-height) | |
| 149 (window-displayed-height) | |
| 150 (- (window-height) 2))) | |
| 151 (top (cond ((< height 4) 0) | |
| 152 ((< height 7) 1) | |
| 153 (t 2))) | |
| 154 (bottom (save-excursion (goto-char (point-max)) | |
| 155 (forward-line (- height)) | |
| 156 (point))) | |
| 157 (window (get-buffer-window (current-buffer)))) | |
| 158 (when (get-buffer-window gnus-article-buffer) | |
| 159 ;; Only do recentering when the article buffer is displayed, | |
| 160 ;; Set the window start to either `bottom', which is the biggest | |
| 161 ;; possible valid number, or the second line from the top, | |
| 162 ;; whichever is the least. | |
| 163 (set-window-start | |
| 164 window (min bottom (save-excursion | |
| 165 (forward-line (- top)) (point))))) | |
| 166 ;; Do horizontal recentering while we're at it. | |
| 167 (when (and (get-buffer-window (current-buffer) t) | |
| 168 (not (eq gnus-auto-center-summary 'vertical))) | |
| 169 (let ((selected (selected-window))) | |
| 170 (select-window (get-buffer-window (current-buffer) t)) | |
| 171 (gnus-summary-position-point) | |
| 172 (gnus-horizontal-recenter) | |
| 173 (select-window selected)))))) | |
| 174 | |
| 175 (defun gnus-xmas-add-hook (hook function &optional append local) | |
| 176 (add-hook hook function)) | |
| 177 | |
| 178 (defun gnus-xmas-add-text-properties (start end props &optional object) | |
| 179 (add-text-properties start end props object) | |
| 180 (put-text-property start end 'start-closed nil object)) | |
| 181 | |
| 182 (defun gnus-xmas-put-text-property (start end prop value &optional object) | |
| 183 (put-text-property start end prop value object) | |
| 184 (put-text-property start end 'start-closed nil object)) | |
| 185 | |
| 186 (defun gnus-xmas-extent-start-open (point) | |
| 187 (map-extents (lambda (extent arg) | |
| 188 (set-extent-property extent 'start-open t)) | |
| 189 nil point (min (1+ (point)) (point-max)))) | |
| 190 | |
| 191 (defun gnus-xmas-article-push-button (event) | |
| 192 "Check text under the mouse pointer for a callback function. | |
| 193 If the text under the mouse pointer has a `gnus-callback' property, | |
| 194 call it with the value of the `gnus-data' text property." | |
| 195 (interactive "e") | |
| 196 (set-buffer (window-buffer (event-window event))) | |
| 197 (let* ((pos (event-closest-point event)) | |
| 198 (data (get-text-property pos 'gnus-data)) | |
| 199 (fun (get-text-property pos 'gnus-callback))) | |
| 200 (if fun (funcall fun data)))) | |
| 201 | |
| 202 (defun gnus-xmas-move-overlay (extent start end &optional buffer) | |
| 203 (set-extent-endpoints extent start end)) | |
| 204 | |
| 205 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>. | |
| 206 (defun gnus-xmas-article-add-button (from to fun &optional data) | |
| 207 "Create a button between FROM and TO with callback FUN and data DATA." | |
| 208 (and gnus-article-button-face | |
| 209 (gnus-overlay-put (gnus-make-overlay from to) | |
| 210 'face gnus-article-button-face)) | |
| 211 (gnus-add-text-properties | |
| 212 from to | |
| 213 (nconc | |
| 214 (and gnus-article-mouse-face | |
| 215 (list 'mouse-face gnus-article-mouse-face)) | |
| 216 (list 'gnus-callback fun) | |
| 217 (and data (list 'gnus-data data)) | |
| 218 (list 'highlight t)))) | |
| 219 | |
| 220 (defun gnus-xmas-window-top-edge (&optional window) | |
| 221 (nth 1 (window-pixel-edges window))) | |
| 222 | |
| 223 (defun gnus-xmas-tree-minimize () | |
| 224 (when (and gnus-tree-minimize-window | |
| 225 (not (one-window-p))) | |
| 226 (let* ((window-min-height 2) | |
| 227 (height (1+ (count-lines (point-min) (point-max)))) | |
| 228 (min (max (1- window-min-height) height)) | |
| 229 (tot (if (numberp gnus-tree-minimize-window) | |
| 230 (min gnus-tree-minimize-window min) | |
| 231 min)) | |
| 232 (win (get-buffer-window (current-buffer))) | |
| 233 (wh (and win (1- (window-height win))))) | |
| 234 (when (and win | |
| 235 (not (eq tot wh))) | |
| 236 (let ((selected (selected-window))) | |
| 237 (select-window win) | |
| 238 (enlarge-window (- tot wh)) | |
| 239 (select-window selected)))))) | |
| 240 | |
| 241 ;; Select the lowest window on the frame. | |
| 242 (defun gnus-xmas-appt-select-lowest-window () | |
| 243 (let* ((lowest-window (selected-window)) | |
| 244 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) | |
| 245 (last-window (previous-window)) | |
| 246 (window-search t)) | |
| 247 (while window-search | |
| 248 (let* ((this-window (next-window)) | |
| 249 (next-bottom-edge (car (cdr (cdr (cdr | |
| 250 (window-pixel-edges | |
| 251 this-window))))))) | |
| 252 (if (< bottom-edge next-bottom-edge) | |
| 253 (progn | |
| 254 (setq bottom-edge next-bottom-edge) | |
| 255 (setq lowest-window this-window))) | |
| 256 | |
| 257 (select-window this-window) | |
| 258 (if (eq last-window this-window) | |
| 259 (progn | |
| 260 (select-window lowest-window) | |
| 261 (setq window-search nil))))))) | |
| 262 | |
| 263 (defmacro gnus-xmas-menu-add (type &rest menus) | |
| 264 `(gnus-xmas-menu-add-1 ',type ',menus)) | |
| 265 (put 'gnus-xmas-menu-add 'lisp-indent-function 1) | |
| 266 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1) | |
| 267 | |
| 268 (defun gnus-xmas-menu-add-1 (type menus) | |
| 269 (when (and menu-bar-mode | |
| 270 (gnus-visual-p (intern (format "%s-menu" type)) 'menu)) | |
| 271 (while menus | |
| 272 (easy-menu-add (symbol-value (pop menus)))))) | |
| 273 | |
| 274 (defun gnus-xmas-group-menu-add () | |
| 275 (gnus-xmas-menu-add group | |
| 276 gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu)) | |
| 277 | |
| 278 (defun gnus-xmas-summary-menu-add () | |
| 279 (gnus-xmas-menu-add summary | |
| 280 gnus-summary-misc-menu gnus-summary-kill-menu | |
| 281 gnus-summary-article-menu gnus-summary-thread-menu | |
| 282 gnus-summary-post-menu )) | |
| 283 | |
| 284 (defun gnus-xmas-article-menu-add () | |
| 285 (gnus-xmas-menu-add article | |
| 286 gnus-article-article-menu gnus-article-treatment-menu)) | |
| 287 | |
| 288 (defun gnus-xmas-score-menu-add () | |
| 289 (gnus-xmas-menu-add score | |
| 290 gnus-score-menu)) | |
| 291 | |
| 292 (defun gnus-xmas-pick-menu-add () | |
| 293 (gnus-xmas-menu-add pick | |
| 294 gnus-pick-menu)) | |
| 295 | |
| 296 (defun gnus-xmas-binary-menu-add () | |
| 297 (gnus-xmas-menu-add binary | |
| 298 gnus-binary-menu)) | |
| 299 | |
| 300 (defun gnus-xmas-tree-menu-add () | |
| 301 (gnus-xmas-menu-add tree | |
| 302 gnus-tree-menu)) | |
| 303 | |
| 304 (defun gnus-xmas-server-menu-add () | |
| 305 (gnus-xmas-menu-add menu | |
| 306 gnus-server-server-menu gnus-server-connections-menu)) | |
| 307 | |
| 308 (defun gnus-xmas-browse-menu-add () | |
| 309 (gnus-xmas-menu-add browse | |
| 310 gnus-browse-menu)) | |
| 311 | |
| 312 (defun gnus-xmas-grouplens-menu-add () | |
| 313 (gnus-xmas-menu-add grouplens | |
| 314 gnus-grouplens-menu)) | |
| 315 | |
| 316 (defun gnus-xmas-read-event-char () | |
| 317 "Get the next event." | |
| 318 (let ((event (next-event))) | |
| 319 ;; We junk all non-key events. Is this naughty? | |
| 320 (while (not (key-press-event-p event)) | |
| 321 (setq event (next-event))) | |
| 322 (cons (and (key-press-event-p event) | |
| 323 ; (numberp (event-key event)) | |
| 324 (event-to-character event)) | |
| 325 event))) | |
| 326 | |
| 327 (defun gnus-xmas-group-remove-excess-properties () | |
| 328 (let ((end (point)) | |
| 329 (beg (progn (forward-line -1) (point)))) | |
| 330 (remove-text-properties (1+ beg) end '(gnus-group nil)) | |
| 331 (remove-text-properties | |
| 332 beg end | |
| 333 '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil)) | |
| 334 (goto-char end) | |
| 335 (map-extents | |
| 336 (lambda (e ma) | |
| 337 (set-extent-property e 'start-closed t)) | |
| 338 (current-buffer) beg end))) | |
| 339 | |
| 340 (defun gnus-xmas-topic-remove-excess-properties () | |
| 341 (let ((end (point)) | |
| 342 (beg (progn (forward-line -1) (point)))) | |
| 343 (remove-text-properties beg end '(gnus-group nil gnus-unread nil)) | |
| 344 (remove-text-properties (1+ beg) end '(gnus-topic nil)) | |
| 345 (goto-char end))) | |
| 346 | |
| 347 (defun gnus-xmas-seconds-since-epoch (date) | |
| 348 "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE." | |
| 349 (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti))) | |
| 350 (timezone-parse-date date))) | |
| 351 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) | |
| 352 (timezone-parse-time | |
| 353 (aref (timezone-parse-date date) 3)))) | |
| 354 (edate (mapcar (lambda (ti) (and ti (string-to-int ti))) | |
| 355 (timezone-parse-date "Jan 1 12:00:00 1970"))) | |
| 356 (tday (- (timezone-absolute-from-gregorian | |
| 357 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) | |
| 358 (timezone-absolute-from-gregorian | |
| 359 (nth 1 edate) (nth 2 edate) (nth 0 edate))))) | |
| 360 (+ (nth 2 ttime) | |
| 361 (* (nth 1 ttime) 60) | |
| 362 (* (float (nth 0 ttime)) 60 60) | |
| 363 (* (float tday) 60 60 24)))) | |
| 364 | |
| 365 (defun gnus-xmas-define () | |
| 366 (setq gnus-mouse-2 [button2]) | |
| 367 | |
| 368 (or (memq 'underline (face-list)) | |
| 369 (and (fboundp 'make-face) | |
| 370 (funcall (intern "make-face") 'underline))) | |
| 371 ;; Must avoid calling set-face-underline-p directly, because it | |
| 372 ;; is a defsubst in emacs19, and will make the .elc files non | |
| 373 ;; portable! | |
| 374 (or (face-differs-from-default-p 'underline) | |
| 375 (funcall (intern "set-face-underline-p") 'underline t)) | |
| 376 | |
| 377 (fset 'gnus-make-overlay 'make-extent) | |
| 378 (fset 'gnus-overlay-put 'set-extent-property) | |
| 379 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) | |
| 380 (fset 'gnus-overlay-end 'extent-end-position) | |
| 381 (fset 'gnus-extent-detached-p 'extent-detached-p) | |
| 382 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) | |
| 383 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) | |
| 384 | |
| 385 (require 'text-props) | |
| 386 (if (< emacs-minor-version 14) | |
| 387 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) | |
| 388 | |
| 389 (or (boundp 'standard-display-table) (setq standard-display-table nil)) | |
| 390 | |
| 391 (defvar gnus-mouse-face-prop 'highlight) | |
| 392 | |
| 393 (unless (fboundp 'encode-time) | |
| 394 (defun encode-time (sec minute hour day month year &optional zone) | |
| 395 (let ((seconds | |
| 396 (gnus-xmas-seconds-since-epoch | |
| 397 (timezone-make-arpa-date | |
| 398 year month day (timezone-make-time-string hour minute sec) | |
| 399 zone)))) | |
| 400 (list (floor (/ seconds (expt 2 16))) | |
| 401 (round (mod seconds (expt 2 16))))))) | |
| 402 | |
| 403 (defun gnus-byte-code (func) | |
| 404 "Return a form that can be `eval'ed based on FUNC." | |
| 405 (let ((fval (symbol-function func))) | |
| 406 (if (compiled-function-p fval) | |
| 407 (list 'funcall fval) | |
| 408 (cons 'progn (cdr (cdr fval)))))) | |
| 409 | |
| 410 ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>. | |
| 411 (defvar gnus-display-type (device-class) | |
| 412 "A symbol indicating the display Emacs is running under. | |
| 413 The symbol should be one of `color', `grayscale' or `mono'. If Emacs | |
| 414 guesses this display attribute wrongly, either set this variable in | |
| 415 your `~/.emacs' or set the resource `Emacs.displayType' in your | |
| 416 `~/.Xdefaults'. See also `gnus-background-mode'. | |
| 417 | |
| 418 This is a meta-variable that will affect what default values other | |
| 419 variables get. You would normally not change this variable, but | |
| 420 pounce directly on the real variables themselves.") | |
| 421 | |
| 422 | |
| 423 (fset 'gnus-x-color-values | |
| 424 (if (fboundp 'x-color-values) | |
| 425 'x-color-values | |
| 426 (lambda (color) | |
| 427 (color-instance-rgb-components | |
| 428 (make-color-instance color))))) | |
| 429 | |
| 430 (defvar gnus-background-mode | |
| 431 (let* ((bg-resource | |
| 432 (condition-case () | |
| 433 (x-get-resource ".backgroundMode" "BackgroundMode" 'string) | |
| 434 (error nil))) | |
| 435 (params (frame-parameters)) | |
| 436 (color (condition-case () | |
| 437 (or (assq 'background-color params) | |
| 438 (color-instance-name | |
| 439 (specifier-instance | |
| 440 (face-background 'default)))) | |
| 441 (error nil)))) | |
| 442 (cond (bg-resource (intern (downcase bg-resource))) | |
| 443 ((and color | |
| 444 (< (apply '+ (gnus-x-color-values color)) | |
| 445 (/ (apply '+ (gnus-x-color-values "white")) 3))) | |
| 446 'dark) | |
| 447 (t 'light))) | |
| 448 "A symbol indicating the Emacs background brightness. | |
| 449 The symbol should be one of `light' or `dark'. | |
| 450 If Emacs guesses this frame attribute wrongly, either set this variable in | |
| 451 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your | |
| 452 `~/.Xdefaults'. | |
| 453 See also `gnus-display-type'. | |
| 454 | |
| 455 This is a meta-variable that will affect what default values other | |
| 456 variables get. You would normally not change this variable, but | |
| 457 pounce directly on the real variables themselves.") | |
| 458 ) | |
| 459 | |
| 460 | |
| 461 | |
| 462 (defun gnus-xmas-redefine () | |
| 463 "Redefine lots of Gnus functions for XEmacs." | |
| 464 (fset 'gnus-summary-make-display-table 'ignore) | |
| 465 (fset 'gnus-visual-turn-off-edit-menu 'identity) | |
| 466 (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter) | |
| 467 (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open) | |
| 468 (fset 'gnus-article-push-button 'gnus-xmas-article-push-button) | |
| 469 (fset 'gnus-article-add-button 'gnus-xmas-article-add-button) | |
| 470 (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge) | |
| 471 (fset 'gnus-read-event-char 'gnus-xmas-read-event-char) | |
| 472 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) | |
| 473 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize) | |
| 474 (fset 'gnus-appt-select-lowest-window | |
| 475 'gnus-xmas-appt-select-lowest-window) | |
| 476 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) | |
| 477 (fset 'gnus-make-local-hook 'make-local-variable) | |
| 478 (fset 'gnus-add-hook 'gnus-xmas-add-hook) | |
| 479 (fset 'gnus-character-to-event 'character-to-event) | |
| 480 (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text) | |
| 481 (fset 'gnus-mode-line-buffer-identification | |
| 482 'gnus-xmas-mode-line-buffer-identification) | |
| 483 | |
| 484 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) | |
| 485 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) | |
| 486 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) | |
| 487 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) | |
| 488 | |
| 489 (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add) | |
| 490 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) | |
| 491 (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) | |
| 492 (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) | |
| 493 (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) | |
| 494 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) | |
| 495 | |
| 496 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) | |
| 497 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) | |
| 498 | |
| 499 (when (and (<= emacs-major-version 19) | |
| 500 (<= emacs-minor-version 13)) | |
| 501 (fset 'gnus-highlight-selected-summary | |
| 502 'gnus-xmas-highlight-selected-summary) | |
| 503 (fset 'gnus-group-remove-excess-properties | |
| 504 'gnus-xmas-group-remove-excess-properties) | |
| 505 (fset 'gnus-topic-remove-excess-properties | |
| 506 'gnus-xmas-topic-remove-excess-properties) | |
| 507 (fset 'gnus-mode-line-buffer-identification 'identity) | |
| 508 (unless (boundp 'shell-command-switch) | |
| 509 (setq shell-command-switch "-c")) | |
| 510 )) | |
| 511 | |
| 512 | |
| 513 ;;; XEmacs logo and toolbar. | |
| 514 | |
| 515 (defun gnus-xmas-group-startup-message (&optional x y) | |
| 516 "Insert startup message in current buffer." | |
| 517 ;; Insert the message. | |
| 518 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) | |
| 519 (erase-buffer) | |
| 520 (let ((logo (and gnus-xmas-glyph-directory | |
| 521 (concat | |
| 522 (file-name-as-directory gnus-xmas-glyph-directory) | |
| 523 "gnus." | |
| 524 (if (featurep 'xpm) "xpm" "xbm")))) | |
| 525 (xpm-color-symbols | |
| 526 (and (featurep 'xpm) | |
| 527 (append `(("thing" ,(car gnus-xmas-logo-colors)) | |
| 528 ("shadow" ,(cadr gnus-xmas-logo-colors))) | |
| 529 xpm-color-symbols)))) | |
| 530 (if (and (featurep 'xpm) | |
| 531 (not (equal (device-type) 'tty)) | |
| 532 logo | |
| 533 (file-exists-p logo)) | |
| 534 (progn | |
| 535 (setq logo (make-glyph logo)) | |
| 536 (insert " ") | |
| 537 (set-extent-begin-glyph (make-extent (point) (point)) logo) | |
| 538 (goto-char (point-min)) | |
| 539 (while (not (eobp)) | |
| 540 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2) | |
| 541 ? )) | |
| 542 (forward-line 1)) | |
| 543 (goto-char (point-min)) | |
| 544 (let* ((pheight (+ 20 (count-lines (point-min) (point-max)))) | |
| 545 (wheight (window-height)) | |
| 546 (rest (- wheight pheight))) | |
| 547 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) | |
| 548 | |
| 549 (insert | |
| 550 (format " %s | |
| 551 _ ___ _ _ | |
| 552 _ ___ __ ___ __ _ ___ | |
| 553 __ _ ___ __ ___ | |
| 554 _ ___ _ | |
| 555 _ _ __ _ | |
| 556 ___ __ _ | |
| 557 __ _ | |
| 558 _ _ _ | |
| 559 _ _ _ | |
| 560 _ _ _ | |
| 561 __ ___ | |
| 562 _ _ _ _ | |
| 563 _ _ | |
| 564 _ _ | |
| 565 _ _ | |
| 566 _ | |
| 567 __ | |
| 568 | |
| 569 " | |
| 570 "")) | |
| 571 ;; And then hack it. | |
| 572 (gnus-indent-rigidly (point-min) (point-max) | |
| 573 (/ (max (- (window-width) (or x 46)) 0) 2)) | |
| 574 (goto-char (point-min)) | |
| 575 (forward-line 1) | |
| 576 (let* ((pheight (count-lines (point-min) (point-max))) | |
| 577 (wheight (window-height)) | |
| 578 (rest (- wheight pheight))) | |
| 579 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) | |
| 580 ;; Fontify some. | |
| 581 (goto-char (point-min)) | |
| 582 (and (search-forward "Praxis" nil t) | |
| 583 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
| 584 (goto-char (point-min)) | |
| 585 (let* ((mode-string (gnus-group-set-mode-line))) | |
| 586 (setq modeline-buffer-identification | |
| 587 (list (concat gnus-version ": *Group*"))) | |
| 588 (set-buffer-modified-p t)))) | |
| 589 | |
| 590 | |
| 591 ;;; The toolbar. | |
| 592 | |
| 593 (defvar gnus-use-toolbar (if (featurep 'toolbar) | |
| 594 'default-toolbar | |
| 595 nil) | |
| 596 "*If nil, do not use a toolbar. | |
| 597 If it is non-nil, it must be a toolbar. The five legal values are | |
| 598 `default-toolbar', `top-toolbar', `bottom-toolbar', | |
| 599 `right-toolbar', and `left-toolbar'.") | |
| 600 | |
| 601 (defvar gnus-group-toolbar | |
| 602 '( | |
| 603 [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] | |
| 604 [gnus-group-get-new-news-this-group | |
| 605 gnus-group-get-new-news-this-group t "Get new news in this group"] | |
| 606 [gnus-group-catchup-current | |
| 607 gnus-group-catchup-current t "Catchup group"] | |
| 608 [gnus-group-describe-group | |
| 609 gnus-group-describe-group t "Describe group"] | |
| 610 [gnus-group-kill-group gnus-group-kill-group t "Kill group"] | |
| 611 [gnus-group-exit gnus-group-exit t "Exit Gnus"] | |
| 612 ) | |
| 613 "The group buffer toolbar.") | |
| 614 | |
| 615 (defvar gnus-summary-toolbar | |
| 616 '( | |
| 617 [gnus-summary-prev-unread | |
| 618 gnus-summary-prev-unread-article t "Prev unread article"] | |
| 619 [gnus-summary-next-unread | |
| 620 gnus-summary-next-unread-article t "Next unread article"] | |
| 621 [gnus-summary-post-news | |
| 622 gnus-summary-post-news t "Post an article"] | |
| 623 [gnus-summary-followup-with-original | |
| 624 gnus-summary-followup-with-original t | |
| 625 "Post a followup and yank the original"] | |
| 626 [gnus-summary-followup | |
| 627 gnus-summary-followup t "Post a followup"] | |
| 628 [gnus-summary-reply-with-original | |
| 629 gnus-summary-reply-with-original t "Mail a reply and yank the original"] | |
| 630 [gnus-summary-reply | |
| 631 gnus-summary-reply t "Mail a reply"] | |
| 632 [gnus-summary-caesar-message | |
| 633 gnus-summary-caesar-message t "Rot 13"] | |
| 634 [gnus-uu-decode-uu | |
| 635 gnus-uu-decode-uu t "Decode uuencoded articles"] | |
| 636 [gnus-summary-save-article-file | |
| 637 gnus-summary-save-article-file t "Save article in file"] | |
| 638 [gnus-summary-save-article | |
| 639 gnus-summary-save-article t "Save article"] | |
| 640 [gnus-uu-post-news | |
| 641 gnus-uu-post-news t "Post an uuencoded article"] | |
| 642 [gnus-summary-cancel-article | |
| 643 gnus-summary-cancel-article t "Cancel article"] | |
| 644 [gnus-summary-catchup-and-exit | |
| 645 gnus-summary-catchup-and-exit t "Catchup and exit"] | |
| 646 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] | |
| 647 ) | |
| 648 "The summary buffer toolbar.") | |
| 649 | |
| 650 (defvar gnus-summary-mail-toolbar | |
| 651 '( | |
| 652 [gnus-summary-prev-unread | |
| 653 gnus-summary-prev-unread-article t "Prev unread article"] | |
| 654 [gnus-summary-next-unread | |
| 655 gnus-summary-next-unread-article t "Next unread article"] | |
| 656 [gnus-summary-mail-reply gnus-summary-reply t "Reply"] | |
| 657 [gnus-summary-mail-get gnus-mail-get t "Message get"] | |
| 658 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] | |
| 659 [gnus-summary-mail-save gnus-summary-save-article t "Save"] | |
| 660 [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] | |
| 661 ; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"] | |
| 662 [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] | |
| 663 ; [gnus-summary-mail-spell gnus-mail-spell t "Spell"] | |
| 664 ; [gnus-summary-mail-help gnus-mail-help t "Message help"] | |
| 665 [gnus-summary-caesar-message | |
| 666 gnus-summary-caesar-message t "Rot 13"] | |
| 667 [gnus-uu-decode-uu | |
| 668 gnus-uu-decode-uu t "Decode uuencoded articles"] | |
| 669 [gnus-summary-save-article-file | |
| 670 gnus-summary-save-article-file t "Save article in file"] | |
| 671 [gnus-summary-save-article | |
| 672 gnus-summary-save-article t "Save article"] | |
| 673 [gnus-summary-catchup-and-exit | |
| 674 gnus-summary-catchup-and-exit t "Catchup and exit"] | |
| 675 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] | |
| 676 ) | |
| 677 "The summary buffer mail toolbar.") | |
| 678 | |
| 679 (defun gnus-xmas-setup-group-toolbar () | |
| 680 (and gnus-use-toolbar | |
| 681 (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus") | |
| 682 (set-specifier (symbol-value gnus-use-toolbar) | |
| 683 (cons (current-buffer) gnus-group-toolbar)))) | |
| 684 | |
| 685 (defun gnus-xmas-setup-summary-toolbar () | |
| 686 (let ((bar (if (gnus-news-group-p gnus-newsgroup-name) | |
| 687 gnus-summary-toolbar gnus-summary-mail-toolbar))) | |
| 688 (and gnus-use-toolbar | |
| 689 (message-xmas-setup-toolbar bar nil "gnus") | |
| 690 (set-specifier (symbol-value gnus-use-toolbar) | |
| 691 (cons (current-buffer) bar))))) | |
| 692 | |
| 693 (defun gnus-xmas-mail-strip-quoted-names (address) | |
| 694 "Protect mail-strip-quoted-names from NIL input. | |
| 695 XEmacs compatibility workaround." | |
| 696 (if (null address) | |
| 697 nil | |
| 698 (mail-strip-quoted-names address))) | |
| 699 | |
| 700 (defun gnus-xmas-call-region (command &rest args) | |
| 701 (apply | |
| 702 'call-process-region (point-min) (point-max) command t '(t nil) nil | |
| 703 args)) | |
| 704 | |
| 705 (unless (find-face 'gnus-x-face) | |
| 706 (copy-face 'default 'gnus-x-face) | |
| 707 (set-face-foreground 'gnus-x-face "black") | |
| 708 (set-face-background 'gnus-x-face "white")) | |
| 709 | |
| 710 (defun gnus-xmas-article-display-xface (beg end) | |
| 711 "Display any XFace headers in the current article." | |
| 712 (save-excursion | |
| 713 (let (xface-glyph) | |
| 714 (if (featurep 'xface) | |
| 715 (setq xface-glyph | |
| 716 (make-glyph (vector 'xface :data | |
| 717 (concat "X-Face: " | |
| 718 (buffer-substring beg end))))) | |
| 719 (let ((cur (current-buffer))) | |
| 720 (save-excursion | |
| 721 (gnus-set-work-buffer) | |
| 722 (insert (format "%s" (buffer-substring beg end cur))) | |
| 723 (gnus-xmas-call-region "uncompface") | |
| 724 (goto-char (point-min)) | |
| 725 (insert "/* Width=48, Height=48 */\n") | |
| 726 (gnus-xmas-call-region "icontopbm") | |
| 727 (gnus-xmas-call-region "ppmtoxpm") | |
| 728 (setq xface-glyph | |
| 729 (make-glyph | |
| 730 (vector 'xpm :data (buffer-string ))))))) | |
| 731 (set-glyph-face xface-glyph 'gnus-x-face) | |
| 732 (goto-char (point-min)) | |
| 733 (re-search-forward "^From:" nil t) | |
| 734 (set-extent-begin-glyph | |
| 735 (make-extent (point) (1+ (point))) xface-glyph)))) | |
| 736 | |
| 737 (defun gnus-xmas-article-show-hidden-text (type &optional hide) | |
| 738 "Show all hidden text of type TYPE. | |
| 739 If HIDE, hide the text instead." | |
| 740 (save-excursion | |
| 741 (set-buffer gnus-article-buffer) | |
| 742 (let ((buffer-read-only nil) | |
| 743 (inhibit-point-motion-hooks t) | |
| 744 (beg (point-min))) | |
| 745 (while (gnus-goto-char (text-property-any | |
| 746 beg (point-max) 'gnus-type type)) | |
| 747 (setq beg (point)) | |
| 748 (forward-char) | |
| 749 (if hide | |
| 750 (gnus-hide-text beg (point) gnus-hidden-properties) | |
| 751 (gnus-unhide-text beg (point))) | |
| 752 (setq beg (point))) | |
| 753 (save-window-excursion | |
| 754 (select-window (get-buffer-window (current-buffer))) | |
| 755 (recenter)) | |
| 756 t))) | |
| 757 | |
| 758 (defun gnus-xmas-mode-line-buffer-identification (line) | |
| 759 (let ((line (car line)) | |
| 760 chop) | |
| 761 (if (not (stringp line)) | |
| 762 (list line) | |
| 763 (unless (setq chop (string-match ":" line)) | |
| 764 (setq chop (/ (length line) 2))) | |
| 765 (list (cons modeline-buffer-id-left-extent (substring line 0 chop)) | |
| 766 (cons modeline-buffer-id-right-extent (substring line chop)))))) | |
| 767 | |
| 768 (provide 'gnus-xmas) | |
| 769 | |
| 770 ;;; gnus-xmas.el ends here |