X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-bookmark.el;h=e26c78b65c5dc1815e860a7c4155e4010547bc2d;hp=775ab3054b6b40e08aae8eef89d6776a6fde352e;hb=91bfdfbc3e77a244efc8af47a47b30b10f48ec87;hpb=333aeb9610f5189544c882fd534e001d9f064f96 diff --git a/lisp/gnus-bookmark.el b/lisp/gnus-bookmark.el index 775ab3054..e26c78b65 100644 --- a/lisp/gnus-bookmark.el +++ b/lisp/gnus-bookmark.el @@ -1,26 +1,24 @@ ;;; gnus-bookmark.el --- Bookmarks in Gnus -;; Copyright (C) 2006 Free Software Foundation, Inc. +;; Copyright (C) 2006-2015 Free Software Foundation, Inc. ;; Author: Bastien Guerry ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -49,8 +47,6 @@ ;; - renaming bookmarks in gnus-bookmark-bmenu-list ;; - better (formatted string) display in bmenu-list -;; - Fix use of `split-string' and `assoc-string' for compatibility with Emacs -;; 21 and XEmacs 21.4. ;; - Integrate the `gnus-summary-*-bookmark' functionality ;; - Initialize defcustoms from corresponding `bookmark.el' variables? @@ -64,6 +60,14 @@ ;; (define-key global-map "\C-crj" 'gnus-bookmark-jump) ;; (define-key global-map "\C-crl" 'gnus-bookmark-bmenu-list) +;; FIXME: Add keybindings, see +;; http://thread.gmane.org/gmane.emacs.gnus.general/63101/focus=63379 +;; http://thread.gmane.org/v9fxx9fkm4.fsf@marauder.physik.uni-ulm.de + +;; FIXME: Check if `gnus-bookmark.el' should use +;; `bookmark-make-cell-function'. +;; Cf. http://article.gmane.org/gmane.emacs.gnus.general/66076 + (defgroup gnus-bookmark nil "Setting, annotation and jumping to Gnus bookmarks." :group 'gnus) @@ -77,6 +81,13 @@ :type 'string :group 'gnus-bookmark) +(defcustom gnus-bookmark-file-coding-system + (if (mm-coding-system-p 'iso-2022-7bit) + 'iso-2022-7bit) + "Coding system used for writing Gnus bookmark files." + :type '(symbol :tag "Coding system") + :group 'gnus-bookmark) + (defcustom gnus-bookmark-sort-flag t "Non-nil means Gnus bookmarks are sorted by bookmark names. Otherwise they will be displayed in LIFO order (that is, @@ -134,8 +145,8 @@ The default value is \(author subject date group annotation\)." (defface gnus-bookmark-menu-heading '((t (:inherit font-lock-type-face))) "Face used to highlight the heading in Gnus bookmark menu buffers." - :group 'gnus-bookmark - :version "22.1") + :version "23.1" ;; No Gnus + :group 'gnus-bookmark) (defconst gnus-bookmark-end-of-version-stamp-marker "-*- End Of Bookmark File Format Version Stamp -*-\n" @@ -145,9 +156,6 @@ The default value is \(author subject date group annotation\)." "The current version of the format used by bookmark files. You should never need to change this.") -(defvar gnus-bookmark-after-jump-hook nil - "Hook run after `gnus-bookmark-jump' jumps to a Gnus bookmark.") - (defvar gnus-bookmark-alist () "Association list of Gnus bookmarks and their records. The format of the alist is @@ -166,12 +174,23 @@ where each BMK is of the form So the cdr of each bookmark is an alist too.") +(defmacro gnus-bookmark-mouse-available-p () + "Return non-nil if a mouse is available." + (if (featurep 'xemacs) + '(device-on-window-system-p) + '(display-mouse-p))) + +(defun gnus-bookmark-remove-properties (string) + "Remove all text properties from STRING." + (set-text-properties 0 (length string) nil string) + string) + ;;;###autoload (defun gnus-bookmark-set () "Set a bookmark for this article." (interactive) (gnus-bookmark-maybe-load-default-file) - (if (or (not (eq major-mode 'gnus-summary-mode)) + (if (or (not (derived-mode-p 'gnus-summary-mode)) (not gnus-article-current)) (error "Please select an article in the Gnus summary buffer") (let* ((group (car gnus-article-current)) @@ -190,35 +209,32 @@ So the cdr of each bookmark is an alist too.") ;; Set the bookmark list (setq gnus-bookmark-alist (cons - (list bmk-name - (gnus-bookmark-make-cell + (list (gnus-bookmark-remove-properties bmk-name) + (gnus-bookmark-make-record group message-id author date subject annotation)) gnus-bookmark-alist)))) (gnus-bookmark-bmenu-surreptitiously-rebuild-list) (gnus-bookmark-write-file)) -(defun gnus-bookmark-make-cell +(defun gnus-bookmark-make-record (group message-id author date subject annotation) "Return the record part of a new bookmark, given GROUP MESSAGE-ID AUTHOR DATE SUBJECT and ANNOTATION." (let ((the-record - `((group . ,group) - (message-id . ,message-id) - (author . ,author) - (date . ,date) - (subject . ,subject) - (annotation . ,annotation)))) + `((group . ,(gnus-bookmark-remove-properties group)) + (message-id . ,(gnus-bookmark-remove-properties message-id)) + (author . ,(gnus-bookmark-remove-properties author)) + (date . ,(gnus-bookmark-remove-properties date)) + (subject . ,(gnus-bookmark-remove-properties subject)) + (annotation . ,(gnus-bookmark-remove-properties annotation))))) the-record)) (defun gnus-bookmark-set-bookmark-name (group author subject) "Set bookmark name from GROUP AUTHOR and SUBJECT." (let* ((subject (split-string subject)) (default-name-0 ;; Should be merged with -1? - ;; FIXME: In Emacs 21 or XEmacs 21.4 split-string accepts only 1-2 - ;; args. - (concat (car (reverse (split-string group "[\\.:]" t))) "-" - (car (split-string author)) "-" - (concat (car subject) "-" - (cadr subject)))) + (concat (car (nreverse (delete "" (split-string group "[\\.:]")))) + "-" (car (split-string author)) + "-" (car subject) "-" (cadr subject))) (default-name-1 ;; Strip "[]" chars from the bookmark name: (gnus-replace-in-string default-name-0 "[]_[]" "")) @@ -235,15 +251,16 @@ So the cdr of each bookmark is an alist too.") (interactive) (save-excursion (save-window-excursion - ;; Avoir warnings? + ;; Avoid warnings? ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) (set-buffer (get-buffer-create " *Gnus bookmarks*")) (erase-buffer) (gnus-bookmark-insert-file-format-version-stamp) (pp gnus-bookmark-alist (current-buffer)) (condition-case nil - (write-region (point-min) (point-max) - gnus-bookmark-default-file) + (let ((coding-system-for-write gnus-bookmark-file-coding-system)) + (write-region (point-min) (point-max) + gnus-bookmark-default-file)) (file-error (message "Can't write %s" gnus-bookmark-default-file))) (kill-buffer (current-buffer)) @@ -254,8 +271,13 @@ So the cdr of each bookmark is an alist too.") (defun gnus-bookmark-insert-file-format-version-stamp () "Insert text indicating current version of Gnus bookmark file format." (insert - (format ";;;; Gnus Bookmark Format Version %d ;;;;\n" - gnus-bookmark-file-format-version)) + (format ";;;; Gnus Bookmark Format Version %d %s;;;;\n" + gnus-bookmark-file-format-version + (if gnus-bookmark-file-coding-system + (concat "-*- coding: " + (symbol-name gnus-bookmark-file-coding-system) + "; -*- ") + ""))) (insert ";;; This format is meant to be slightly human-readable;\n" ";;; nevertheless, you probably don't want to edit it.\n" ";;; " @@ -267,13 +289,16 @@ So the cdr of each bookmark is an alist too.") (interactive) (gnus-bookmark-maybe-load-default-file) (let* ((bookmark (or bmk-name - (completing-read "Jump to bookmarked article: " - (mapcar 'car gnus-bookmark-alist)))) - (bmk-cell (cadr (assoc bookmark gnus-bookmark-alist))) - (group (cdr (assoc 'group bmk-cell))) - (message-id (cdr (assoc 'message-id bmk-cell)))) - (require 'gnus) - (if group (gnus-fetch-group group)) + (gnus-completing-read "Jump to bookmarked article" + (mapcar 'car gnus-bookmark-alist)))) + (bmk-record (cadr (assoc bookmark gnus-bookmark-alist))) + (group (cdr (assoc 'group bmk-record))) + (message-id (cdr (assoc 'message-id bmk-record)))) + (when group + (unless (get-buffer gnus-group-buffer) + (gnus-no-server)) + (gnus-activate-group group) + (gnus-group-quick-select-group 0 group)) (if message-id (or (gnus-summary-goto-article message-id nil 'force) (if (fboundp 'gnus-summary-insert-cached-articles) @@ -342,10 +367,11 @@ The leftmost column displays a D if the bookmark is flagged for deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) - (if (interactive-p) + (if (gmm-called-interactively-p 'any) (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) - (let ((inhibit-read-only t)) + (let ((inhibit-read-only t) + alist name start end) (erase-buffer) (insert "% Gnus Bookmark\n- --------\n") (add-text-properties (point-min) (point) @@ -353,29 +379,29 @@ deletion, or > if it is flagged for displaying." ;; sort before displaying (gnus-bookmark-maybe-sort-alist) ;; Display gnus bookmarks - (mapcar - (lambda (full-record) - ;; if a Gnus bookmark has an annotation, prepend a "*" - ;; in the list of bookmarks. - (let ((annotation (gnus-bookmark-get-annotation - (gnus-bookmark-name-from-full-record full-record)))) - (if (and annotation (not (string-equal annotation ""))) - (insert " *") - (insert " ")) - (let ((start (point))) - (insert (gnus-bookmark-name-from-full-record full-record)) - (if (and (display-color-p) (display-mouse-p)) - (add-text-properties - start - (save-excursion (re-search-backward - "[^ \t]") - (1+ (point))) - '(mouse-face highlight - follow-link t - help-echo "mouse-2: go to this article"))) - (insert "\n") - ))) - gnus-bookmark-alist) + (setq alist gnus-bookmark-alist) + (while alist + (setq name (gnus-bookmark-name-from-full-record (pop alist))) + ;; if a Gnus bookmark has an annotation, prepend a "*" + ;; in the list of bookmarks. + (insert (if (member (gnus-bookmark-get-annotation name) (list nil "")) + " " + " *")) + (if (gnus-bookmark-mouse-available-p) + (add-text-properties + (prog1 + (point) + (insert name)) + (let ((end (point))) + (prog2 + (re-search-backward "[^ \t]") + (1+ (point)) + (goto-char end) + (insert "\n"))) + `(mouse-face highlight follow-link t + help-echo ,(format "%s: go to this article" + (aref gnus-mouse-2 0)))) + (insert name "\n"))) (goto-char (point-min)) (forward-line 2) (gnus-bookmark-bmenu-mode) @@ -398,8 +424,7 @@ Don't affect the buffer ring order." "Return the full entry for Gnus BOOKMARK in `gnus-bookmark-alist'. If BOOKMARK is not a string, return nil." (when (stringp bookmark) - ;; FIXME: `assoc-string' doesn't exist in Emacs 21 and XEmacs 21.4: - (assoc-string bookmark gnus-bookmark-alist t))) + (assoc bookmark gnus-bookmark-alist))) (defun gnus-bookmark-get-bookmark-record (bookmark) "Return the guts of the entry for Gnus BOOKMARK in `gnus-bookmark-alist'. @@ -418,7 +443,9 @@ That is, all information but the name." nil (setq gnus-bookmark-bmenu-mode-map (make-keymap)) (suppress-keymap gnus-bookmark-bmenu-mode-map t) - (define-key gnus-bookmark-bmenu-mode-map "q" 'quit-window) + (define-key gnus-bookmark-bmenu-mode-map "q" (if (fboundp 'quit-window) + 'quit-window + 'bury-buffer)) (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select) (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select) (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete) @@ -436,7 +463,8 @@ That is, all information but the name." (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save) (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos) (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details) - (define-key gnus-bookmark-bmenu-mode-map [mouse-2] 'gnus-bookmark-bmenu-select)) + (define-key gnus-bookmark-bmenu-mode-map gnus-mouse-2 + 'gnus-bookmark-bmenu-select-by-mouse)) ;; Bookmark Buffer Menu mode is suitable only for specially formatted ;; data. @@ -445,7 +473,7 @@ That is, all information but the name." ;; Been to lazy to use gnus-bookmark-save... (defalias 'gnus-bookmark-bmenu-save 'gnus-bookmark-write-file) -(defun gnus-bookmark-bmenu-mode () +(define-derived-mode gnus-bookmark-bmenu-mode fundamental-mode "Bookmark Menu" "Major mode for editing a list of Gnus bookmarks. Each line describes one of the bookmarks in Gnus. Letters do not insert themselves; instead, they are commands. @@ -469,13 +497,8 @@ Gnus bookmarks names preceded by a \"*\" have annotations. in another buffer. \\[gnus-bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer. \\[gnus-bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark." - (kill-all-local-variables) - (use-local-map gnus-bookmark-bmenu-mode-map) (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'gnus-bookmark-bmenu-mode) - (setq mode-name "Bookmark Menu") - (gnus-run-mode-hooks 'gnus-bookmark-bmenu-mode-hook)) + (setq buffer-read-only t)) ;; avoid compilation warnings (defvar gnus-bookmark-bmenu-toggle-infos nil) @@ -510,10 +533,10 @@ Optional argument SHOW means show them unconditionally." (let ((bmrk (gnus-bookmark-bmenu-bookmark))) (setq gnus-bookmark-bmenu-hidden-bookmarks (cons bmrk gnus-bookmark-bmenu-hidden-bookmarks)) - (let ((start (save-excursion (end-of-line) (point)))) + (let ((start (point-at-eol))) (move-to-column gnus-bookmark-bmenu-file-column t) ;; Strip off `mouse-face' from the white spaces region. - (if (and (display-color-p) (display-mouse-p)) + (if (gnus-bookmark-mouse-available-p) (remove-text-properties start (point) '(mouse-face nil help-echo nil)))) (delete-region (point) (progn (end-of-line) (point))) @@ -529,24 +552,24 @@ Optional argument SHOW means show them unconditionally." (insert (gnus-bookmark-get-details bmk-name gnus-bookmark-bookmark-inline-details)) - (if (and (display-color-p) (display-mouse-p)) + (if (gnus-bookmark-mouse-available-p) (add-text-properties start (save-excursion (re-search-backward "[^ \t]") (1+ (point))) - '(mouse-face highlight + `(mouse-face highlight follow-link t - help-echo "mouse-2: go to this article")))))) + help-echo ,(format "%s: go to this article" + (aref gnus-mouse-2 0)))))))) (defun gnus-bookmark-kill-line (&optional newline-too) "Kill from point to end of line. If optional arg NEWLINE-TOO is non-nil, delete the newline too. Does not affect the kill ring." - (let ((eol (save-excursion (end-of-line) (point)))) - (delete-region (point) eol) - (if (and newline-too (looking-at "\n")) - (delete-char 1)))) + (delete-region (point) (point-at-eol)) + (if (and newline-too (looking-at "\n")) + (delete-char 1))) (defun gnus-bookmark-get-details (bmk-name details-list) "Get details for a Gnus BMK-NAME depending on DETAILS-LIST." @@ -578,16 +601,17 @@ Does not affect the kill ring." (gnus-bookmark-kill-line) (let ((start (point))) (insert (car gnus-bookmark-bmenu-hidden-bookmarks)) - (if (and (display-color-p) (display-mouse-p)) + (if (gnus-bookmark-mouse-available-p) (add-text-properties start (save-excursion (re-search-backward "[^ \t]") (1+ (point))) - '(mouse-face highlight + `(mouse-face highlight follow-link t help-echo - "mouse-2: go to this bookmark in other window")))) + ,(format "%s: go to this bookmark in other window" + (aref gnus-mouse-2 0)))))) (setq gnus-bookmark-bmenu-hidden-bookmarks (cdr gnus-bookmark-bmenu-hidden-bookmarks)) (forward-line 1)))))))) @@ -633,20 +657,18 @@ reposition and try again, else return nil." (defun gnus-bookmark-show-details (bookmark) "Display the annotation for BOOKMARK in a buffer." (let ((record (gnus-bookmark-get-bookmark-record bookmark)) - (details-list gnus-bookmark-bookmark-details)) + (old-buf (current-buffer)) + (details gnus-bookmark-bookmark-details) + detail) (save-excursion - (let ((old-buf (current-buffer))) - (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) - (delete-region (point-min) (point-max)) - (mapcar - (lambda (detail) - (when (not (equal (cdr (assoc detail record)) "")) - (insert (concat (symbol-name detail) ": " - (cdr (assoc detail record)) - "\n")))) - gnus-bookmark-bookmark-details) - (goto-char (point-min)) - (pop-to-buffer old-buf))))) + (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (erase-buffer) + (while details + (setq detail (pop details)) + (unless (equal (cdr (assoc detail record)) "") + (insert (symbol-name detail) ": " (cdr (assoc detail record)) "\n"))) + (goto-char (point-min)) + (pop-to-buffer old-buf)))) (defun gnus-bookmark-bmenu-show-details () "Show the annotation for the current bookmark in another window." @@ -730,6 +752,11 @@ command." (gnus-bookmark-jump bmrk) (bury-buffer menu)))) +(defun gnus-bookmark-bmenu-select-by-mouse (event) + (interactive "e") + (mouse-set-point event) + (gnus-bookmark-bmenu-select)) + (defun gnus-bookmark-bmenu-load () "Load the Gnus bookmark file and rebuild the bookmark menu-buffer." (interactive) @@ -792,5 +819,4 @@ probably because we were called from there." (provide 'gnus-bookmark) -;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525 ;;; gnus-bookmark.el ends here