From fa6d281597f94cda2824d8fdeb063ddd9007c0bb Mon Sep 17 00:00:00 2001 From: jao Date: Wed, 31 Mar 2021 01:39:06 +0100 Subject: bmk to attic --- attic/bmk/bmk-mgr-w3.el | 58 ++ attic/bmk/bmk-mgr-w3m.el | 84 +++ attic/bmk/bmk-mgr.el | 1478 +++++++++++++++++++++++++++++++++++++++++++ attic/bmk/dot-emacs.el | 42 ++ attic/bmk/folder-closed.xpm | 31 + attic/bmk/folder-open.xpm | 39 ++ attic/bmk/url-alt.xpm | 31 + attic/bmk/url.xpm | 39 ++ 8 files changed, 1802 insertions(+) create mode 100644 attic/bmk/bmk-mgr-w3.el create mode 100644 attic/bmk/bmk-mgr-w3m.el create mode 100644 attic/bmk/bmk-mgr.el create mode 100644 attic/bmk/dot-emacs.el create mode 100644 attic/bmk/folder-closed.xpm create mode 100644 attic/bmk/folder-open.xpm create mode 100644 attic/bmk/url-alt.xpm create mode 100644 attic/bmk/url.xpm (limited to 'attic') diff --git a/attic/bmk/bmk-mgr-w3.el b/attic/bmk/bmk-mgr-w3.el new file mode 100644 index 0000000..c22700f --- /dev/null +++ b/attic/bmk/bmk-mgr-w3.el @@ -0,0 +1,58 @@ +;;; bmk-mgr-w3.el --- w3 specific code for bmk-mgr + +;; Copyright (C) 2007, 2008 Jose Antonio Ortega Ruiz. +;; +;; Author: Robert D. Crawford +;; Author: Jose A Ortega Ruiz +;; Keywords: hypermedia + +;; This file 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 3, or (at your option) +;; any later version. + +;; This file 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 +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; Set up bmk-mgr for w3. + +;;; Code: + +;;;; Dependencies: + +(require 'bmk-mgr) +(require 'w3) + +(defun bmk-mgr-w3-current-url () + "Returns the current document url +without the string properties." + (interactive) + (substring-no-properties (url-view-url))) + +(defun bmk-mgr-w3-document-title-fixed () + "Removes the newline in long titles that +seems to have cropped up in current versions of w3." + (replace-regexp-in-string "\n" " " (buffer-name))) + +(add-hook 'w3-mode-hook + (lambda () + (setq bmk-mgr-document-title + 'bmk-mgr-w3-document-title-fixed) + (setq bmk-mgr-url-at-point 'w3-view-this-url) + (setq bmk-mgr-current-url 'bmk-mgr-w3-current-url))) +;; (setq bmk-mgr-document-title 'buffer-name) +(provide 'bmk-mgr-w3) + +;; Local variables ** +;; indent-tabs-mode: nil ** +;; end ** +;;; bmk-mgr-w3.el ends here diff --git a/attic/bmk/bmk-mgr-w3m.el b/attic/bmk/bmk-mgr-w3m.el new file mode 100644 index 0000000..cc53d41 --- /dev/null +++ b/attic/bmk/bmk-mgr-w3m.el @@ -0,0 +1,84 @@ +;;; bmk-mgr-w3m.el --- w3m specific code for bmk-mgr + +;; Copyright (C) 2007 Jose Antonio Ortega Ruiz. +;; +;; Author: Robert D. Crawford +;; Author: Jose A Ortega Ruiz +;; Keywords: hypermedia + +;; This file 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. + +;; This file 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 +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; Set up bmk-mgr for w3m. + +;;; Code: + +;;;; Dependencies: + +(require 'bmk-mgr) +(require 'w3m) + +(defsubst bmk-mgr-w3m-url-at-point () + "Return the url at point in w3m." + (or (w3m-anchor (point)) (w3m-image (point)))) + +(defsubst bmk-mgr-w3m-current-url () + "Returns the value of w3m-current-url." + w3m-current-url) + +(add-hook 'w3m-fontify-after-hook + (lambda () + (setq bmk-mgr-document-title 'w3m-current-title) + (setq bmk-mgr-url-at-point 'bmk-mgr-w3m-url-at-point) + (setq bmk-mgr-current-url 'bmk-mgr-w3m-current-url))) + +(bmk-mgr-import-add-formatter "w3m" 'bmk-mgr-w3m-import) + +(defun bmk-mgr-w3m-import (file name) + (if (not (file-readable-p file)) (error "Cannot read file")) + (with-temp-buffer + (let ((result (bmk-mgr-node-folder-new (or name "w3m"))) + (coding-system-for-read + (if (boundp 'w3m-bookmark-file-coding-system) + w3m-bookmark-file-coding-system + coding-system-for-read)) + (sec-delim (if (boundp 'w3m-bookmark-section-delimiter) + w3m-bookmark-section-delimiter + "\n"))) + (insert-file-contents file) + (goto-char 1) + (while (re-search-forward "

\\([^<]+\\)

\n
    \n" nil t) + (let* ((folder + (bmk-mgr-node-folder-new (match-string 1) t)) + (limit + (save-excursion + (and (search-forward sec-delim nil t) (point))))) + (while (search-forward "
  • \\([^<]+\\)\n" nil t) + (bmk-mgr-node-add-child + folder + (bmk-mgr-node-url-new (match-string 2) (match-string 1))))) + (bmk-mgr-node-add-child result folder))) + result))) + +(provide 'bmk-mgr-w3m) + +;; Local variables ** +;; indent-tabs-mode: nil ** +;; end ** + +;;; bmk-mgr-w3m.el ends here diff --git a/attic/bmk/bmk-mgr.el b/attic/bmk/bmk-mgr.el new file mode 100644 index 0000000..eab1844 --- /dev/null +++ b/attic/bmk/bmk-mgr.el @@ -0,0 +1,1478 @@ +;;; bmk-mgr.el --- Bookmark manager: + +;; Copyright (C) 2003, 2004, 2006, 2007, 2020 Jose Antonio Ortega Ruiz. +;; + +(defconst bmk-mgr-version "0.1.2") + +;; Author: Jose A Ortega Ruiz +;; Keywords: hypermedia + +;; This file 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. + +;; This file 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 +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;;; INTRODUCTION: +;;;; Emacs Bookmark Manager. +;;;; +;;;; INSTALLATION: +;;;; +;;;; CUSTOMIZATION: +;;;; +;;;; HISTORY: +;;;; - 0.1.1 (May 2006). XBEL importing corrected. +;;;; +;;;; TODO: +;;;; - Export: xbel, HTML, bmk +;;;; - Add menu: display bookmarks as a menu +;;;; +;;;; THANKS: +;;;; - David Magill, for lots of help in debugging. +;;;; + +;;; Code: + +;;;; Dependencies: + +(require 'cl) +(require 'outline) +(require 'browse-url) + +;;;; Compatibility: +(if (< emacs-major-version 22) + (progn + (defun substring-no-properties (x) x) + (defsubst bmk-string-to-int (x) (string-to-int x))) + (progn + (defsubst bmk-string-to-int (x) (string-to-number x)))) + +;;;; Customization: + +;;;;; Customization buffer: +(defgroup bmk-mgr nil + "Bookmark manager" + :group 'hypermedia + :prefix "bmk-mgr-") + +(defcustom bmk-mgr-bookmark-file "~/.emacs.bookmarks" + "The file where bookmarks are stored." + :group 'bmk-mgr + :type 'file) + +(defcustom bmk-mgr-autosave t + "If on, save bookmarks whenever they are modified." + :group 'bmk-mgr + :type 'boolean) + +(defcustom bmk-mgr-indent-width 2 + "The amount of indentation for evey new subfolder level." + :group 'bmk-mgr + :type 'number) + +(defcustom bmk-mgr-link-mark "" + "The string used to prefix link names." + :group 'bmk-mgr + :type 'string) + +(defcustom bmk-mgr-open-mark "- " + "The string used to prefix open folder names." + :group 'bmk-mgr + :type 'string) + +(defcustom bmk-mgr-closed-mark "+ " + "The string used to prefix closed folder names." + :group 'bmk-mgr + :type 'string) + +(defconst bmk-mgr-available-browsers + '(choice + (function-item :tag "Default" :value nil) + (function-item :tag "Emacs W3" :value browse-url-w3) + (function-item :tag "W3 in another Emacs via `gnudoit'" + :value browse-url-w3-gnudoit) + (function-item :tag "Mozilla" :value browse-url-mozilla) + (function-item :tag "Galeon" :value browse-url-galeon) + (function-item :tag "Netscape" :value browse-url-netscape) + (function-item :tag "Mosaic" :value browse-url-mosaic) + (function-item :tag "Mosaic using CCI" :value browse-url-cci) + (function-item :tag "IXI Mosaic" :value browse-url-iximosaic) + (function-item :tag "Lynx in an xterm window" + :value browse-url-lynx-xterm) + (function-item :tag "Lynx in an Emacs window" + :value browse-url-lynx-emacs) + (function-item :tag "Grail" :value browse-url-grail) + (function-item :tag "MMM" :value browse-url-mmm) + (function-item :tag "KDE" :value browse-url-kde) + (function-item :tag "Specified by `Browse Url Generic Program'" + :value browse-url-generic) + (function-item :tag "Default Windows browser" + :value browse-url-default-windows-browser) + (function-item :tag "GNOME invoking Mozilla" + :value browse-url-gnome-moz) + (function-item :tag "Default browser" + :value browse-url-default-browser) + (function :tag "Your own function") + (alist :tag "Regexp/function association list" + :key-type regexp :value-type function))) + +(defcustom bmk-mgr-browser-function nil + "*Function to display the current bookmark in a WWW browser. + +This has the same semantics as `browse-url''s `browse-url-browser-function'. +If you set this variable to nil, the latter will be used. Otherwise, +if the value is not a function it should be a list of pairs +\(REGEXP . FUNCTION). In this case the function called will be the one +associated with the first REGEXP which matches the current URL. The +function is passed the URL and any other args of `browse-url'. The last +regexp should probably be \".\" to specify a default browser." + :type bmk-mgr-available-browsers + :group 'bmk-mgr) + +(defcustom bmk-mgr-alt-browser-function nil + "Alternative function to display the current bookmark in a WWW browser. + +This has the same semantics as `bmk-mgr-browser-function'. You can use +it to have a second browsing function available (activated by pressing +`shift-return' instead of just `return'). A typical application is to +have one to display the bookmark in the current tab, and another to +display the bookmark in a new tab." + :type bmk-mgr-available-browsers + :group 'bmk-mgr) + + +(defcustom bmk-mgr-inhibit-welcome-message nil + "When on, do not display a welcome message in the minibuffer upon +entering the bookmark manager." + :group 'bmk-mgr + :type 'boolean) + +(defcustom bmk-mgr-inhibit-minibuffer nil + "When on, do not automatically display info about the current folder +or bookmark in the minibuffer." + :group 'bmk-mgr + :type 'boolean) + +(defcustom bmk-mgr-ignore-fold-state nil + "Turn this variable on to display the initial tree with all +subfolders closed, instead of using their last state." + :group 'bmk-mgr + :type 'boolean) + +(defcustom bmk-mgr-use-images nil + "If on, images are used by default." + :type 'boolean + :group 'bmk-mgr) + +(defcustom bmk-mgr-folder-open-image "folder-open.xpm" + "Image to use for representing open folders." + :type 'file + :group 'bmk-mgr) + +(defcustom bmk-mgr-folder-closed-image "folder-closed.xpm" + "Image to use for representing closed folders." + :type 'file + :group 'bmk-mgr) + +(defcustom bmk-mgr-bookmark-image "url.xpm" + "Image to use for representing bookmarks." + :type 'file + :group 'bmk-mgr) + +(defcustom bmk-mgr-use-own-frame nil + "Whether the bookmars buffer should be displayed on its own frame." + :type 'boolean + :group 'bmk-mgr) + +(defcustom bmk-mgr-frame-parameters '((width . 60)) + "Parameters of the bookmars buffer frame, when +`bmk-mgr-use-own-frame' has been set to non-nil" + :type '(repeat (sexp :tag "Parameter:")) + :group 'bmk-mgr) + +(defface bmk-mgr-folder-face '((t (:bold t :foreground nil :weight bold))) + "Face for folder names." + :group 'bmk-mgr) + +(defface bmk-mgr-sel-folder-face + '((t (:bold t :foreground "IndianRed" :weight bold))) + "Face for selected folder names." + :group 'bmk-mgr) + +(defface bmk-mgr-bookmark-face '((t ())) + "Face for bookmark names." + :group 'bmk-mgr) + +(defface bmk-mgr-sel-bookmark-face '((t (:foreground "IndianRed"))) + "Face for selected bookmark names." + :group 'bmk-mgr) + +;;;;; Other variables: + +(defvar bmk-mgr-bookmark-buffer-name "*Bookmarks*" + "*Name of the bookmarks buffer.") + +(defvar bmk-mgr-kill-ring-size 50 + "*Maximum number of killed bookmarks to be remembered.") + +(defvar bmk-mgr-line-spacing 2 + "*Additional space to put between lines when displaying the +bookmarks buffer. + +The space is measured in pixels, and put below lines on window +systems.") + +(defvar bmk-mgr-document-title nil + "Function variable returning the current document title.") + +(defvar bmk-mgr-url-at-point nil + "Function variable returning the value of the url under point.") + +(defvar bmk-mgr-current-url nil + "Function variable returning the value of the current document url.") + +(make-variable-buffer-local 'bmk-mgr-document-title) +(make-variable-buffer-local 'bmk-mgr-url-at-point) +(make-variable-buffer-local 'bmk-mgr-current-url) + +;;;; User interactive functions: + +(defun bmk-mgr-create-bookmark-buffer () + (let ((tree (bmk-mgr-read-from-file bmk-mgr-bookmark-file))) + (when tree + (when bmk-mgr-use-own-frame + (select-frame (make-frame bmk-mgr-frame-parameters))) + (switch-to-buffer + (get-buffer-create bmk-mgr-bookmark-buffer-name)) + (bmk-mgr-mode tree) + (current-buffer)))) + +(defsubst bmk-mgr-get-bookmark-buffer () + (or (get-buffer bmk-mgr-bookmark-buffer-name) + (bmk-mgr-create-bookmark-buffer))) + +(defun bmk-mgr-show-bookmarks () + "Display the bookmarks buffer." + (interactive) + (let ((display-buffer-reuse-frames bmk-mgr-use-own-frame) + (pop-up-frames bmk-mgr-use-own-frame)) + (switch-to-buffer (bmk-mgr-get-bookmark-buffer)))) + +(defun bmk-mgr-show-bookmarks-other-window () + "Display the bookmarks buffer in other window" + (interactive) + (let ((display-buffer-reuse-frames nil) + (pop-up-frames nil)) + (split-window-horizontally (/ (* 2 (window-width)) 3)) + (other-window 1) + (switch-to-buffer (bmk-mgr-get-bookmark-buffer)))) + +(defun bmk-mgr-add-url-at-point () + "Add URL at point to the bookmarks collection. +If there is no URL at point, this command asks for it." + (interactive) + (if bmk-mgr-url-at-point + (bmk-mgr-add-bookmark-at-folder (funcall bmk-mgr-url-at-point)) + (progn + (require 'ffap) + (bmk-mgr-add-bookmark-at-folder (ffap-url-at-point))))) + +;; the following 2 functions need to be combined and generalized +(defun bmk-mgr-add-current-page () + "Adds the current page to the bookmark list." + (interactive) + (unless bmk-mgr-current-url + (error "Current buffer has no associated URL.")) + ;; please leave these here, as I will need them later -- rdc + ;; (message "bmk-mgr-current-url value as function is %s" + ;; bmk-mgr-current-url) + ;; (message "bmk-mgr-current-url value as variable is %s" + ;; (funcall bmk-mgr-current-url)) + ;; (message "bmk-mgr-document-title value as function is %s" + ;; bmk-mgr-document-title) + ;; (message "bmk-mgr-document-title value as variable is %s" + ;; (funcall bmk-mgr-document-title)) + (bmk-mgr-add-bookmark-at-folder + (funcall bmk-mgr-current-url) + (funcall bmk-mgr-document-title))) + +;;;; Bookmark mode: + +;;;;; Variables: + +(defvar bmk-mgr-kill-ring nil "Killed nodes list") + +(defmacro bmk-mgr-folder-or-url (ffun ufun) + `(lambda () + (interactive) + (if (bmk-mgr-node-folder-p (bmk-mgr-get-node-at-point)) + (funcall ',ffun) + (funcall ',ufun)))) + +(defvar bmk-mgr-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [(control ?a)] 'beginning-of-line) + (define-key map [(control ?e)] 'end-of-line) + (define-key map [(control ?k)] 'bmk-mgr-kill-bookmark) + (define-key map [(control ?n)] 'bmk-mgr-next-line) + (define-key map [(control ?p)] 'bmk-mgr-previous-line) + (define-key map [(control ?y)] 'bmk-mgr-yank-bookmark) + (define-key map [??] 'describe-mode) + (define-key map [?A] 'bmk-mgr-add-folder) + (define-key map [?I] 'bmk-mgr-toggle-images) + (define-key map [?N] 'bmk-mgr-next-folder) + (define-key map [?P] 'bmk-mgr-previous-folder) + (define-key map [?Q] 'bmk-mgr-quit) + (define-key map [?V] 'bmk-mgr-version) + (define-key map [?a] 'bmk-mgr-add-bookmark) + (define-key map [?c] 'bmk-mgr-close-children) + (define-key map [?d] 'bmk-mgr-move-bookmark-down) + (define-key map [?e] 'bmk-mgr-edit-bookmark) + (define-key map [?f] 'bmk-mgr-find-folder) + (define-key map [?h] 'describe-mode) + (define-key map [?i] 'bmk-mgr-import) + (define-key map [?n] 'bmk-mgr-next-line) + (define-key map [?p] 'bmk-mgr-previous-line) + (define-key map [?q] 'bmk-mgr-quit-ask) + (define-key map [?s] 'bmk-mgr-save-bookmarks) + (define-key map [?u] 'bmk-mgr-move-bookmark-up) + (define-key map [?v] 'bmk-mgr-bookmark-info) + (define-key map [?y] 'bmk-mgr-copy-url) + (define-key map (kbd "") 'bmk-mgr-previous-line) + (define-key map (kbd "") 'bmk-mgr-next-line) + (define-key map (kbd "") 'beginning-of-line) + (define-key map (kbd "") 'end-of-line) + (define-key map (kbd "") 'bmk-mgr-mouse-click) + (define-key map (kbd "") 'bmk-mgr-mouse-click-alt) + (define-key map (kbd "") 'bmk-mgr-browse-url-alt) + (define-key map (kbd "M-RET") 'bmk-mgr-browse-url-alt) + (define-key map (kbd "RET") 'bmk-mgr-browse-url) + (define-key map (kbd "TAB") 'bmk-mgr-toggle-folder) + map) + "Keymap for `bmk-mgr-mode'.") + +(defvar bmk-mgr-mode-syntax-table + (let ((st (make-syntax-table))) + st) + "Syntax table for `bmk-mgr-mode'.") + +;; regexps used by bmk-mgr-mode and other functions +(defvar bmk-mgr-outline-regexp nil) + +;; images +(defvar bmk-mgr-url-img) +(defvar bmk-mgr-fopen-img) +(defvar bmk-mgr-fclosed-img) + +;;;;; Mode definition: + +;;;###autoload +(defun bmk-mgr-mode (&optional tree) + "\\ + Major mode for displaying bookmark files. + +Commands: + ++\tRepeat command denoted by the number of times + \tpreviously typed. Commands accepting a prefix count are + \tmarked with (*) below. + +\\[bmk-mgr-next-line]\tGo to next visible line (*). +\\[bmk-mgr-previous-line]\tGo to previous visible line (*). +\\[bmk-mgr-next-folder]\tGo to next visible folder (*). +\\[bmk-mgr-previous-folder]\tGo to previous visible folder (*). +\\[beginning-of-line]\tGo to the beginning of text in current line. +\\[end-of-line]\tGo to the end of text in current line. +\\[bmk-mgr-toggle-folder]\tOpens or closes current folder. +\\[bmk-mgr-close-children]\tCloses all subfolders of current folder. +\\[bmk-mgr-bookmark-info]\tDisplay info about current bookmark or folder. +\\[bmk-mgr-copy-url]\tPut the current URL (if any) in the kill ring. +\\[bmk-mgr-find-folder]\tFind bookmarks folder. + +\\[bmk-mgr-mouse-click]\tDisplay or toggle the clicked URL or folder. +\\[bmk-mgr-mouse-click-alt]\tDisplay or toggle the clicked URL or folder, + \tusing the alternate browser. +\\[bmk-mgr-browse-url]\tDisplay current URL in browser. +\\[bmk-mgr-browse-url-alt]\tDisplay current URL in alternate browser. + +\\[bmk-mgr-move-bookmark-up]\tMoves current bookmark one line up (*). +\\[bmk-mgr-move-bookmark-down]\tMoves current bookmark one line down (*). +\\[bmk-mgr-edit-bookmark]\tEdit bookmark or folder in current line. +\\[bmk-mgr-add-bookmark]\tAdd a new bookmark (asks for its name and URL). +\\[bmk-mgr-add-folder]\tAdd a new bookmark folder (asks for its path). +\\[bmk-mgr-kill-bookmark]\tKills current bookmark or folder, putting it in the kill ring (*). +\\[bmk-mgr-yank-bookmark]\tYanks a previously killed bookmark or folder (*). + +\\[bmk-mgr-import]\tImports an external bookmarks file (xbel, w3m, bmk). + +\\[bmk-mgr-toggle-images]\tToggle display of images. + +\\[bmk-mgr-save-bookmarks]\tSave current bookmarks. +\\[bmk-mgr-quit]\tQuit Bookmark Manager. +\\[bmk-mgr-quit-ask]\tQuit Bookmark Manager asking for confirmation. + +\\[bmk-mgr-version]\tShow version. +\\[describe-mode]\tShows this help page. +" + (kill-all-local-variables) + (buffer-disable-undo) + (setq major-mode 'bmk-mgr-mode) + (setq mode-name "bmk") + (use-local-map bmk-mgr-mode-map) + + (let ((prefix (make-string bmk-mgr-indent-width 32))) + (setq bmk-mgr-outline-regexp (concat "\\(" prefix "\\)*."))) + (set (make-local-variable 'outline-regexp) bmk-mgr-outline-regexp) + (set (make-local-variable 'truncate-lines) t) + (set (make-local-variable 'automatic-hscrolling) t) + (set (make-local-variable 'line-spacing) bmk-mgr-line-spacing) + (set (make-local-variable 'kill-whole-line) t) + (set (make-local-variable 'next-line-add-newlines) t) + (goto-char 1) + (bmk-mgr-refresh tree) + (toggle-read-only 1) + (unless bmk-mgr-inhibit-welcome-message + (message + "Emacs Bookmark Manager, version %s. Type `h' for help." bmk-mgr-version))) + +;;;;; Functions: + +;;;;;; Helper macros: +(defmacro bmk-mgr-with-bookmarks-buffer (&rest body) + `(with-current-buffer (bmk-mgr-get-bookmark-buffer) + (unwind-protect + (prog1 + (let ((inhibit-read-only t)) + (bmk-mgr-unmark-current) + ,@body) + (if (not bmk-mgr-inhibit-minibuffer) (bmk-mgr-bookmark-info))) + (bmk-mgr-mark-current)))) + +(defmacro bmk-mgr-with-current-node (&rest body) + `(bmk-mgr-with-bookmarks-buffer + (beginning-of-line) + (let ((bmk-node (bmk-mgr-get-node-at-point)) + (bmk-path (bmk-mgr-get-path-at-point))) + ,@body))) + +(defmacro bmk-mgr-with-current-node-save (&rest body) + `(bmk-mgr-with-current-node + (prog1 + (progn ,@body) + (if bmk-mgr-autosave + (progn + (bmk-mgr-save-current-tree) + (set-buffer-modified-p nil)))))) + +(defmacro bmk-mgr-repeat (&rest body) + `(let ((count bmk-mgr-repeat-count)) + (while (> count 0) + (decf count) + ,@body))) + +;;;;;; Helper functions: +(defun bmk-mgr-outline-level () + (save-excursion + (beginning-of-line) + (if (looking-at bmk-mgr-outline-regexp) + (length (match-string 0)) + 0))) + +(defun bmk-mgr-mark-current () + (let* ((inhibit-read-only 1) + (node (bmk-mgr-get-node-at-point)) + (face (if (bmk-mgr-node-folder-p node) 'bmk-mgr-sel-folder-face + 'bmk-mgr-sel-bookmark-face))) + (beginning-of-line) + (save-excursion + (add-text-properties (progn (bmk-mgr-beginning) (point)) + (progn (end-of-line) (point)) + `(face ,face))))) + +(defun bmk-mgr-unmark-current () + (let* ((inhibit-read-only 1) + (node (bmk-mgr-get-node-at-point)) + (face (if (bmk-mgr-node-folder-p node) 'bmk-mgr-folder-face + 'bmk-mgr-bookmark-face))) + (add-text-properties (progn (bmk-mgr-beginning) (point)) + (save-excursion (end-of-line) (point)) + `(face ,face)))) + +(defun bmk-mgr-unmark-all () + (save-excursion + (goto-char 1) + (while (not (eobp)) + (bmk-mgr-unmark-current) + (next-line 1)))) + +(defun bmk-mgr-push-to-kill-ring (node) + (push (copy-list node) bmk-mgr-kill-ring) + (when (> (length bmk-mgr-kill-ring) bmk-mgr-kill-ring-size) + (setcdr (nthcdr (1- bmk-mgr-kill-ring-size) bmk-mgr-kill-ring) nil))) + +(defsubst bmk-mgr-pop-kill-ring () (pop bmk-mgr-kill-ring)) + +(defsubst bmk-mgr-url-at-point () + "Get the URL of the current bookmark, if any." + (bmk-mgr-node-url (bmk-mgr-get-node-at-point))) + +(defun bmk-mgr-save-current-tree () + (bmk-mgr-save-to-file (bmk-mgr-get-root-node-in-buffer) + bmk-mgr-bookmark-file)) + +(defun bmk-mgr-ask-path (prompt &optional path) + (let ((PC-word-delimiters ".") + (bmk-mgr-inhibit-minibuffer t) + (path (or path (list (bmk-mgr-node-name + (bmk-mgr-get-root-node-in-buffer)))))) + (bmk-mgr-string-to-path + (completing-read prompt 'bmk-mgr-complete-path nil nil + (concat (bmk-mgr-path-to-string path) "/"))))) + +(defun bmk-mgr-complete-path (pstr fun flag) + (bmk-mgr-with-bookmarks-buffer + (let* ((root (bmk-mgr-get-root-node-in-buffer)) + (partial (not (string-match "/$" pstr))) + (pc (split-string pstr "/")) + (path (or pc (list (bmk-mgr-node-name root)))) + (ppath (if partial (bmk-mgr-path-parent path) path)) + (partstr (concat "^" (regexp-quote (bmk-mgr-path-leaf path)))) + (str (concat (bmk-mgr-path-to-string ppath) "/")) + (children (bmk-mgr-node-child-folders root ppath)) + (comp (mapcar (lambda (x) (concat str (bmk-mgr-node-name x) "/")) + (if partial + (remove-if-not + (lambda (x) + (string-match partstr (bmk-mgr-node-name x))) + children) + children))) + (len (length comp))) + (case flag + ((nil) (cond + ((and (not partial) (zerop len)) t) + ((= len 1) (car comp)) + ((zerop len) nil) + (t pstr))) + ((lambda) (not partial)) + (t comp))))) + +;;;;;; Mode functions: + +(defun bmk-mgr-version () + "Display version." + (interactive) + (message "Emacs Bookmark Manager, version %s" bmk-mgr-version)) + +(defun bmk-mgr-toggle-images () + "Toggle image display." + (interactive) + (setq bmk-mgr-use-images (not bmk-mgr-use-images)) + (bmk-mgr-refresh)) + +(defun bmk-mgr-refresh (&optional tree) + "Refresh the bookmarks buffer." + (interactive) + (message "Redisplaying bookmarks...") + (bmk-mgr-with-bookmarks-buffer + (if window-system + (progn + (clear-image-cache + (window-frame (get-buffer-window (current-buffer)))) + (setq bmk-mgr-url-img + (find-image + `((:file ,bmk-mgr-bookmark-image :type xpm :ascent center)))) + (setq bmk-mgr-fopen-img + (find-image + `((:file ,bmk-mgr-folder-open-image :type xpm :ascent 95)))) + (setq bmk-mgr-fclosed-img + (find-image + `((:file ,bmk-mgr-folder-closed-image :type xpm :ascent 95))))) + (setq bmk-mgr-url-img nil bmk-mgr-fopen-img nil bmk-mgr-fclosed-img nil + bmk-mgr-use-images nil)) + (let ((tree (or tree (bmk-mgr-get-root-node-in-buffer)))) + (save-excursion + (erase-buffer) + (if bmk-mgr-ignore-fold-state (bmk-mgr-node-close-all-children tree)) + (bmk-mgr-print-tree tree) + (goto-char 1) + (bmk-mgr-unmark-all) + (bmk-mgr-refresh-open-close))) + (message "Redisplaying bookmarks... done."))) + +(defsubst bmk-mgr-beginning () + "Go to beginning of current bookmark." + (interactive) + (beginning-of-line) + (re-search-forward "^ *")) + +(defun bmk-mgr-next-line (arg) + "Go to next visible bookmark line." + (interactive "P") + (bmk-mgr-with-bookmarks-buffer + (outline-next-visible-heading (if arg (prefix-numeric-value arg) 1)) + (if (eobp) (outline-previous-visible-heading 1)))) + +(defun bmk-mgr-previous-line (arg) + "Go to previous visible bookmark line." + (interactive "P") + (bmk-mgr-with-bookmarks-buffer + (outline-previous-visible-heading (if arg (prefix-numeric-value arg) 1)))) + +(defun bmk-mgr-bookmark-info () + "Show info about current bookmark or folder." + (interactive) + (let ((node (bmk-mgr-get-node-at-point))) + (if node + (if (bmk-mgr-node-url-p node) + (let ((url (bmk-mgr-node-url node))) + (and url (message "%s" url))) + (let ((children (bmk-mgr-node-child-folders node))) + (if children + (message + "%s" + (concat "Subfolders: " + (mapconcat 'bmk-mgr-node-name children ", "))))))))) + +(defun bmk-mgr-copy-url () + "Put current URL in the kill ring." + (interactive) + (bmk-mgr-with-current-node + (let ((url (bmk-mgr-node-url bmk-node))) + (when url + (kill-new url) + (message "%s copied" url))))) + +(defun bmk-mgr-next-folder (arg) + "Go to next visible bookmark folder." + (interactive "P") + (bmk-mgr-with-bookmarks-buffer + (let ((count (if arg (prefix-numeric-value arg) 1)) + (test (lambda () (bmk-mgr-node-url-p (bmk-mgr-get-node-at-point))))) + (while (> count 0) + (decf count) + (if (not (funcall test)) (outline-next-visible-heading 1)) + (while (funcall test) + (outline-next-visible-heading 1)))) + (if (eobp) (outline-previous-visible-heading 1)) + (bmk-mgr-beginning))) + +(defun bmk-mgr-previous-folder (arg) + "Go to previous visible bookmark folder." + (interactive "P") + (bmk-mgr-with-bookmarks-buffer + (let ((count (if arg (prefix-numeric-value arg) 1)) + (test (lambda () (bmk-mgr-node-url-p (bmk-mgr-get-node-at-point))))) + (while (> count 0) + (decf count) + (if (not (funcall test)) (outline-previous-visible-heading 1)) + (while (funcall test) + (outline-previous-visible-heading 1)))) + (bmk-mgr-beginning))) + +(defun bmk-mgr-browse-url () + "Display current bookmark in browser." + (interactive) + (let ((browse-url-browser-function + (or bmk-mgr-browser-function browse-url-browser-function)) + (url (bmk-mgr-node-url (bmk-mgr-get-node-at-point)))) + (if url (browse-url url) (bmk-mgr-toggle-folder)))) + +(defun bmk-mgr-browse-url-alt () + "Display current bookmark in alternate browser." + (interactive) + (bmk-mgr-with-current-node + (let ((browse-url-browser-function + (or bmk-mgr-alt-browser-function browse-url-browser-function)) + (url (bmk-mgr-node-url (bmk-mgr-get-node-at-point)))) + (if url (browse-url url) (bmk-mgr-toggle-folder))))) + +(defun bmk-mgr-mouse-click (event) + "Visit the clicked bookmark or toogle the folder state." + (interactive "e") + (set-buffer (bmk-mgr-get-bookmark-buffer)) + (goto-char (posn-point (event-start event))) + (let ((node (bmk-mgr-get-node-at-point))) + (if (bmk-mgr-node-url-p node) + (bmk-mgr-browse-url) + (if (bmk-mgr-node-folder-p node) + (bmk-mgr-toggle-folder))))) + +(defun bmk-mgr-mouse-click-alt (event) + "Visit the clicked bookmark or toogle the folder state." + (interactive "e") + (set-buffer (bmk-mgr-get-bookmark-buffer)) + (goto-char (posn-point (event-start event))) + (let ((node (bmk-mgr-get-node-at-point))) + (if (bmk-mgr-node-url-p node) + (bmk-mgr-browse-url-alt) + (if (bmk-mgr-node-folder-p node) + (bmk-mgr-toggle-folder))))) + +(defun bmk-mgr-toggle-folder () + "Toggle the open/closed status of folder at point, if any." + (interactive) + (bmk-mgr-with-current-node + (when (bmk-mgr-node-folder-p bmk-node) + (bmk-mgr-node-toggle-open-closed bmk-node) + (bmk-mgr-redraw-node-at-point)))) + +(defun bmk-mgr-close-children () + "Close all subfolders of folder at point, if any." + (interactive) + (bmk-mgr-with-current-node + (when (bmk-mgr-node-folder-p bmk-node) + (bmk-mgr-node-close-all-children bmk-node) + (bmk-mgr-update-tree-at-point) + (bmk-mgr-refresh-open-close)))) + +(defun bmk-mgr-find-folder () + "Find a bookmarks folder." + (interactive) + (bmk-mgr-with-bookmarks-buffer + (bmk-mgr-find-path-in-buffer (bmk-mgr-ask-path "Find folder: ") t))) + +(defun bmk-mgr-save-bookmarks () + "Save current bookmars." + (interactive) + (when (y-or-n-p "Save current bookmarks? ") + (with-current-buffer (bmk-mgr-get-bookmark-buffer) + (bmk-mgr-save-current-tree) + (set-buffer-modified-p nil)))) + +(defun bmk-mgr-edit-bookmark () + "Edit the current bookmark." + (interactive) + (bmk-mgr-with-current-node-save + (when bmk-node + (let ((newtitle (read-string "Name: " (bmk-mgr-node-title bmk-node)))) + (if (> (length newtitle) 0) (bmk-mgr-node-set-name bmk-node newtitle)) + (if (bmk-mgr-node-url-p bmk-node) + (let ((newurl (read-string "URL: " (bmk-mgr-node-url bmk-node)))) + (if (> (length newurl) 0) (bmk-mgr-node-set-url bmk-node newurl)))) + (bmk-mgr-redraw-node-at-point + (append (bmk-mgr-path-parent bmk-path) (list newtitle))) + (if (bmk-mgr-node-folder-p bmk-node) ; update children paths + (save-excursion + (let ((cl (bmk-mgr-outline-level)) + (pos (length (bmk-mgr-path-parent bmk-path)))) + (forward-line 1) + (while (> (bmk-mgr-outline-level) cl) + (setf (nth pos (bmk-mgr-get-path-at-point)) newtitle) + (forward-line 1))))) + (beginning-of-line))))) + +(defun bmk-mgr-add-bookmark-at-folder (&optional url title) + (let ((path + (bmk-mgr-with-current-node + (bmk-mgr-ask-path "Add bookmark to folder: " + (if (bmk-mgr-node-folder-p bmk-node) bmk-path + (bmk-mgr-path-parent bmk-path)))))) + (bmk-mgr-add-bookmark path nil url title t))) + + +(defun bmk-mgr-add-bookmark (&optional path node url title after) + "Insert bookmark at a given path or current point." + (interactive) + (bmk-mgr-with-current-node-save + (let* ((title (or title + (and node (bmk-mgr-node-name node)) + (read-string "Name of new bookmark: "))) + (url (or (and node "") url (read-string "URL: "))) + (node (or node (bmk-mgr-node-url-new title url)))) + (if (and path (not (bmk-mgr-find-path-in-buffer path t))) + (error "Folder %s does not exist" + (bmk-mgr-path-to-string path))) + (message "adding with path %S (%S)" path after) + (if (not (or path bmk-path)) (outline-previous-visible-heading 1)) + (if (and (bmk-mgr-node-folder-p (bmk-mgr-get-node-at-point)) + (bmk-mgr-node-open-p (bmk-mgr-get-node-at-point))) + (bmk-mgr-insert-child-at-point node (not after)) + (bmk-mgr-insert-sibling-at-point node nil)) + (while (not (or (eobp) (eq node (bmk-mgr-get-node-at-point)))) + (outline-next-visible-heading 1))))) + +(defun bmk-mgr-add-folder () + "Insert new bookmarks folder." + (interactive) + (bmk-mgr-with-current-node-save + (let* ((fpath (if (bmk-mgr-node-folder-p bmk-node) bmk-path + (bmk-mgr-path-parent bmk-path))) + (npath (bmk-mgr-ask-path "New folder: " fpath)) + (pnpath (bmk-mgr-path-parent npath)) + (sibling (and (not (equal bmk-path fpath)) ; inserting besides a url + (equal fpath pnpath)))) ; in the same folder + (if (and (not (equal fpath pnpath)) + (not (bmk-mgr-find-path-in-buffer pnpath t))) + (error "Folder %s does not exist" (bmk-mgr-path-to-string pnpath))) + (let ((node (bmk-mgr-node-folder-new (bmk-mgr-path-leaf npath)))) + (if sibling + (bmk-mgr-insert-sibling-at-point node nil) + (bmk-mgr-insert-child-at-point node t)) + (bmk-mgr-goto-node-around node))))) + +(defun bmk-mgr-yank-bookmark (arg) + "Yank last killed bookmark at point." + (interactive "P") + (let ((count (if arg (prefix-numeric-value arg) 1))) + (while (> count 0) + (decf count) + (bmk-mgr-with-current-node-save + (bmk-mgr-add-bookmark nil (bmk-mgr-pop-kill-ring)))))) + +(defun bmk-mgr-delete-node-at-point () + (let ((path (bmk-mgr-get-path-at-point))) + (beginning-of-line) + (hide-subtree) + (let ((a (point)) + (b (save-excursion (outline-next-visible-heading 1) (point)))) + (if bmk-mgr-use-images (remove-images a b)) + (delete-region a b) + (if (eobp) (outline-previous-visible-heading 1))) + (bmk-mgr-delete-node (bmk-mgr-get-root-node-in-buffer) path))) + +(defun bmk-mgr-kill-bookmark (arg) + "Delete bookmark at point." + (interactive "P") + (let ((count (if arg (prefix-numeric-value arg) 1))) + (while (> count 0) + (decf count) + (bmk-mgr-with-current-node-save + (if (not (bmk-mgr-path-parent bmk-path)) + (error "Cannot kill root node")) + (if (and (bmk-mgr-node-folder-p bmk-node) + (not (null (bmk-mgr-node-children bmk-node))) + (not (y-or-n-p + (format + "Killing `%s' and all its contents. Are you sure? " + (bmk-mgr-path-leaf bmk-path))))) + (error "Cancelled")) + (bmk-mgr-push-to-kill-ring bmk-node) + (bmk-mgr-delete-node-at-point))))) + +(defun bmk-mgr-transpose-lines (node path count &optional up) + (beginning-of-line) + (outline-next-visible-heading (if up count (* -1 count))) + (let ((eol (save-excursion (end-of-line) (point)))) + (if bmk-mgr-use-images (remove-images (point) eol)) + (delete-region (point) (1+ eol)) + (outline-next-visible-heading (if up (* -1 count) count)) + (bmk-mgr-print-single-node-at-point node path t))) + +(defun bmk-mgr-goto-node-around (node &optional width) + (let ((width (or width 2))) + (outline-previous-visible-heading (1+ width)) + (do ((max (1+ (* 2 width))) (n 0 (incf n))) + ((or (> n max) (eq node (bmk-mgr-get-node-at-point)))) + (outline-next-visible-heading 1)))) + +(defun bmk-mgr-move-bookmark-up (arg) + "Move bookmark at point one line up." + (interactive "P") + (bmk-mgr-with-current-node-save + (let ((ppath (bmk-mgr-path-parent bmk-path)) + (count (if arg (prefix-numeric-value arg) 1))) + (when (and (> count 0) + (bmk-mgr-node-url-p bmk-node) + (> (length bmk-path) 1)) + (beginning-of-line) + (let ((p (point))) + (outline-previous-visible-heading count) + (if (= (bmk-mgr-outline-level) 1) + (progn + (outline-next-visible-heading 1) + (when (not (equal bmk-node (bmk-mgr-get-node-at-point))) + (goto-char p) + (bmk-mgr-delete-node-at-point) + (goto-char 1) + (bmk-mgr-insert-child-at-point bmk-node t))) + (let* ((current (bmk-mgr-get-node-at-point)) + (iscl (bmk-mgr-node-closed-p current)) + (isurl (bmk-mgr-node-url-p current)) + (cpath (bmk-mgr-get-path-at-point)) + (cppath (bmk-mgr-path-parent cpath))) + (cond + ((and (equal ppath cppath) (or isurl iscl)) + (bmk-mgr-node-swap-children-at-path + (bmk-mgr-get-root-node-in-buffer) ppath bmk-node current) + (bmk-mgr-transpose-lines bmk-node bmk-path count t)) + (t + (outline-next-visible-heading count) + (bmk-mgr-delete-node-at-point) + (outline-previous-visible-heading count) + (if (or isurl iscl (equal cpath ppath)) + (bmk-mgr-insert-sibling-at-point bmk-node + (equal cpath ppath)) + (bmk-mgr-insert-child-at-point bmk-node nil))))))) + (bmk-mgr-goto-node-around bmk-node))))) + +(defun bmk-mgr-move-bookmark-down (arg) + "Move bookmark at point one line down." + (interactive "P") + (bmk-mgr-with-current-node-save + (let ((ppath (bmk-mgr-path-parent bmk-path)) + (count (if arg (prefix-numeric-value arg) 1))) + (when (and (> count 0) + (bmk-mgr-node-url-p bmk-node) + (> (length bmk-path) 1)) + (beginning-of-line) + (let ((p (point))) + (outline-next-visible-heading count) + (if (null (bmk-mgr-get-node-at-point)) + (progn + (outline-previous-visible-heading 1) + (when (not (equal bmk-node (bmk-mgr-get-node-at-point))) + (goto-char p) + (bmk-mgr-delete-node-at-point) + (goto-char 1) + (bmk-mgr-insert-child-at-point bmk-node nil) + (goto-char (point-max)))) + (let* ((current (bmk-mgr-get-node-at-point)) + (iscl (bmk-mgr-node-closed-p current)) + (isurl (bmk-mgr-node-url-p current)) + (cpath (bmk-mgr-get-path-at-point)) + (isout (< (length cpath) (length bmk-path))) + (cppath (bmk-mgr-path-parent cpath))) + (cond + ((and (equal ppath cppath) (or isurl iscl)) + (bmk-mgr-node-swap-children-at-path + (bmk-mgr-get-root-node-in-buffer) ppath bmk-node current) + (bmk-mgr-transpose-lines bmk-node bmk-path count nil)) + (t + (outline-previous-visible-heading count) + (bmk-mgr-delete-node-at-point) + (outline-next-visible-heading (1- count)) + (if (or isurl iscl isout) + (bmk-mgr-insert-sibling-at-point bmk-node isout) + (bmk-mgr-insert-child-at-point bmk-node t))))))) + (bmk-mgr-goto-node-around bmk-node))))) + +(defvar bmk-mgr-import-formats '(("xbel" . bmk-mgr-import-xbel) + ("bmk" . bmk-mgr-import-bmk))) + +(defun bmk-mgr-import-add-formatter (name fun) + (add-to-list 'bmk-mgr-import-formats `(,name . ,fun))) + +(defun bmk-mgr-import () + "Import bookmarks file." + (interactive) + (let* ((formats bmk-mgr-import-formats) + (names (mapcar 'car formats)) + (prompt (concat "Format (" (mapconcat 'identity names ", ") "): ")) + (sel (completing-read prompt formats nil 1)) + (fun (cdr (assoc sel formats)))) + (if fun + (bmk-mgr-with-bookmarks-buffer + (let* ((file (read-file-name "File: " nil nil t)) + (folder (bmk-mgr-ask-path "Import to folder: ")) + (ign (message "Reading %s..." file)) + (node (funcall fun file (bmk-mgr-path-leaf folder)))) + (when node + (message "Importing bookmarks...") + (if (bmk-mgr-find-path-in-buffer folder t) + (let ((parent (bmk-mgr-get-node-at-point)) + (children (bmk-mgr-node-children node))) + (if (bmk-mgr-node-folder-p parent) + (progn + (mapc (lambda (x) + (bmk-mgr-node-add-child parent x)) children) + (bmk-mgr-update-tree-at-point) + (bmk-mgr-refresh-open-close) + (message nil)) + (message "`%s' is not a correct insertion point" + (bmk-mgr-node-name parent)))) + (if (bmk-mgr-find-path-in-buffer (bmk-mgr-path-parent folder) t) + (progn + (bmk-mgr-insert-child-at-point node nil) + (message nil)))))))))) + +(defun bmk-mgr-quit-ask () + "Quit bookmarks buffer, asking for confirmation." + (interactive) + (when (y-or-n-p "Close bookmarks browser? ") (bmk-mgr-quit))) + +(defun bmk-mgr-quit () + "Quit bookmarks buffer." + (interactive) + (with-current-buffer (bmk-mgr-get-bookmark-buffer) + (bmk-mgr-save-current-tree) + (kill-buffer (current-buffer)))) + +;;;; Import/export: + +;;;;; xbel: +(defun bmk-mgr-xbel-get-title (node def) + (let* ((title-node (car (xml-get-children node 'title))) + (title-body (or (and title-node (xml-node-children title-node)) + '()))) + (bmk-mgr-filter-html + (or (and title-body (stringp (car title-body)) (car title-body)) def)))) + +(defun bmk-mgr-xbel-to-bmk (xbel &optional name) + (when (listp xbel) + (case (xml-node-name xbel) + (xbel (bmk-mgr-node-folder-new + (or name "xbel") nil + (mapcar 'bmk-mgr-xbel-to-bmk + (append (xml-get-children xbel 'bookmark) + (xml-get-children xbel 'folder))))) + (folder (bmk-mgr-node-folder-new + (bmk-mgr-xbel-get-title xbel "folder") + (equal (xml-get-attribute xbel 'folded) "yes") + (mapcar 'bmk-mgr-xbel-to-bmk + (append (xml-get-children xbel 'bookmark) + (xml-get-children xbel 'folder))))) + (bookmark + (let* ((href (bmk-mgr-filter-html (xml-get-attribute xbel 'href))) + (title (bmk-mgr-xbel-get-title xbel href))) + (bmk-mgr-node-url-new title href)))))) + +(defun bmk-mgr-import-xbel (file name) + (save-current-buffer + (if (not (file-readable-p file)) (error "Cannot read file")) + (require 'xml) + (message "Reading XBEL file...") + (bmk-mgr-xbel-to-bmk + (car (with-temp-buffer + (insert-buffer (find-file-noselect file)) + (beginning-of-buffer) + (while (re-search-forward "\n" nil t) (replace-match "")) + (beginning-of-buffer) + (while (re-search-forward "\"\"" nil t) (replace-match "\"empty\"")) + (beginning-of-buffer) + (while (re-search-forward "> +<" nil t) (replace-match "><")) + (xml-parse-region (point-min) (point-max)))) + name))) + +;;;;; aux: +(defconst bmk-mgr-html-scp "&#[0-9]+\\;") + +(defun bmk-mgr-filter-html (str) + (let* ((str (substring-no-properties str)) + (result "") + (p0 0) + (p1 (string-match bmk-mgr-html-scp str))) + (while p1 + (let* ((p2 (match-end 0)) + (ch + (char-to-string (bmk-string-to-int (substring + str (+ 2 p1) (1- p2)))))) + (setf result (concat result (substring str p0 p1) ch)) + (setf p0 p2) + (setf p1 (string-match bmk-mgr-html-scp str p2)))) + (concat result (substring str p0)))) + +;;;; Bookmarks buffer: + +;;;;; Functions: +(defun bmk-mgr-print-single-node-at-point (node path &optional insert) + (beginning-of-line) + (let ((kill-whole-line nil) + (inhibit-read-only t) + (depth (* (- (length path) 1) bmk-mgr-indent-width)) + (txt-mark "") + (img)) + (if (bmk-mgr-node-folder-p node) + (if (bmk-mgr-node-open-p node) + (setq txt-mark bmk-mgr-open-mark img bmk-mgr-fopen-img) + (setq txt-mark bmk-mgr-closed-mark img bmk-mgr-fclosed-img)) + (if (> (length (bmk-mgr-node-url node)) 0) + (setq txt-mark bmk-mgr-link-mark img bmk-mgr-url-img))) + (if insert + (progn (newline) + (forward-line -1)) + (kill-line)) + (delete-trailing-whitespace) + (remove-images (point) (save-excursion (end-of-line) (point))) + (insert (make-string depth 32)) + (if bmk-mgr-use-images + (if img ; no image for separators + (progn (put-image img (point)) (insert " "))) + (insert txt-mark)) + (insert (bmk-mgr-node-title node)) + (bmk-mgr-set-path-at-point path) + (bmk-mgr-set-node-at-point node))) + +(defun bmk-mgr-print-tree (tree &optional path level) + (let* ((kill-whole-line nil) + (inhibit-read-only t) + (next-line-add-newlines nil) + (insertp + (lambda (node path) + (not + (and (equal path (bmk-mgr-get-path-at-point)) + (equal (bmk-mgr-node-type node) + (bmk-mgr-node-type (bmk-mgr-get-node-at-point))))))) + (pfun + (lambda (n w) + (beginning-of-line) + (let* ((title (bmk-mgr-node-title n)) + (neww (append w (list title)))) + (bmk-mgr-print-single-node-at-point + n neww (funcall insertp n neww)) + (if (eobp) (newline)) + (next-line 1) + (cons neww t))))) + (bmk-mgr-visit-tree tree pfun path))) + +(defsubst bmk-mgr-update-tree-at-point () + (save-excursion + (bmk-mgr-print-tree (bmk-mgr-get-node-at-point) + (bmk-mgr-path-parent (bmk-mgr-get-path-at-point))))) + +(defsubst bmk-mgr-set-path-at-point (path &optional buffer) + (let ((inhibit-field-text-motion t) + (pos (save-excursion (end-of-line) (point)))) + (save-excursion + (beginning-of-line) + (add-text-properties (point) pos (list 'bmk-mgr-path path) buffer)))) + +(defsubst bmk-mgr-set-node-at-point (node &optional buffer) + (let ((inhibit-field-text-motion t) + (pos (save-excursion (end-of-line) (point)))) + (save-excursion + (beginning-of-line) + (add-text-properties (point) pos (list 'bmk-mgr-node node) buffer) + (when (bmk-mgr-node-url-p node) + (bmk-mgr-beginning) + (add-text-properties (point) (1- pos) + (list 'mouse-face 'bmk-mgr-sel-bookmark-face) + buffer))))) + +(defsubst bmk-mgr-get-path-at-point (&optional buffer) + (get-text-property (point) 'bmk-mgr-path buffer)) + +(defsubst bmk-mgr-get-node-at-point (&optional buffer) + (get-text-property (point) 'bmk-mgr-node buffer)) + +(defun bmk-mgr-get-root-node-in-buffer (&optional buffer) + (save-current-buffer + (if buffer (set-buffer buffer)) + (save-excursion + (goto-char (point-min)) + (bmk-mgr-get-node-at-point)))) + +(defun bmk-mgr-refresh-open-close () + (save-excursion + (let* ((node (bmk-mgr-get-node-at-point)) + (path (bmk-mgr-get-path-at-point)) + (cl (length path))) + (unless (eobp) + (bmk-mgr-unmark-current) + (if (bmk-mgr-node-open-p node) + (progn + (show-children) + (outline-next-visible-heading 1) + (while (> (length (bmk-mgr-get-path-at-point)) cl) + (bmk-mgr-refresh-open-close) + (outline-next-visible-heading 1))) + (hide-subtree)))))) + +(defun bmk-mgr-redraw-node-at-point (&optional path) + (save-excursion + (let ((node (bmk-mgr-get-node-at-point))) + (when node + (show-children) + (bmk-mgr-print-single-node-at-point + node (or path (bmk-mgr-get-path-at-point))) + (beginning-of-line) + (when (bmk-mgr-node-folder-p node) + (if (bmk-mgr-node-open-p node) + (bmk-mgr-refresh-open-close) + (hide-subtree))))))) + +(defun bmk-mgr-find-path-in-buffer (path &optional begin) + (beginning-of-line) + (let ((ip (point)) + (ppos) + (found)) + (if begin (goto-char (point-min))) + (while (not (or found (eobp))) + (let* ((cp (bmk-mgr-get-path-at-point)) + (node (bmk-mgr-get-node-at-point)) + (isf (and node (bmk-mgr-node-folder-p node))) + (isclf (and isf (bmk-mgr-node-closed-p node)))) + (cond + ((equal path cp) + (save-excursion + (mapc (lambda (p) + (goto-char p) + (bmk-mgr-toggle-folder) + (bmk-mgr-unmark-current)) + (reverse (if isclf (cons (point) ppos) ppos)))) + (setf found t)) + ((or (and isf (bmk-mgr-path-contains cp path)) + (and (not isf) (equal (bmk-mgr-path-parent cp) + (bmk-mgr-path-parent path)))) + (if isclf (setf ppos (cons (point) ppos))) + (forward-line 1)) + (t (let ((cl (bmk-mgr-outline-level))) + (forward-line 1) + (while (and (not (eobp)) + (< cl (bmk-mgr-outline-level))) + (forward-line 1))))))) + (if (not found) (goto-char ip) + (save-excursion (goto-char ip) (bmk-mgr-unmark-current))) + (and found (point)))) + +(defun bmk-mgr-insert-sibling-at-point (node before) + (let ((bmk-node (bmk-mgr-get-node-at-point)) + (bmk-path (bmk-mgr-get-path-at-point)) + (pos (point))) + (save-excursion + (if (and node + (bmk-mgr-find-path-in-buffer (bmk-mgr-path-parent bmk-path) t)) + (let* ((path (list (bmk-mgr-path-leaf (bmk-mgr-get-path-at-point)) + (bmk-mgr-path-leaf bmk-path))) + (newtree (bmk-mgr-insert-node (bmk-mgr-get-node-at-point) + node path t before))) + (if newtree + (progn + (goto-char pos) + (when (not before) + (outline-next-visible-heading 1) + (if (eobp) (newline))) + (save-excursion + (bmk-mgr-print-tree node + (bmk-mgr-path-parent bmk-path))) + (bmk-mgr-refresh-open-close)) + (error "Internal error"))) + (error "Path to node not found"))))) + + +(defun bmk-mgr-insert-child-at-point (node before) + (let ((bmk-node (bmk-mgr-get-node-at-point)) + (bmk-path (bmk-mgr-get-path-at-point))) + (if (bmk-mgr-node-url-p bmk-node) + (bmk-mgr-insert-sibling-at-point node before) + (when node + (let* ((path (list (bmk-mgr-path-leaf bmk-path))) + (newtree (bmk-mgr-insert-node bmk-node node path nil before))) + (if newtree + (progn + (if (bmk-mgr-node-closed-p bmk-node) (bmk-mgr-toggle-folder)) + (forward-line 1) + (if (and (not before) + (> (length (bmk-mgr-node-children bmk-node)) 1)) + (condition-case nil + (while (not (eobp)) (outline-forward-same-level 1)) + (error (forward-line 1)))) + (save-excursion + (bmk-mgr-print-tree node bmk-path)) + (bmk-mgr-refresh-open-close)))))))) + +;;;; Bookmark tree datatype: + +;;;;; paths: + +(defsubst bmk-mgr-path-parent (path) (and (listp path) (subseq path 0 -1))) +(defsubst bmk-mgr-path-leaf (path) (and (listp path) (car (subseq path -1)))) +(defsubst bmk-mgr-path-to-string (path) + (mapconcat (lambda (x) (and (stringp x) x)) + (delete-if (lambda (x) (string= x "")) path) "/")) +(defsubst bmk-mgr-string-to-path (path) + (delete-if (lambda (x) (string= x "")) + (split-string path "/"))) +(defsubst bmk-mgr-path-contains (parent child) + (equal parent (subseq child 0 (length parent)))) + +;;;;; constructors: +(defsubst bmk-mgr-node-url-new (title url) (list title url)) +(defsubst bmk-mgr-node-folder-new (name &optional closed children) + (cons name (cons (if closed :closed :open) children))) + +;;;;; accessors: +(defsubst bmk-mgr-node-children (n) (cddr n)) +(defsubst bmk-mgr-node-name (n) (nth 0 n)) +(defsubst bmk-mgr-node-folder-p (n) (and n (symbolp (nth 1 n)))) +(defsubst bmk-mgr-node-open-p (n) (equal :open (nth 1 n))) +(defsubst bmk-mgr-node-closed-p (n) (equal :closed (nth 1 n))) +(defsubst bmk-mgr-node-url-p (n) (stringp (nth 1 n))) +(defsubst bmk-mgr-node-url (n) (and (stringp (nth 1 n)) (nth 1 n))) +(defsubst bmk-mgr-node-title (n) (nth 0 n)) +(defsubst bmk-mgr-node-type (n) (if (bmk-mgr-node-url-p n) 'url 'folder)) + +(defun bmk-mgr-node-child-folders (node &optional path) + (let ((node (or (and (null path) node) + (and node path (bmk-mgr-find-node node path))))) + (when node + (remove-if 'bmk-mgr-node-url-p + (bmk-mgr-node-children node))))) + +(defun bmk-mgr-find-node (tree path) + (let* ((node nil) + (ffun (lambda (n p) + (if (equal (car p) (bmk-mgr-node-name n)) + (if (null (cdr p)) + (progn + (setq node n) + (cons nil nil)) + (cons (cdr p) t)) + (cons nil nil))))) + (bmk-mgr-visit-tree tree ffun path) + node)) + +(defun bmk-mgr-find-node-and-parent (tree path) + (let* ((parent tree) + (node nil) + (fnode (lambda (n p) + (if (equal (car p) (bmk-mgr-node-name n)) + (if (null (cdr p)) + (progn (setq node n) + (cons nil nil)) + (progn (setq parent n) + (cons (cdr p) t))) + (cons nil nil))))) + (bmk-mgr-visit-tree tree fnode path) + (cons (and node parent) node))) + +;;;;; modifiers: +(defsubst bmk-mgr-node-set-name (node name) + (when (stringp name) (setf (car node) name))) + +(defsubst bmk-mgr-node-set-url (node url) + (when (and (bmk-mgr-node-url-p node) (stringp url)) (setf (nth 1 node) url))) + +(defun bmk-mgr-node-toggle-open-closed (node) + (when (bmk-mgr-node-folder-p node) + (setf (nth 1 node) (if (bmk-mgr-node-closed-p node) :open :closed)))) + +(defsubst bmk-mgr-node-close (node) + (when (bmk-mgr-node-folder-p node) (setf (nth 1 node) :closed))) + +(defsubst bmk-mgr-node-close-all (tree) + (when (bmk-mgr-node-folder-p tree) + (bmk-mgr-node-close tree) + (mapc #'bmk-mgr-node-close-all (bmk-mgr-node-children tree)))) + +(defsubst bmk-mgr-node-close-all-children (tree) + (when (bmk-mgr-node-folder-p tree) + (mapc #'bmk-mgr-node-close-all (bmk-mgr-node-children tree)))) + +(defun bmk-mgr-node-set-children (node children) + (when (bmk-mgr-node-folder-p node) + (setf (nthcdr 2 node) children))) + +(defun bmk-mgr-node-swap-children (node c0 c1) + "Swap the positions of C0 and C1, which are children of NODE. + +If C0 is null, C1 gets promoted to the top of the children list. +Conversely, if C1 is null, C0 goes to the tail." + (when (and (bmk-mgr-node-folder-p node) (or c0 c1)) + (let* ((children (bmk-mgr-node-children node)) + (p0 (position c0 children)) + (p1 (position c1 children))) + (when (and children (or p0 p1)) + (if (and c1 p1) (setf (nth (or p0 2) children) c1)) + (if (and c0 p0) + (setf (nth (or p1 (1- (length children))) children) c0)))))) + +(defun bmk-mgr-node-swap-children-at-path (tree path c0 c1) + "Calls `bmk-mgr-node-swap-children' on the node of TREE denoted by +path." + (when tree + (let ((node (bmk-mgr-find-node tree path))) + (if node (bmk-mgr-node-swap-children node c0 c1))))) + +(defun bmk-mgr-node-add-child (tree node &optional prev before) + "Add NODE as a new child of TREE, after (or before, if BEFORE is not +null) node PREV if it exists. + +Returns the updated TREE if successful, nil otherwise." + (when (bmk-mgr-node-folder-p tree) + (let* ((pos (or (position prev tree) (if before 2))) + (insp (if (not pos) (length tree) (if before pos (1+ pos))))) + (setf (nthcdr insp tree) (cons node (nthcdr insp tree))) + tree))) + +(defun bmk-mgr-insert-node (tree node path &optional sibling before) + "Insert the NODE at the given PATH of TREE. + +If SIBLING is not null, the new node will be inserted as a sibling of +the one denoted by PATH. Otherwise, PATH is the path of NODE's parent. +If BEFORE is not null, NODE is inserter before or as the first child +denoted by path. + +Returns the updated parent of NODE if successful, nil otherwise." + (let* ((np (bmk-mgr-find-node-and-parent tree path)) + (parent (and np (car np))) + (found (and np (cdr np)))) + (when found + (if (or sibling (bmk-mgr-node-url-p found)) + (bmk-mgr-node-add-child parent node found before) + (bmk-mgr-node-add-child found node nil before))))) + +(defun bmk-mgr-delete-node (tree path) + (let* ((np (bmk-mgr-find-node-and-parent tree path)) + (parent (and np (car np))) + (found (and np (cdr np))) + (children (and found (bmk-mgr-node-children parent)))) + (when children + (bmk-mgr-node-set-children parent (remove found children))))) + +;;;;; input/output: +(defun bmk-mgr-read-from-file (filename) + (let ((rfname (expand-file-name filename))) + (if (file-readable-p rfname) + (with-temp-buffer + (insert-file-contents rfname) + (goto-char (point-min)) + (let ((sexp (read (current-buffer)))) + (and (bmk-mgr-node-folder-p sexp) sexp))) + '("Bookmarks" :open + ("Emacs bookmark manager" + "http://www.emacswiki.org/cgi-bin/wiki/EmacsBmkMgr"))))) + +(defun bmk-mgr-save-to-file (bmks filename) + (require 'pp) + (when (bmk-mgr-node-folder-p bmks) + (let ((rfname (expand-file-name filename)) + (b (if bmk-mgr-ignore-fold-state (subst :closed :open bmks) bmks))) + (with-temp-buffer + (insert ";;; File automatically generated by Emacs Bookmark Manager" + "\n") + (if bmk-mgr-ignore-fold-state (bmk-mgr-node-toggle-open-closed b)) + (pp b (current-buffer)) + (insert "\n;;; End of " (file-name-nondirectory rfname) "\n") + (write-region (point-min) (point-max) rfname))))) + + +;;;;; aux functions: +(defun bmk-mgr-visit-tree (tree fun arg) + "Visit a bookmarks tree aplying FUN to its nodes." + (when tree + (let ((arg (funcall fun tree arg))) + (when (cdr arg) + (mapc (lambda (n) (bmk-mgr-visit-tree n fun (car arg))) + (bmk-mgr-node-children tree)))))) + + + +(provide 'bmk-mgr) + + + + + +;;; Local stuff: +;;;; Local Variables: ;; +;;;; mode: emacs-lisp ;; +;;;; mode: outline-minor ;; +;;;; outline-regexp: ";;[;\f]+ " ;; +;;;; outline-heading-end-regexp: ":\n" ;; +;;;; indent-tabs-mode: nil ;; +;;;; End: ;; + +;;; bmk-mgr.el ends here diff --git a/attic/bmk/dot-emacs.el b/attic/bmk/dot-emacs.el new file mode 100644 index 0000000..01f00d0 --- /dev/null +++ b/attic/bmk/dot-emacs.el @@ -0,0 +1,42 @@ +;;; sample initialisation file for bmk-mgr + +(if (require 'bmk-mgr nil t) + (progn + (setq bmk-mgr-bookmark-file "~/.emacs.d/bookmarks") + (setq bmk-mgr-inhibit-welcome-message nil) + (setq bmk-mgr-inhibit-minibuffer t) + (setq bmk-mgr-use-own-frame nil) + (setq bmk-mgr-use-images t) + (setq bmk-mgr-ignore-fold-state t) + + (define-key bmk-mgr-mode-map "g" 'bmk-mgr-browse-url) + (define-key bmk-mgr-mode-map "G" 'bmk-mgr-browse-url-alt) + (global-set-key "\C-cB" 'bmk-mgr-show-bookmarks) + (global-set-key "\C-cA" 'bmk-mgr-add-url-at-point) + + ;;;; integration with emacs-w3m (optional) + (when (require 'w3m nil t) + (require 'bmk-mgr-w3m) + (defun browse-bmk-w3m (url &rest ig) + (goto-w3m-buffer) + (w3m-goto-url url t)) + + (defun browse-bmk-new-tab-w3m (url &rest ig) + (goto-w3m-buffer) + (w3m-goto-url-new-session url t)) + + (defun goto-w3m-buffer () (interactive) + (let ((display-buffer-reuse-frames 1) + (pop-up-windows nil) + (buffer (w3m-alive-p))) + (if buffer (pop-to-buffer buffer)))) + + (define-key bmk-mgr-mode-map "w" 'goto-w3m-buffer) + (setq bmk-mgr-browser-function 'browse-bmk-w3m) + (setq bmk-mgr-alt-browser-function 'browse-bmk-new-tab-w3m)) + + ;; integration with w3 + (require 'bmk-mgr-w3))) + + (message "bookmark manager not available")) + diff --git a/attic/bmk/folder-closed.xpm b/attic/bmk/folder-closed.xpm new file mode 100644 index 0000000..ece8a9e --- /dev/null +++ b/attic/bmk/folder-closed.xpm @@ -0,0 +1,31 @@ +/* XPM */ +static char *folder-closed[] = { +/* columns rows colors chars-per-pixel */ +"16 16 9 1", +" c gray100", +". c #FFFFCC", +"X c #CCCCFF", +"o c #C0C0C0", +"O c #9999FF", +"+ c #6666CC", +"@ c #222222", +"# c black", +"$ c None", +/* pixels */ +"$$$$$$$$$$$$$$$$", +"$$$$$$$$$$$$$$$$", +"$$$$$$$$$$$$$$$$", +"$$$$$$$$$$$$$$$$", +"$$++++O$$$$$$$$$", +"$+ XXO.++++++$$$", +"+ XXXXXXXXXXXO$$", +"+ OXOXOXOXOXO+$$", +"+ XOXOXOXOXOX+#$", +"+ OXOXOXOXOXO+#$", +"+ XOXOXOXOXOX+#$", +"+ OXOXOXOXOXO+#$", +"+ XOXOXOXOXOX+#$", +"+XOXOXOXOXOXO+#$", +"++++++++++++++#$", +"$#@@###########$" +}; diff --git a/attic/bmk/folder-open.xpm b/attic/bmk/folder-open.xpm new file mode 100644 index 0000000..f03f65c --- /dev/null +++ b/attic/bmk/folder-open.xpm @@ -0,0 +1,39 @@ +/* XPM */ +static char *folder-open[] = { +/* columns rows colors chars-per-pixel */ +"16 16 17 1", +" c gray100", +". c #FFFFCC", +"X c magenta", +"o c #CCCCFF", +"O c #C0C0C0", +"+ c #9999FF", +"@ c #6666CC", +"# c #222222", +"$ c black", +"% c black", +"& c black", +"* c black", +"= c black", +"- c black", +"; c black", +": c black", +"> c None", +/* pixels */ +">>>>>>>>>>>>>>>>", +">>>>>>>>>>>>>>>>", +">>>>>>>>>>>>>>>>", +">>>>>>>>>>>>>>>>", +">>@@@@>>>>>>>>>>", +">@ @@@@@@@@@>>", +">@ +O.......#+@>", +">@ O.......#+o@>", +">+ .......#+o+@$", +"@@@@@@@@@@#@+o@$", +"@ O$o+@$", +">@+O+O+O+O+O$o@$", +">@O+O+O+O+O+#$@$", +">>@O+O+O+O+O+#$$", +">>@@@@@@@@@@@@@$", +">>>$$$$$$$$$$$$$" +}; diff --git a/attic/bmk/url-alt.xpm b/attic/bmk/url-alt.xpm new file mode 100644 index 0000000..4cb2c14 --- /dev/null +++ b/attic/bmk/url-alt.xpm @@ -0,0 +1,31 @@ +/* XPM */ +static char *document[] = { +/* columns rows colors chars-per-pixel */ +"16 16 9 1", +" c gray100", +". c #CECEBF", +"X c gray80", +"o c #272724", +"O c black", +"+ c black", +"@ c black", +"# c black", +"$ c None", +/* pixels */ +"$oooooooooo$$$$$", +"$o........oO$$$$", +"$o........oXO$$$", +"$o........oooo$$", +"$o...........o$$", +"$o...........o$$", +"$o..o.oo.oo..o$$", +"$o...........o$$", +"$o..oooo.oo..o$$", +"$o...........o$$", +"$o..oo.oo.o..o$$", +"$o...........o$$", +"$o...........o$$", +"$o...........o$$", +"$o...........o$$", +"$ooooooooooooo$$" +}; diff --git a/attic/bmk/url.xpm b/attic/bmk/url.xpm new file mode 100644 index 0000000..60cad93 --- /dev/null +++ b/attic/bmk/url.xpm @@ -0,0 +1,39 @@ +/* XPM */ +static char *article[] = { +/* columns rows colors chars-per-pixel */ +"16 16 17 1", +" c black", +". c #BF0000", +"X c #00BF00", +"o c #BFBF00", +"O c #0000BF", +"+ c #BF00BF", +"@ c #00BFBF", +"# c #C0C0C0", +"$ c #808080", +"% c red", +"& c green", +"* c yellow", +"= c blue", +"- c magenta", +"; c cyan", +": c gray100", +"> c None", +/* pixels */ +"OOOOOOOOOOO>>>>>", +"O:::::::::O>>>>>", +"O: #$ # #:OOO>>>", +"O:$ # $ :O*O>>>", +"O:::::::::O:O$>>", +"O:#$:$$#$:O*O$>>", +"O:::::::::O:O$>>", +"O:$$:$#$$:O*O$>>", +"O:::::::::O:O$>>", +"O:#$:$$$#:O*O$>>", +"O:::::::::O:O$>>", +"OOOOOOOOOOO*O$>>", +">>O:*:*:*:*:O$>>", +">>OOOOOOOOOOO$>>", +">>>>$$$$$$$$$$>>", +">>>>>>>>>>>>>>>>" +}; -- cgit v1.2.3