From 771abb84830678455de4625ac7f082d8100f0ea0 Mon Sep 17 00:00:00 2001 From: jao Date: Tue, 2 Feb 2021 05:16:17 +0000 Subject: libs -> lib/ --- .gitignore | 5 + bmk/bmk-mgr-w3.el | 58 -- bmk/bmk-mgr-w3m.el | 84 -- bmk/bmk-mgr.el | 1478 ----------------------------------- bmk/dot-emacs.el | 42 - bmk/folder-closed.xpm | 31 - bmk/folder-open.xpm | 39 - bmk/url-alt.xpm | 31 - bmk/url.xpm | 39 - doc/jao-counsel-recoll.el | 60 -- doc/jao-doc-view.el | 153 ---- doc/jao-recoll.el | 82 -- eos/jao-afio.el | 212 ----- eos/jao-ednc.el | 148 ---- eos/jao-embark-targets.el | 97 --- eos/jao-minibuffer.el | 138 ---- eos/jao-notify.el | 33 - eos/jao-osd.el | 55 -- eos/jao-sleep.el | 58 -- lib/bmk/bmk-mgr-w3.el | 58 ++ lib/bmk/bmk-mgr-w3m.el | 84 ++ lib/bmk/bmk-mgr.el | 1478 +++++++++++++++++++++++++++++++++++ lib/bmk/dot-emacs.el | 42 + lib/bmk/folder-closed.xpm | 31 + lib/bmk/folder-open.xpm | 39 + lib/bmk/url-alt.xpm | 31 + lib/bmk/url.xpm | 39 + lib/doc/jao-counsel-recoll.el | 60 ++ lib/doc/jao-doc-view.el | 153 ++++ lib/doc/jao-recoll.el | 82 ++ lib/eos/jao-afio.el | 212 +++++ lib/eos/jao-ednc.el | 148 ++++ lib/eos/jao-embark-targets.el | 97 +++ lib/eos/jao-minibuffer.el | 138 ++++ lib/eos/jao-notify.el | 33 + lib/eos/jao-osd.el | 55 ++ lib/eos/jao-sleep.el | 58 ++ lib/media/espotify.org | 627 +++++++++++++++ lib/media/jao-emms-info-track.el | 212 +++++ lib/media/jao-emms-lyrics.el | 41 + lib/media/jao-emms-random-album.el | 118 +++ lib/media/jao-emms.el | 27 + lib/media/jao-lyrics.el | 152 ++++ lib/media/jao-mpris.el | 139 ++++ lib/media/jao-random-album.el | 101 +++ lib/media/leoslyrics.py | 84 ++ lib/media/lyricwiki.rb | 52 ++ lib/net/jao-frm.el | 222 ++++++ lib/net/jao-maildir.el | 155 ++++ lib/net/jao-proton-utils.el | 131 ++++ lib/net/randomsig.el | 724 +++++++++++++++++ lib/net/signel.org | 546 +++++++++++++ lib/org/jao-org-gnus.el | 72 ++ lib/org/jao-org-links.el | 147 ++++ lib/org/jao-org-notes.el | 79 ++ lib/org/jao-org-popup.el | 31 + lib/org/jao-org-utils.el | 43 + lib/prog/jao-compilation.el | 118 +++ lib/prog/jao-sloc.el | 33 + lib/prog/jao-vterm-repl.el | 130 +++ lib/readme.org | 19 + lib/themes/jao-dark-blue-theme.el | 100 +++ lib/themes/jao-dark-forest-theme.el | 131 ++++ lib/themes/jao-dark-theme.el | 77 ++ lib/themes/jao-doom-theme.el | 57 ++ lib/themes/jao-doomish-theme.el | 152 ++++ lib/themes/jao-greenish-theme.el | 114 +++ lib/themes/jao-light-theme.el | 111 +++ lib/themes/jao-mono-dark-theme.el | 98 +++ lib/themes/jao-themes.el | 1099 ++++++++++++++++++++++++++ lib/themes/jao-zenburn-theme.el | 132 ++++ media/espotify.org | 627 --------------- media/jao-emms-info-track.el | 212 ----- media/jao-emms-lyrics.el | 41 - media/jao-emms-random-album.el | 118 --- media/jao-emms.el | 27 - media/jao-lyrics.el | 152 ---- media/jao-mpris.el | 139 ---- media/jao-random-album.el | 101 --- media/leoslyrics.py | 84 -- media/lyricwiki.rb | 52 -- net/jao-frm.el | 222 ------ net/jao-maildir.el | 155 ---- net/jao-proton-utils.el | 131 ---- net/randomsig.el | 724 ----------------- net/signel.org | 546 ------------- org/jao-org-gnus.el | 72 -- org/jao-org-links.el | 147 ---- org/jao-org-notes.el | 79 -- org/jao-org-popup.el | 31 - org/jao-org-utils.el | 43 - prog/jao-compilation.el | 118 --- prog/jao-sloc.el | 33 - prog/jao-vterm-repl.el | 130 --- readme.org | 19 - themes/jao-dark-blue-theme.el | 100 --- themes/jao-dark-forest-theme.el | 131 ---- themes/jao-dark-theme.el | 77 -- themes/jao-doom-theme.el | 57 -- themes/jao-doomish-theme.el | 152 ---- themes/jao-greenish-theme.el | 114 --- themes/jao-light-theme.el | 111 --- themes/jao-mono-dark-theme.el | 98 --- themes/jao-themes.el | 1099 -------------------------- themes/jao-zenburn-theme.el | 132 ---- 105 files changed, 8917 insertions(+), 8912 deletions(-) delete mode 100644 bmk/bmk-mgr-w3.el delete mode 100644 bmk/bmk-mgr-w3m.el delete mode 100644 bmk/bmk-mgr.el delete mode 100644 bmk/dot-emacs.el delete mode 100644 bmk/folder-closed.xpm delete mode 100644 bmk/folder-open.xpm delete mode 100644 bmk/url-alt.xpm delete mode 100644 bmk/url.xpm delete mode 100644 doc/jao-counsel-recoll.el delete mode 100644 doc/jao-doc-view.el delete mode 100644 doc/jao-recoll.el delete mode 100644 eos/jao-afio.el delete mode 100644 eos/jao-ednc.el delete mode 100644 eos/jao-embark-targets.el delete mode 100644 eos/jao-minibuffer.el delete mode 100644 eos/jao-notify.el delete mode 100644 eos/jao-osd.el delete mode 100644 eos/jao-sleep.el create mode 100644 lib/bmk/bmk-mgr-w3.el create mode 100644 lib/bmk/bmk-mgr-w3m.el create mode 100644 lib/bmk/bmk-mgr.el create mode 100644 lib/bmk/dot-emacs.el create mode 100644 lib/bmk/folder-closed.xpm create mode 100644 lib/bmk/folder-open.xpm create mode 100644 lib/bmk/url-alt.xpm create mode 100644 lib/bmk/url.xpm create mode 100644 lib/doc/jao-counsel-recoll.el create mode 100644 lib/doc/jao-doc-view.el create mode 100644 lib/doc/jao-recoll.el create mode 100644 lib/eos/jao-afio.el create mode 100644 lib/eos/jao-ednc.el create mode 100644 lib/eos/jao-embark-targets.el create mode 100644 lib/eos/jao-minibuffer.el create mode 100644 lib/eos/jao-notify.el create mode 100644 lib/eos/jao-osd.el create mode 100644 lib/eos/jao-sleep.el create mode 100644 lib/media/espotify.org create mode 100644 lib/media/jao-emms-info-track.el create mode 100644 lib/media/jao-emms-lyrics.el create mode 100644 lib/media/jao-emms-random-album.el create mode 100644 lib/media/jao-emms.el create mode 100644 lib/media/jao-lyrics.el create mode 100644 lib/media/jao-mpris.el create mode 100644 lib/media/jao-random-album.el create mode 100755 lib/media/leoslyrics.py create mode 100755 lib/media/lyricwiki.rb create mode 100644 lib/net/jao-frm.el create mode 100644 lib/net/jao-maildir.el create mode 100644 lib/net/jao-proton-utils.el create mode 100644 lib/net/randomsig.el create mode 100644 lib/net/signel.org create mode 100644 lib/org/jao-org-gnus.el create mode 100644 lib/org/jao-org-links.el create mode 100644 lib/org/jao-org-notes.el create mode 100644 lib/org/jao-org-popup.el create mode 100644 lib/org/jao-org-utils.el create mode 100644 lib/prog/jao-compilation.el create mode 100644 lib/prog/jao-sloc.el create mode 100644 lib/prog/jao-vterm-repl.el create mode 100644 lib/readme.org create mode 100644 lib/themes/jao-dark-blue-theme.el create mode 100644 lib/themes/jao-dark-forest-theme.el create mode 100644 lib/themes/jao-dark-theme.el create mode 100644 lib/themes/jao-doom-theme.el create mode 100644 lib/themes/jao-doomish-theme.el create mode 100644 lib/themes/jao-greenish-theme.el create mode 100644 lib/themes/jao-light-theme.el create mode 100644 lib/themes/jao-mono-dark-theme.el create mode 100644 lib/themes/jao-themes.el create mode 100644 lib/themes/jao-zenburn-theme.el delete mode 100644 media/espotify.org delete mode 100644 media/jao-emms-info-track.el delete mode 100644 media/jao-emms-lyrics.el delete mode 100644 media/jao-emms-random-album.el delete mode 100644 media/jao-emms.el delete mode 100644 media/jao-lyrics.el delete mode 100644 media/jao-mpris.el delete mode 100644 media/jao-random-album.el delete mode 100755 media/leoslyrics.py delete mode 100755 media/lyricwiki.rb delete mode 100644 net/jao-frm.el delete mode 100644 net/jao-maildir.el delete mode 100644 net/jao-proton-utils.el delete mode 100644 net/randomsig.el delete mode 100644 net/signel.org delete mode 100644 org/jao-org-gnus.el delete mode 100644 org/jao-org-links.el delete mode 100644 org/jao-org-notes.el delete mode 100644 org/jao-org-popup.el delete mode 100644 org/jao-org-utils.el delete mode 100644 prog/jao-compilation.el delete mode 100644 prog/jao-sloc.el delete mode 100644 prog/jao-vterm-repl.el delete mode 100644 readme.org delete mode 100644 themes/jao-dark-blue-theme.el delete mode 100644 themes/jao-dark-forest-theme.el delete mode 100644 themes/jao-dark-theme.el delete mode 100644 themes/jao-doom-theme.el delete mode 100644 themes/jao-doomish-theme.el delete mode 100644 themes/jao-greenish-theme.el delete mode 100644 themes/jao-light-theme.el delete mode 100644 themes/jao-mono-dark-theme.el delete mode 100644 themes/jao-themes.el delete mode 100644 themes/jao-zenburn-theme.el diff --git a/.gitignore b/.gitignore index f39c38f..e848970 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,8 @@ /media/espotify-consult.el /media/espotify-embark.el /media/espotify-counsel.el +/lib/media/espotify-consult.el +/lib/media/espotify-counsel.el +/lib/media/espotify-embark.el +/lib/media/espotify.el +/site diff --git a/bmk/bmk-mgr-w3.el b/bmk/bmk-mgr-w3.el deleted file mode 100644 index c22700f..0000000 --- a/bmk/bmk-mgr-w3.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; 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/bmk/bmk-mgr-w3m.el b/bmk/bmk-mgr-w3m.el deleted file mode 100644 index cc53d41..0000000 --- a/bmk/bmk-mgr-w3m.el +++ /dev/null @@ -1,84 +0,0 @@ -;;; 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/bmk/bmk-mgr.el b/bmk/bmk-mgr.el deleted file mode 100644 index eab1844..0000000 --- a/bmk/bmk-mgr.el +++ /dev/null @@ -1,1478 +0,0 @@ -;;; 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/bmk/dot-emacs.el b/bmk/dot-emacs.el deleted file mode 100644 index 01f00d0..0000000 --- a/bmk/dot-emacs.el +++ /dev/null @@ -1,42 +0,0 @@ -;;; 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/bmk/folder-closed.xpm b/bmk/folder-closed.xpm deleted file mode 100644 index ece8a9e..0000000 --- a/bmk/folder-closed.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* 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/bmk/folder-open.xpm b/bmk/folder-open.xpm deleted file mode 100644 index f03f65c..0000000 --- a/bmk/folder-open.xpm +++ /dev/null @@ -1,39 +0,0 @@ -/* 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/bmk/url-alt.xpm b/bmk/url-alt.xpm deleted file mode 100644 index 4cb2c14..0000000 --- a/bmk/url-alt.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* 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/bmk/url.xpm b/bmk/url.xpm deleted file mode 100644 index 60cad93..0000000 --- a/bmk/url.xpm +++ /dev/null @@ -1,39 +0,0 @@ -/* 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$>>", -">>>>$$$$$$$$$$>>", -">>>>>>>>>>>>>>>>" -}; diff --git a/doc/jao-counsel-recoll.el b/doc/jao-counsel-recoll.el deleted file mode 100644 index adae881..0000000 --- a/doc/jao-counsel-recoll.el +++ /dev/null @@ -1,60 +0,0 @@ -;;; jao-counsel-recoll.el --- counsel and recoll -*- lexical-binding: t; -*- - -;; Copyright (C) 2020 jao - -;; Author: jao -;; Keywords: docs - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; Helpers for using recoll with counsel - -;;; Code: - -(require 'jao-recoll) -(require 'counsel) -(require 'ivy) - -(defvar jao-counsel-recoll--history nil) -(defun jao-counsel-recoll--function (str) - (let ((xs (counsel-recoll-function str))) - (cl-remove-if-not (lambda (x) (string-prefix-p "file://" x)) xs))) - -;;;###autoload -(defun jao-counsel-recoll (&optional initial-input) - (interactive) - (counsel-require-program "recoll") - (ivy-read "recoll: " 'jao-counsel-recoll--function - :initial-input initial-input - :dynamic-collection t - :history 'jao-counsel-recoll--history - :action (lambda (x) - (when (string-match "file://\\(.*\\)\\'" x) - (let ((file-name (match-string 1 x))) - (if (string-match "pdf$" x) - (jao-open-doc file-name) - (find-file file-name))))) - :unwind #'counsel-delete-process - :caller 'jao-counsel-recoll)) - -(defun jao-counsel-recoll--recoll (_s) (jao-recoll ivy-text)) - -(ivy-set-actions 'jao-counsel-recoll - '(("x" jao-counsel-recoll--recoll "List in buffer"))) - - -(provide 'jao-counsel-recoll) -;;; jao-counsel-recoll.el ends here diff --git a/doc/jao-doc-view.el b/doc/jao-doc-view.el deleted file mode 100644 index 5060452..0000000 --- a/doc/jao-doc-view.el +++ /dev/null @@ -1,153 +0,0 @@ -;; jao-doc-view.el -- Remembering visited documents - -;; Copyright (c) 2013, 2015, 2017, 2018, 2019 Jose Antonio Ortega Ruiz - -;; 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 of the License, 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 this program. If not, see . - -;; Author: Jose Antonio Ortega Ruiz -;; Start date: Fri Feb 15, 2013 01:21 - -;;; Comentary: - -;; Some utilities to keep track of visited documents and the last -;; visited page. - -;;; Code: - -(defvar jao-doc-view-bmk-file "~/.emacs.d/doc-view-bmk") -(defvar jao-doc-view-session-file "~/.emacs.d/doc-view-session") -(defvar jao-doc-view--current-bmks nil) - -(defun jao-doc-view--read-file (file) - (let ((buff (find-file-noselect file))) - (ignore-errors - (with-current-buffer buff - (goto-char (point-min))) - (read buff)))) - -(defun jao-doc-view--save-to-file (file value) - (with-current-buffer (find-file-noselect file) - (erase-buffer) - (insert (format "%S" value)) - (save-buffer))) - -(defun jao-doc-view--read-bmks () - (let ((bmks (jao-doc-view--read-file jao-doc-view-bmk-file))) - (if (hash-table-p bmks) bmks (make-hash-table :test 'equal)))) - -(defun jao-doc-view--current-bmks () - (or jao-doc-view--current-bmks - (setq jao-doc-view--current-bmks (jao-doc-view--read-bmks)))) - -(defun jao-doc-view-purge-bmks () - (interactive) - (when jao-doc-view--current-bmks - (maphash (lambda (k v) - (when (or (not k) (= 1 v) (not (file-exists-p k))) - (remhash k jao-doc-view--current-bmks))) - jao-doc-view--current-bmks))) - -(defun jao-doc-view-goto-bmk () - (interactive) - (when (eq major-mode 'pdf-view-mode) - (let* ((bmks (jao-doc-view--current-bmks)) - (fname (buffer-file-name)) - (p (when fname (gethash (expand-file-name fname) bmks 1)))) - (when (and (numberp p) (> p 1)) - (message "Found bookmark at page %d" p) - (ignore-errors (pdf-view-goto-page p)))))) - -(defun jao-doc-view-open (file) - (let* ((buffs (buffer-list)) - (b (catch 'done - (while buffs - (when (string-equal (buffer-file-name (car buffs)) file) - (throw 'done (car buffs))) - (setq buffs (cdr buffs)))))) - (if b - (pop-to-buffer b) - (when (file-exists-p file) (find-file file))))) - -(defun jao-doc-view-session (&optional file) - (let ((file (or file jao-doc-view-session-file))) - (jao-doc-view--read-file file))) - -(defun jao-doc-view-load-session (&optional file) - (interactive) - (let ((docs (jao-doc-view-session file))) - (when (not (listp docs)) (error "Empty session")) - (dolist (d docs) (other-window 1) (jao-doc-view-open d)))) - -(defun jao-doc-view--save-bmks () - (jao-doc-view-purge-bmks) - (jao-doc-view--save-to-file jao-doc-view-bmk-file - (jao-doc-view--current-bmks))) - -(defun jao-doc-view--save-bmk (&rest ignored) - (when (eq major-mode 'pdf-view-mode) - (ignore-errors - (puthash (buffer-file-name) - (max (pdf-view-current-page) 1) - (jao-doc-view--current-bmks))))) - -(defun jao-doc-view-save-session (&optional skip-current) - (interactive) - (let ((docs '()) - (cb (when skip-current (current-buffer)))) - (dolist (b (buffer-list)) - (with-current-buffer b - (when (and (equalp major-mode 'pdf-view-mode) - (not (equalp cb b))) - (jao-doc-view--save-bmk) - (add-to-list 'docs (buffer-file-name))))) - (jao-doc-view--save-bmks) - (when (> (length docs) 0) - (jao-doc-view--save-to-file jao-doc-view-session-file docs)))) - -(defun jao-doc-view--save-session-1 () - (when (equalp major-mode 'pdf-view-mode) - (jao-doc-view-purge-bmks) - (jao-doc-view-save-session t))) - -(defvar jao-doc-session-timer nil) -(defvar jao-doc-session-timer-seconds 60) - -(defun jao-doc-view-stop-session-timer () - (interactive) - (when jao-doc-session-timer - (cancel-timer jao-doc-session-timer) - (setq jao-doc-session-timer nil))) - -(defun jao-doc-view--save-session () - (let ((inhibit-message t) - (message-log-max nil)) - (jao-doc-view-save-session))) - -(defun jao-doc-view-start-session-timer () - (interactive) - (setq jao-doc-session-timer - (run-with-idle-timer jao-doc-session-timer-seconds - t - 'jao-doc-view--save-session))) - -(defun jao-doc-view-install () - (jao-doc-view--current-bmks) - (add-hook 'kill-buffer-hook 'jao-doc-view--save-bmk) - (add-hook 'kill-buffer-hook 'jao-doc-view--save-session-1 t) - (add-hook 'kill-emacs-hook 'jao-doc-view-save-session) - (jao-doc-view-start-session-timer)) - - - -(provide 'jao-doc-view) diff --git a/doc/jao-recoll.el b/doc/jao-recoll.el deleted file mode 100644 index 28a1c1a..0000000 --- a/doc/jao-recoll.el +++ /dev/null @@ -1,82 +0,0 @@ -;; jao-recoll.el -- Displaying recoll queries - -;; Copyright (c) 2017, 2020 Jose Antonio Ortega Ruiz - -;; 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 of the License, 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 this program. If not, see . - -;; Author: Jose Antonio Ortega Ruiz -;; Start date: Wed Nov 01, 2017 18:14 - - -;;; Comentary: - -;; A simple interactive command to perform recoll queries and display -;; its results using org-mode. - -;;; Code: - - -(require 'org) - -(define-derived-mode recoll-mode org-mode "Recoll" - "Simple mode for showing recoll query results" - (read-only-mode 1)) - -(defvar jao-recoll--file-regexp - "\\(\\w+/\\w+\\)\t+\\[\\([^]]+\\)\\]\t+\\[\\([^]]+\\)\\].+") - -(defvar jao-recoll-flags "-A") - -;;;###autoload -(defun jao-recoll (keywords) - "Performs a query using recoll and shows the results in a -buffer using org mode." - (interactive "sRecoll query string: ") - (with-current-buffer (get-buffer-create (format "* Recoll: '%s' *" keywords)) - (read-only-mode -1) - (delete-region (point-min) (point-max)) - (let ((c (format "recoll %s -t %s" - jao-recoll-flags (shell-quote-argument keywords)))) - (shell-command c t)) - (goto-char (point-min)) - (when (looking-at-p "Recoll query:") - (let ((kill-whole-line t)) (kill-line)) - (forward-line 1)) - (open-line 1) - (while (search-forward-regexp jao-recoll--file-regexp nil t) - (replace-match "* [[\\2][\\3]] (\\1)") - (forward-line) - (beginning-of-line) - (let ((kill-whole-line nil)) (kill-line)) - (forward-line) - (let ((p (point))) - (re-search-forward "/ABSTRACT") - (beginning-of-line) - (fill-region p (point)) - (let ((kill-whole-line nil)) (kill-line)))) - (recoll-mode) - (pop-to-buffer (current-buffer)) - (goto-char (point-min)) - (org-cycle '(4)) - (org-next-visible-heading 1))) - -(define-key recoll-mode-map [?n] 'org-next-link) -(define-key recoll-mode-map [?p] 'org-previous-link) -(define-key recoll-mode-map [?q] 'bury-buffer) -(define-key recoll-mode-map [?r] 'jao-recoll) - - - -(provide 'jao-recoll) -;;; jao-recoll.el ends here diff --git a/eos/jao-afio.el b/eos/jao-afio.el deleted file mode 100644 index 10ca474..0000000 --- a/eos/jao-afio.el +++ /dev/null @@ -1,212 +0,0 @@ -;;; jao-afio.el --- workspaces in just one frame -*- lexical-binding: t; -*- - -;; Copyright (C) 2020, 2021 jao - -;; Author: jao -;; Keywords: frames - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Code: - -(defvar jao-afio--configs '(?c ?w ?g ?p ?s)) -(defvar jao-afio--current-config (car jao-afio--configs)) -(defvar jao-afio--locker nil) -(defvar jao-afio-fallback-fun nil) - -(defun jao-afio--check-frame-p () - (assoc 'afio (frame-parameters))) - -(defun jao-afio--init (&optional f) - (interactive) - (when (and (frame-live-p jao-afio--locker) - (not (eql f jao-afio--locker))) - (if jao-afio-fallback-fun - (funcall jao-afio-fallback-fun) - (error "Another frame is using afio"))) - (setq jao-afio--locker f) - (modify-frame-parameters f '((afio . t))) - (setq jao-afio--current-config ?c) - (mapc (lambda (r) (set-register r nil)) jao-afio--configs) - (window-configuration-to-register ?c)) - -(defun jao-afio--steal () - (interactive) - (setq jao-afio--locker nil) - (jao-afio--init (window-frame (get-buffer-window (current-buffer))))) - -(defun jao-afio--check-frame () - (unless (jao-afio--check-frame-p) - (or (when jao-afio-fallback-fun - (funcall jao-afio-fallback-fun) - t) - (when (y-or-n-p "Another frame is using afio. Steal? ") - (jao-afio--steal) - t) - (error "Aborted")))) - -(defun jao-afio--next-frame () - (interactive) - (jao-afio--check-frame) - (let* ((cur (member jao-afio--current-config jao-afio--configs)) - (next (or (cadr cur) (car jao-afio--configs)))) - (jao-afio--goto-frame next))) - -;;;###autoload -(defun jao-afio-open-doc () - (interactive) - (delete-other-windows) - (split-window-right) - (let ((docs (remove-if-not (lambda (b) - (eq (buffer-local-value 'major-mode b) - 'pdf-view-mode)) - (buffer-list)))) - (if (car docs) - (progn (switch-to-buffer (car docs)) - (switch-to-buffer-other-window (or (cadr docs) (car docs)))) - (when (and (jao-doc-view-session) - (y-or-n-p "Load saved session? ")) - (dolist (doc (jao-doc-view-session)) - (when (and (file-exists-p doc) (y-or-n-p (format "Open %s? " doc))) - (find-file doc))))))) - -;;;###autoload -(defun jao-afio-open-w3m () - (interactive) - (if (< (frame-width) 180) - (w3m) - (delete-other-windows) - (split-window-right) - (w3m) - (other-window 1) - (switch-to-buffer "*w3m*") - (ignore-errors (w3m-previous-buffer 2)))) - -;;;###autoload -(defun jao-afio-open-gnus () - (interactive) - (delete-other-windows) - (org-agenda-list) - (calendar) - (find-file (expand-file-name "inbox.org" org-directory)) - (gnus) - (jao-gnus--set-summary-line)) - -;;;###autoload -(defun jao-afio-open-mail (mail-func) - (interactive) - (delete-other-windows) - (funcall mail-func) - (jao-bisect) - (other-window 1) - (find-file (expand-file-name "inbox.org" org-directory)) - (split-window-below (/ (window-height) 3)) - (other-window 1) - (org-agenda-list) - (split-window-below -9) - (other-window 1) - (switch-to-buffer "*Calendar*") - (other-window 1)) - -(defvar jao-afio-switch-hook nil) - -(defun jao-afio--goto-frame (next &optional reset) - (let ((next-cfg (when (not reset) (get-register next)))) - (window-configuration-to-register jao-afio--current-config) - (setq jao-afio--current-config next) - (if next-cfg - (jump-to-register next) - (delete-other-windows) - (cl-case next - (?w (jao-afio-open-w3m)) - (?g (jao-afio-open-gnus)) - (?p (jao-afio-open-doc)) - (?s (delete-other-windows)))) - (run-hooks 'jao-afio-switch-hook))) - -(defun jao-afio--goto-main (&optional reset) - (interactive "P") - (jao-afio--check-frame) - (jao-afio--goto-frame ?c reset)) - -(defun jao-afio--goto-scratch (&optional reset) - (interactive "P") - (jao-afio--check-frame) - (jao-afio--goto-frame ?s reset)) - -(defun jao-afio--goto-gnus (&optional reset) - (interactive "P") - (jao-afio--check-frame) - (jao-afio--goto-frame ?g reset)) - -(defun jao-afio--goto-docs (&optional reset) - (interactive "P") - (jao-afio--check-frame) - (jao-afio--goto-frame ?p reset)) - -(defun jao-afio--goto-w3m (&optional reset) - (interactive "P") - (if (jao-afio--check-frame-p) - (jao-afio--goto-frame ?w reset) - (when (w3m-alive-p) - (pop-to-buffer (w3m-alive-p))))) - -(defun jao-afio--try-init (&optional f) - (ignore-errors (jao-afio--init f)) - t) - -(defun jao-afio--goto-w3m-buffer (buf &rest _) - (jao-afio--goto-w3m) - (jao-first-window) - (switch-to-buffer buf nil t)) - -(defun jao-afio--goto-pdf-buffer (buf &rest _) - (if (jao-afio--check-frame-p) - (progn (jao-afio--goto-docs) - (jao-first-window) - (switch-to-buffer buf nil t)) - (pop-to-buffer buf))) - -(defun jao-afio-goto-scratch (&optional one-win) - (jao-afio--goto-scratch) - (when one-win (delete-other-windows))) - -(defun jao-afio-current-frame () - (cl-case jao-afio--current-config - (?c "Main") - (?s "Scratch") - (?g "Gnus") - (?p "Docs") - (?w "Web"))) - -(defun jao-afio-current-no () - (cl-case jao-afio--current-config - (?c "1") - (?s "0") - (?g "2") - (?p "4") - (?w "3"))) - -;;;###autoload -(defun jao-afio-setup (&optional fallback-fun init-p) - (global-set-key "\C-cf" 'jao-afio--goto-main) - (global-set-key "\C-cg" 'jao-afio--goto-gnus) - (global-set-key "\C-cw" 'jao-afio--goto-w3m) - (global-set-key "\C-cz" 'jao-afio--goto-docs) - (setq jao-afio-fallback-fun fallback-fun) - (add-hook (if init-p 'after-init-hook 'after-make-frame-functions) - 'jao-afio--try-init)) - -(provide 'jao-afio) -;;; jao-afio.el ends here diff --git a/eos/jao-ednc.el b/eos/jao-ednc.el deleted file mode 100644 index 8e55a56..0000000 --- a/eos/jao-ednc.el +++ /dev/null @@ -1,148 +0,0 @@ -;;; jao-ednc.el --- Minibuffer notifications using EDNC -*- lexical-binding: t; -*- - -;; Copyright (C) 2020, 2021 jao - -;; Author: jao -;; Keywords: tools, abbrev - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; Use the ednc package to provide a notification daemon that uses -;; the minibuffer to display them. - -;;; Code: - -(require 'ednc) -(require 'jao-minibuffer) - -(declare-function tracking-add-buffer "tracking") -(declare-function tracking-remove-buffer "tracking") - -(defvar jao-ednc--count-format " {%d} ") -(defvar jao-ednc--notifications ()) -(defvar jao-ednc--handlers ()) - -(defvar jao-ednc-use-minibuffer-notifications nil) -(defvar jao-ednc-use-tracking nil) - -(defface jao-ednc-tracking '((t :inherit warning)) - "Tracking notifications face" - :group 'jao-ednc) - -(defun jao-ednc--last-notification () (car jao-ednc--notifications)) - -(defun jao-ednc--format-last () - (when (jao-ednc--last-notification) - (let ((s (ednc-format-notification (jao-ednc--last-notification) t))) - (replace-regexp-in-string "\n" " " (substring-no-properties s))))) - -(defun jao-ednc--count () - (let ((no (length jao-ednc--notifications))) - (if (> no 0) - (propertize (format jao-ednc--count-format no) 'face 'warning) - ""))) - -(defun jao-ednc-add-handler (app handler) - (add-to-list 'jao-ednc--handlers (cons app handler))) - -(defun jao-ednc-ignore-app (app) - (jao-ednc-add-handler app (lambda (not _) (ednc-dismiss-notification not)))) - -(defun jao-ednc--pop-minibuffer () - (if jao-ednc-use-minibuffer-notifications - (jao-minibuffer-pop-notification) - (jao-minibuffer-refresh))) - -(defun jao-ednc--clean (&optional notification) - (tracking-remove-buffer (get-buffer ednc-log-name)) - (if notification - (remove notification jao-ednc--notifications) - (pop jao-ednc--notifications)) - (jao-ednc--pop-minibuffer)) - -(defun jao-ednc--show-last () - (if jao-ednc-use-minibuffer-notifications - (jao-minibuffer-push-notification '(:eval (jao-ednc--format-last))) - (message "%s" (jao-ednc--format-last)))) - -(defun jao-ednc--default-handler (notification newp) - (if (not newp) - (jao-ednc--clean notification) - (tracking-add-buffer (get-buffer ednc-log-name) '(jao-ednc-tracking)) - (push notification jao-ednc--notifications) - (jao-ednc--show-last))) - -(defun jao-ednc--handler (notification) - (alist-get (ednc-notification-app-name notification) - jao-ednc--handlers - #'jao-ednc--default-handler - nil - 'string=)) - -(defun jao-ednc--on-notify (old new) - (when old (funcall (jao-ednc--handler old) old nil)) - (when new (funcall (jao-ednc--handler new) new t))) - -;;;###autoload -(defun jao-ednc-setup (minibuffer-order) - (setq jao-notify-use-messages-p t) - (with-eval-after-load "tracking" - (when jao-ednc-use-tracking - (add-to-list 'tracking-faces-priorities 'jao-ednc-tracking) - (when (listp tracking-shorten-modes) - (add-to-list 'tracking-shorten-modes 'ednc-view-mode)))) - (when minibuffer-order - (jao-minibuffer-add-variable '(jao-ednc--count) minibuffer-order)) - (add-hook 'ednc-notification-presentation-functions #'jao-ednc--on-notify) - (ednc-mode)) - -;;;###autoload -(defun jao-ednc-pop () - (interactive) - (pop-to-buffer-same-window ednc-log-name)) - -;;;###autoload -(defun jao-ednc-show () - (interactive) - (if (not (jao-ednc--last-notification)) - (jao-ednc-pop) - (jao-ednc--show-last))) - -;;;###autoload -(defun jao-ednc-invoke-last-action () - (interactive) - (if (jao-ednc--last-notification) - (ednc-invoke-action (jao-ednc--last-notification)) - (message "No active notifications")) - (jao-ednc--clean)) - -;;;###autoload -(defun jao-ednc-dismiss () - (interactive) - (when (jao-ednc--last-notification) - (ignore-errors - (with-current-buffer ednc-log-name - (ednc-dismiss-notification (jao-ednc--last-notification))))) - (jao-ednc--clean)) - -;;;###autoload -(defun jao-ednc-dismiss-all () - (interactive) - (while (jao-ednc--last-notification) - (jao-ednc-dismiss))) - -(provide 'jao-ednc) -;;; jao-ednc.el ends here diff --git a/eos/jao-embark-targets.el b/eos/jao-embark-targets.el deleted file mode 100644 index 1887b79..0000000 --- a/eos/jao-embark-targets.el +++ /dev/null @@ -1,97 +0,0 @@ -;;; jao-embark-targets.el --- embark actions -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 jao - -;; Author: jao -;; Keywords: convenience - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; Embark targets and actions - -;;; Code: - -(require 'embark) - -(declare-function w3m-anchor "w3m") -(declare-function org-link-any-re "ol") -(declare-function org-open-link-from-string "ol") -(declare-function org-in-regexp "org-macs") - -(defun jao-embark-targets--org-link () - (when (derived-mode-p 'org-mode) - (when (org-in-regexp org-link-any-re) - (let ((lnk (match-string-no-properties 2))) - (if (string-match-p "http://.+" lnk) - (cons 'url lnk) - (cons 'org-link (match-string-no-properties 0))))))) - -(embark-define-keymap jao-embark-targets-org-link-map - "Actions for org links" - ((kbd "RET") org-open-link-from-string)) - -(add-to-list 'embark-target-finders #'jao-embark-targets--org-link) -(add-to-list 'embark-keymap-alist '(org-link . jao-embark-targets-org-link-map)) - -(defvar jao-embark-targets-video-url-rx - (format "^https?://\\(?:www\\.\\)?%s/.+" - (regexp-opt '("youtu.be" - "youtube.com" - "blip.tv" - "vimeo.com" - "infoq.com") - t)) - "A regular expression matching URLs that point to video streams") - -(defun jao-embark-targets--w3m-anchor () - (when (not (region-active-p)) - (when-let ((url (or (w3m-anchor) w3m-current-url))) - (cons 'url url)))) - -(defun jao-embark-targets--refine-url (url) - (if (string-match-p jao-embark-targets-video-url-rx url) - (cons 'video-url url) - (cons 'url url))) - -(defun jao-embark-targets--play-video (player url) - (interactive "sURL: ") - (let ((cmd (format "%s %s" player (shell-quote-argument url)))) - (start-process-shell-command player nil cmd))) - -(defun jao-embark-targets-mpv (&optional url) - "Play video stream with mpv" - (interactive "sURL: ") - (jao-embark-targets--play-video "mpv" url)) - -(defun jao-embark-targets-vlc (&optional url) - "Play video stream with vlc" - (interactive "sURL: ") - (jao-embark-targets--play-video "vlc" url)) - -(embark-define-keymap jao-embark-targets-video-url-map - "Actions on URLs pointing to remote video streams." - :parent embark-url-map - ("v" jao-embark-targets-vlc) - ("m" jao-embark-targets-mpv)) - -(define-key embark-url-map (kbd "f") #'browse-url-firefox) - -(add-to-list 'embark-target-finders #'jao-embark-targets--w3m-anchor) -(add-to-list 'embark-transformer-alist '(url . jao-embark-targets--refine-url)) -(add-to-list 'embark-keymap-alist '(video-url . jao-embark-targets-video-url-map)) - -(provide 'jao-embark-targets) -;;; jao-embark-targets.el ends here diff --git a/eos/jao-minibuffer.el b/eos/jao-minibuffer.el deleted file mode 100644 index 91662bf..0000000 --- a/eos/jao-minibuffer.el +++ /dev/null @@ -1,138 +0,0 @@ -;;; jao-minibuffer.el --- using the minibuffer to report status -*- lexical-binding: t; -*- - -;; Copyright (C) 2020, 2021 jao - -;; Author: jao -;; Keywords: extensions - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; Simple asynchronous display of information in the minibuffer. - -;;; Code: - -(defvar jao-minibuffer-info ()) -(defvar jao-minibuffer-notification nil) -(defvar jao-minibuffer-align-right-p t) -(defvar jao-minibuffer-right-margin (if window-system 0 1)) -(defvar jao-minibuffer-maximized-frames-p nil) -(defvar jao-minibuffer-frame-width nil) -(defvar jao-minibuffer-notification-timeout 5) -(defvar jao-minibuffer-enabled-p t) - -(defconst jao-minibuffer--name " *Minibuf-0*") - -(defun jao-minibuffer--trim (s w) - (if (<= (string-width (or s "")) w) - (format (format "%%%ds" (if jao-minibuffer-align-right-p w (- w))) s) - (substring s 0 w))) - -(defun jao-minibuffer--current () - (with-current-buffer jao-minibuffer--name - (buffer-substring (point-min) (point-max)))) - -(defun jao-minibuffer--width () - (cond ((numberp jao-minibuffer-frame-width) jao-minibuffer-frame-width) - (jao-minibuffer-maximized-frames-p (frame-width)) - (t (min (frame-width) (window-width (minibuffer-window)))))) - -(defun jao-minibuffer--format-info () - (mapconcat 'string-trim - (seq-filter (lambda (s) (not (string-blank-p s))) - (mapcar 'format-mode-line - (if jao-minibuffer-align-right-p - jao-minibuffer-info - (reverse jao-minibuffer-info)))) - " ")) - -(defun jao-minibuffer--aligned (&optional w currentp) - (let* ((msg (cond (currentp (jao-minibuffer--current)) - (jao-minibuffer-notification - (format-mode-line jao-minibuffer-notification)) - (t (jao-minibuffer--format-info)))) - (msg (if jao-minibuffer-align-right-p - (string-trim msg) - (string-trim-left msg))) - (msg (propertize msg :minibuffer-message t))) - (when (not (string-empty-p msg)) - (let* ((mw (jao-minibuffer--width)) - (w (mod (or w (string-width (or (current-message) ""))) mw)) - (w (- mw w jao-minibuffer-right-margin))) - (if (> w 0) (jao-minibuffer--trim msg w) ""))))) - -(defun jao-minibuffer--set-message (msg) - (if current-minibuffer-command - msg - (let* ((msg (string-trim (replace-regexp-in-string "\n" " " msg))) - (msg (if (string-blank-p msg) msg (concat msg " ")))) - (if jao-minibuffer-align-right-p - (concat msg (jao-minibuffer--aligned (string-width (or msg "")) t)) - (concat (jao-minibuffer--aligned (+ 3 (string-width (or msg ""))) t) - " " msg))))) - -(defun jao-minibuffer--insert (msg) - (with-current-buffer jao-minibuffer--name - (erase-buffer) - (insert msg))) - -;;;###autoload -(defun jao-minibuffer-refresh () - (interactive) - (when jao-minibuffer-enabled-p - (jao-minibuffer--insert (or (jao-minibuffer--aligned) "")))) - -;;;###autoload -(defun jao-minibuffer-add-variable (variable-name &optional order) - (add-to-ordered-list 'jao-minibuffer-info `(:eval ,variable-name) order)) - -(defvar jao-minibuffer--notification-timer nil) - -(defun jao-minibuffer--start-notification-timer (timeout) - (interactive) - (when jao-minibuffer--notification-timer - (cancel-timer jao-minibuffer--notification-timer)) - (setq jao-minibuffer--notification-timer - (run-with-idle-timer (or timeout jao-minibuffer-notification-timeout) - nil - 'jao-minibuffer-pop-notification))) - -;;;###autoload -(defun jao-minibuffer-push-notification (msg &optional timeout) - (setq jao-minibuffer-notification msg) - (jao-minibuffer--start-notification-timer timeout) - (jao-minibuffer-refresh)) - -;;;###autoload -(defun jao-minibuffer-pop-notification () - (interactive) - (setq jao-minibuffer-notification nil) - (jao-minibuffer-refresh)) - -;;;###autoload -(defun jao-minibuffer-toggle () - (interactive) - (setq jao-minibuffer-enabled-p (not jao-minibuffer-enabled-p)) - (if jao-minibuffer-enabled-p - (jao-minibuffer-refresh) - (jao-minibuffer--insert ""))) - -(setq set-message-function #'jao-minibuffer--set-message) -(setq clear-message-function #'jao-minibuffer-refresh) - -(setq resize-mini-windows nil) - -(provide 'jao-minibuffer) -;;; jao-minibuffer.el ends here diff --git a/eos/jao-notify.el b/eos/jao-notify.el deleted file mode 100644 index dc48ca4..0000000 --- a/eos/jao-notify.el +++ /dev/null @@ -1,33 +0,0 @@ -;; jao-notify.el -- Interacting with notification daemon - -;; Copyright (c) 2017, 2019, 2020 Jose Antonio Ortega Ruiz - -;; Author: Jose Antonio Ortega Ruiz -;; Start date: Sun Jan 08, 2017 20:24 - - -;;; Comentary: - -;; Simple notifications using echo or dbus notifications - -;;; Code: - -(defvar jao-notify-use-messages-p nil) -(defvar jao-notify-timeout 5000) - -(declare-function notifications-notify "notifications") - -(defun jao-notify (msg &optional title icon) - (if jao-notify-use-messages-p - (message "%s%s%s" (or title "") (if title ": " "") (or msg "")) - (let* ((args `(:timeout ,jao-notify-timeout)) - (args (append args - (if title `(:title ,title :body ,msg) `(:title ,msg)))) - (args (if (and (stringp icon) (file-exists-p icon)) - (append args `(:app-icon ,(format "%s" icon))) - args))) - (apply 'notifications-notify args)))) - - -(provide 'jao-notify) -;;; jao-notify.el ends here diff --git a/eos/jao-osd.el b/eos/jao-osd.el deleted file mode 100644 index acdc629..0000000 --- a/eos/jao-osd.el +++ /dev/null @@ -1,55 +0,0 @@ -;; candy -(defvar jao-osd-cat-color-fg "black") -(defvar jao-osd-cat-color-bg "white") -(defvar jao-osd-cat-font "Andika Basic 16") -;; (setq jao-osd-cat-font "Inconsolata 20") -(defun jao-osd-cat-font (&optional font) - (or font jao-osd-cat-font)) - -(defun jao-osd-process-args (&optional font fg bg) - `("-n" ,(jao-osd-cat-font font) - "-R" ,(or bg jao-osd-cat-color-fg) "-B" ,(or fg jao-osd-cat-color-bg) - "-b" "200" "-r" "255" - "-e" "0" "-t" "2" "-d" "10" "-p" "0" "-x" "10" "-y" "10" "-u" "5000")) - -(setq jao-osd-processes (make-hash-table)) - -(defsubst jao-osd--delete-process (name) - (remhash name jao-osd-processes)) - -(defun jao-osd-process (name &optional font color) - (let ((proc (gethash name jao-osd-processes))) - (or (and proc (eq (process-status proc) 'run) proc) - (puthash name - (apply 'start-process - `("notifications" - ,(format "*notifications/%s*" name) - "aosd_cat" - ,@(jao-osd-process-args))) - jao-osd-processes)))) - -(defun jao-osd-cat (name lines) - (let* ((proc (jao-osd-process name)) - (lines (if (listp lines) lines (list lines))) - (trail (- 5 (length lines)))) - (when proc - (dolist (line lines) - (send-string proc (format "%s\n" line)))))) - ; (when (> trail 0) (send-string proc (make-string trail ?\n)))))) - -(defun jao-osd--names () - (let (names) - (maphash (lambda (n k) (push n names)) jao-osd-processes) - (reverse names))) - -(defun jao-osd-kill (name) - (let ((proc (gethash name jao-osd-processes))) - (when (processp proc) - (kill-process proc)))) - -(defun jao-osd-kill-notifiers () - (interactive) - (maphash (lambda (n p) (ignore-errors (kill-process p))) jao-osd-processes) - (clrhash jao-osd-processes)) - -(provide 'jao-osd) diff --git a/eos/jao-sleep.el b/eos/jao-sleep.el deleted file mode 100644 index 93da0e7..0000000 --- a/eos/jao-sleep.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; jao-sleep.el --- Actions upon sleep/awake -*- lexical-binding: t; -*- - -;; Copyright (C) 2020 jao - -;; Author: jao -;; Keywords: hardware - -;; This program 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 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Code: - -(require 'dbus) - -(defvar jao-sleep-sleep-functions nil) -(defvar jao-sleep-awake-functions nil) - -(defvar jao-sleep--dbus-registration-object nil) - -(defun jao-sleep--dbus-sleep-handler (sleep-start) - (condition-case nil - (if sleep-start - (progn (message "Running on sleep functions") - (run-hooks 'jao-sleep-sleep-functions)) - (message "Running on awake functions") - (run-hooks 'jao-sleep-awake-functions)) - (error (message "There was an error running %s" sleep-start)))) - -;;;###autoload -(defun jao-sleep-dbus-register (&optional session-dbus) - "Register actions to take on sleep and on awake, using the system D-BUS." - (when (featurep 'dbusbind) - (setq jao-sleep--dbus-sleep-registration-object - (dbus-register-signal (if session-dbus :session :system) - "org.freedesktop.login1" - "/org/freedesktop/login1" - "org.freedesktop.login1.Manager" - "PrepareForSleep" - #'jao-sleep--dbus-sleep-handler)))) - -;;;###autoload -(defun jao-sleep-dbus-unregister () - (condition-case nil - (dbus-unregister-object jao-sleep--dbus-sleep-registration-object) - (wrong-type-argument nil))) - -(provide 'jao-sleep) -;;; jao-sleep.el ends here diff --git a/lib/bmk/bmk-mgr-w3.el b/lib/bmk/bmk-mgr-w3.el new file mode 100644 index 0000000..c22700f --- /dev/null +++ b/lib/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/lib/bmk/bmk-mgr-w3m.el b/lib/bmk/bmk-mgr-w3m.el new file mode 100644 index 0000000..cc53d41 --- /dev/null +++ b/lib/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/lib/bmk/bmk-mgr.el b/lib/bmk/bmk-mgr.el new file mode 100644 index 0000000..eab1844 --- /dev/null +++ b/lib/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/lib/bmk/dot-emacs.el b/lib/bmk/dot-emacs.el new file mode 100644 index 0000000..01f00d0 --- /dev/null +++ b/lib/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/lib/bmk/folder-closed.xpm b/lib/bmk/folder-closed.xpm new file mode 100644 index 0000000..ece8a9e --- /dev/null +++ b/lib/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/lib/bmk/folder-open.xpm b/lib/bmk/folder-open.xpm new file mode 100644 index 0000000..f03f65c --- /dev/null +++ b/lib/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/lib/bmk/url-alt.xpm b/lib/bmk/url-alt.xpm new file mode 100644 index 0000000..4cb2c14 --- /dev/null +++ b/lib/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/lib/bmk/url.xpm b/lib/bmk/url.xpm new file mode 100644 index 0000000..60cad93 --- /dev/null +++ b/lib/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$>>", +">>>>$$$$$$$$$$>>", +">>>>>>>>>>>>>>>>" +}; diff --git a/lib/doc/jao-counsel-recoll.el b/lib/doc/jao-counsel-recoll.el new file mode 100644 index 0000000..adae881 --- /dev/null +++ b/lib/doc/jao-counsel-recoll.el @@ -0,0 +1,60 @@ +;;; jao-counsel-recoll.el --- counsel and recoll -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 jao + +;; Author: jao +;; Keywords: docs + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Helpers for using recoll with counsel + +;;; Code: + +(require 'jao-recoll) +(require 'counsel) +(require 'ivy) + +(defvar jao-counsel-recoll--history nil) +(defun jao-counsel-recoll--function (str) + (let ((xs (counsel-recoll-function str))) + (cl-remove-if-not (lambda (x) (string-prefix-p "file://" x)) xs))) + +;;;###autoload +(defun jao-counsel-recoll (&optional initial-input) + (interactive) + (counsel-require-program "recoll") + (ivy-read "recoll: " 'jao-counsel-recoll--function + :initial-input initial-input + :dynamic-collection t + :history 'jao-counsel-recoll--history + :action (lambda (x) + (when (string-match "file://\\(.*\\)\\'" x) + (let ((file-name (match-string 1 x))) + (if (string-match "pdf$" x) + (jao-open-doc file-name) + (find-file file-name))))) + :unwind #'counsel-delete-process + :caller 'jao-counsel-recoll)) + +(defun jao-counsel-recoll--recoll (_s) (jao-recoll ivy-text)) + +(ivy-set-actions 'jao-counsel-recoll + '(("x" jao-counsel-recoll--recoll "List in buffer"))) + + +(provide 'jao-counsel-recoll) +;;; jao-counsel-recoll.el ends here diff --git a/lib/doc/jao-doc-view.el b/lib/doc/jao-doc-view.el new file mode 100644 index 0000000..5060452 --- /dev/null +++ b/lib/doc/jao-doc-view.el @@ -0,0 +1,153 @@ +;; jao-doc-view.el -- Remembering visited documents + +;; Copyright (c) 2013, 2015, 2017, 2018, 2019 Jose Antonio Ortega Ruiz + +;; 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 of the License, 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 this program. If not, see . + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Fri Feb 15, 2013 01:21 + +;;; Comentary: + +;; Some utilities to keep track of visited documents and the last +;; visited page. + +;;; Code: + +(defvar jao-doc-view-bmk-file "~/.emacs.d/doc-view-bmk") +(defvar jao-doc-view-session-file "~/.emacs.d/doc-view-session") +(defvar jao-doc-view--current-bmks nil) + +(defun jao-doc-view--read-file (file) + (let ((buff (find-file-noselect file))) + (ignore-errors + (with-current-buffer buff + (goto-char (point-min))) + (read buff)))) + +(defun jao-doc-view--save-to-file (file value) + (with-current-buffer (find-file-noselect file) + (erase-buffer) + (insert (format "%S" value)) + (save-buffer))) + +(defun jao-doc-view--read-bmks () + (let ((bmks (jao-doc-view--read-file jao-doc-view-bmk-file))) + (if (hash-table-p bmks) bmks (make-hash-table :test 'equal)))) + +(defun jao-doc-view--current-bmks () + (or jao-doc-view--current-bmks + (setq jao-doc-view--current-bmks (jao-doc-view--read-bmks)))) + +(defun jao-doc-view-purge-bmks () + (interactive) + (when jao-doc-view--current-bmks + (maphash (lambda (k v) + (when (or (not k) (= 1 v) (not (file-exists-p k))) + (remhash k jao-doc-view--current-bmks))) + jao-doc-view--current-bmks))) + +(defun jao-doc-view-goto-bmk () + (interactive) + (when (eq major-mode 'pdf-view-mode) + (let* ((bmks (jao-doc-view--current-bmks)) + (fname (buffer-file-name)) + (p (when fname (gethash (expand-file-name fname) bmks 1)))) + (when (and (numberp p) (> p 1)) + (message "Found bookmark at page %d" p) + (ignore-errors (pdf-view-goto-page p)))))) + +(defun jao-doc-view-open (file) + (let* ((buffs (buffer-list)) + (b (catch 'done + (while buffs + (when (string-equal (buffer-file-name (car buffs)) file) + (throw 'done (car buffs))) + (setq buffs (cdr buffs)))))) + (if b + (pop-to-buffer b) + (when (file-exists-p file) (find-file file))))) + +(defun jao-doc-view-session (&optional file) + (let ((file (or file jao-doc-view-session-file))) + (jao-doc-view--read-file file))) + +(defun jao-doc-view-load-session (&optional file) + (interactive) + (let ((docs (jao-doc-view-session file))) + (when (not (listp docs)) (error "Empty session")) + (dolist (d docs) (other-window 1) (jao-doc-view-open d)))) + +(defun jao-doc-view--save-bmks () + (jao-doc-view-purge-bmks) + (jao-doc-view--save-to-file jao-doc-view-bmk-file + (jao-doc-view--current-bmks))) + +(defun jao-doc-view--save-bmk (&rest ignored) + (when (eq major-mode 'pdf-view-mode) + (ignore-errors + (puthash (buffer-file-name) + (max (pdf-view-current-page) 1) + (jao-doc-view--current-bmks))))) + +(defun jao-doc-view-save-session (&optional skip-current) + (interactive) + (let ((docs '()) + (cb (when skip-current (current-buffer)))) + (dolist (b (buffer-list)) + (with-current-buffer b + (when (and (equalp major-mode 'pdf-view-mode) + (not (equalp cb b))) + (jao-doc-view--save-bmk) + (add-to-list 'docs (buffer-file-name))))) + (jao-doc-view--save-bmks) + (when (> (length docs) 0) + (jao-doc-view--save-to-file jao-doc-view-session-file docs)))) + +(defun jao-doc-view--save-session-1 () + (when (equalp major-mode 'pdf-view-mode) + (jao-doc-view-purge-bmks) + (jao-doc-view-save-session t))) + +(defvar jao-doc-session-timer nil) +(defvar jao-doc-session-timer-seconds 60) + +(defun jao-doc-view-stop-session-timer () + (interactive) + (when jao-doc-session-timer + (cancel-timer jao-doc-session-timer) + (setq jao-doc-session-timer nil))) + +(defun jao-doc-view--save-session () + (let ((inhibit-message t) + (message-log-max nil)) + (jao-doc-view-save-session))) + +(defun jao-doc-view-start-session-timer () + (interactive) + (setq jao-doc-session-timer + (run-with-idle-timer jao-doc-session-timer-seconds + t + 'jao-doc-view--save-session))) + +(defun jao-doc-view-install () + (jao-doc-view--current-bmks) + (add-hook 'kill-buffer-hook 'jao-doc-view--save-bmk) + (add-hook 'kill-buffer-hook 'jao-doc-view--save-session-1 t) + (add-hook 'kill-emacs-hook 'jao-doc-view-save-session) + (jao-doc-view-start-session-timer)) + + + +(provide 'jao-doc-view) diff --git a/lib/doc/jao-recoll.el b/lib/doc/jao-recoll.el new file mode 100644 index 0000000..28a1c1a --- /dev/null +++ b/lib/doc/jao-recoll.el @@ -0,0 +1,82 @@ +;; jao-recoll.el -- Displaying recoll queries + +;; Copyright (c) 2017, 2020 Jose Antonio Ortega Ruiz + +;; 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 of the License, 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 this program. If not, see . + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Wed Nov 01, 2017 18:14 + + +;;; Comentary: + +;; A simple interactive command to perform recoll queries and display +;; its results using org-mode. + +;;; Code: + + +(require 'org) + +(define-derived-mode recoll-mode org-mode "Recoll" + "Simple mode for showing recoll query results" + (read-only-mode 1)) + +(defvar jao-recoll--file-regexp + "\\(\\w+/\\w+\\)\t+\\[\\([^]]+\\)\\]\t+\\[\\([^]]+\\)\\].+") + +(defvar jao-recoll-flags "-A") + +;;;###autoload +(defun jao-recoll (keywords) + "Performs a query using recoll and shows the results in a +buffer using org mode." + (interactive "sRecoll query string: ") + (with-current-buffer (get-buffer-create (format "* Recoll: '%s' *" keywords)) + (read-only-mode -1) + (delete-region (point-min) (point-max)) + (let ((c (format "recoll %s -t %s" + jao-recoll-flags (shell-quote-argument keywords)))) + (shell-command c t)) + (goto-char (point-min)) + (when (looking-at-p "Recoll query:") + (let ((kill-whole-line t)) (kill-line)) + (forward-line 1)) + (open-line 1) + (while (search-forward-regexp jao-recoll--file-regexp nil t) + (replace-match "* [[\\2][\\3]] (\\1)") + (forward-line) + (beginning-of-line) + (let ((kill-whole-line nil)) (kill-line)) + (forward-line) + (let ((p (point))) + (re-search-forward "/ABSTRACT") + (beginning-of-line) + (fill-region p (point)) + (let ((kill-whole-line nil)) (kill-line)))) + (recoll-mode) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (org-cycle '(4)) + (org-next-visible-heading 1))) + +(define-key recoll-mode-map [?n] 'org-next-link) +(define-key recoll-mode-map [?p] 'org-previous-link) +(define-key recoll-mode-map [?q] 'bury-buffer) +(define-key recoll-mode-map [?r] 'jao-recoll) + + + +(provide 'jao-recoll) +;;; jao-recoll.el ends here diff --git a/lib/eos/jao-afio.el b/lib/eos/jao-afio.el new file mode 100644 index 0000000..10ca474 --- /dev/null +++ b/lib/eos/jao-afio.el @@ -0,0 +1,212 @@ +;;; jao-afio.el --- workspaces in just one frame -*- lexical-binding: t; -*- + +;; Copyright (C) 2020, 2021 jao + +;; Author: jao +;; Keywords: frames + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Code: + +(defvar jao-afio--configs '(?c ?w ?g ?p ?s)) +(defvar jao-afio--current-config (car jao-afio--configs)) +(defvar jao-afio--locker nil) +(defvar jao-afio-fallback-fun nil) + +(defun jao-afio--check-frame-p () + (assoc 'afio (frame-parameters))) + +(defun jao-afio--init (&optional f) + (interactive) + (when (and (frame-live-p jao-afio--locker) + (not (eql f jao-afio--locker))) + (if jao-afio-fallback-fun + (funcall jao-afio-fallback-fun) + (error "Another frame is using afio"))) + (setq jao-afio--locker f) + (modify-frame-parameters f '((afio . t))) + (setq jao-afio--current-config ?c) + (mapc (lambda (r) (set-register r nil)) jao-afio--configs) + (window-configuration-to-register ?c)) + +(defun jao-afio--steal () + (interactive) + (setq jao-afio--locker nil) + (jao-afio--init (window-frame (get-buffer-window (current-buffer))))) + +(defun jao-afio--check-frame () + (unless (jao-afio--check-frame-p) + (or (when jao-afio-fallback-fun + (funcall jao-afio-fallback-fun) + t) + (when (y-or-n-p "Another frame is using afio. Steal? ") + (jao-afio--steal) + t) + (error "Aborted")))) + +(defun jao-afio--next-frame () + (interactive) + (jao-afio--check-frame) + (let* ((cur (member jao-afio--current-config jao-afio--configs)) + (next (or (cadr cur) (car jao-afio--configs)))) + (jao-afio--goto-frame next))) + +;;;###autoload +(defun jao-afio-open-doc () + (interactive) + (delete-other-windows) + (split-window-right) + (let ((docs (remove-if-not (lambda (b) + (eq (buffer-local-value 'major-mode b) + 'pdf-view-mode)) + (buffer-list)))) + (if (car docs) + (progn (switch-to-buffer (car docs)) + (switch-to-buffer-other-window (or (cadr docs) (car docs)))) + (when (and (jao-doc-view-session) + (y-or-n-p "Load saved session? ")) + (dolist (doc (jao-doc-view-session)) + (when (and (file-exists-p doc) (y-or-n-p (format "Open %s? " doc))) + (find-file doc))))))) + +;;;###autoload +(defun jao-afio-open-w3m () + (interactive) + (if (< (frame-width) 180) + (w3m) + (delete-other-windows) + (split-window-right) + (w3m) + (other-window 1) + (switch-to-buffer "*w3m*") + (ignore-errors (w3m-previous-buffer 2)))) + +;;;###autoload +(defun jao-afio-open-gnus () + (interactive) + (delete-other-windows) + (org-agenda-list) + (calendar) + (find-file (expand-file-name "inbox.org" org-directory)) + (gnus) + (jao-gnus--set-summary-line)) + +;;;###autoload +(defun jao-afio-open-mail (mail-func) + (interactive) + (delete-other-windows) + (funcall mail-func) + (jao-bisect) + (other-window 1) + (find-file (expand-file-name "inbox.org" org-directory)) + (split-window-below (/ (window-height) 3)) + (other-window 1) + (org-agenda-list) + (split-window-below -9) + (other-window 1) + (switch-to-buffer "*Calendar*") + (other-window 1)) + +(defvar jao-afio-switch-hook nil) + +(defun jao-afio--goto-frame (next &optional reset) + (let ((next-cfg (when (not reset) (get-register next)))) + (window-configuration-to-register jao-afio--current-config) + (setq jao-afio--current-config next) + (if next-cfg + (jump-to-register next) + (delete-other-windows) + (cl-case next + (?w (jao-afio-open-w3m)) + (?g (jao-afio-open-gnus)) + (?p (jao-afio-open-doc)) + (?s (delete-other-windows)))) + (run-hooks 'jao-afio-switch-hook))) + +(defun jao-afio--goto-main (&optional reset) + (interactive "P") + (jao-afio--check-frame) + (jao-afio--goto-frame ?c reset)) + +(defun jao-afio--goto-scratch (&optional reset) + (interactive "P") + (jao-afio--check-frame) + (jao-afio--goto-frame ?s reset)) + +(defun jao-afio--goto-gnus (&optional reset) + (interactive "P") + (jao-afio--check-frame) + (jao-afio--goto-frame ?g reset)) + +(defun jao-afio--goto-docs (&optional reset) + (interactive "P") + (jao-afio--check-frame) + (jao-afio--goto-frame ?p reset)) + +(defun jao-afio--goto-w3m (&optional reset) + (interactive "P") + (if (jao-afio--check-frame-p) + (jao-afio--goto-frame ?w reset) + (when (w3m-alive-p) + (pop-to-buffer (w3m-alive-p))))) + +(defun jao-afio--try-init (&optional f) + (ignore-errors (jao-afio--init f)) + t) + +(defun jao-afio--goto-w3m-buffer (buf &rest _) + (jao-afio--goto-w3m) + (jao-first-window) + (switch-to-buffer buf nil t)) + +(defun jao-afio--goto-pdf-buffer (buf &rest _) + (if (jao-afio--check-frame-p) + (progn (jao-afio--goto-docs) + (jao-first-window) + (switch-to-buffer buf nil t)) + (pop-to-buffer buf))) + +(defun jao-afio-goto-scratch (&optional one-win) + (jao-afio--goto-scratch) + (when one-win (delete-other-windows))) + +(defun jao-afio-current-frame () + (cl-case jao-afio--current-config + (?c "Main") + (?s "Scratch") + (?g "Gnus") + (?p "Docs") + (?w "Web"))) + +(defun jao-afio-current-no () + (cl-case jao-afio--current-config + (?c "1") + (?s "0") + (?g "2") + (?p "4") + (?w "3"))) + +;;;###autoload +(defun jao-afio-setup (&optional fallback-fun init-p) + (global-set-key "\C-cf" 'jao-afio--goto-main) + (global-set-key "\C-cg" 'jao-afio--goto-gnus) + (global-set-key "\C-cw" 'jao-afio--goto-w3m) + (global-set-key "\C-cz" 'jao-afio--goto-docs) + (setq jao-afio-fallback-fun fallback-fun) + (add-hook (if init-p 'after-init-hook 'after-make-frame-functions) + 'jao-afio--try-init)) + +(provide 'jao-afio) +;;; jao-afio.el ends here diff --git a/lib/eos/jao-ednc.el b/lib/eos/jao-ednc.el new file mode 100644 index 0000000..8e55a56 --- /dev/null +++ b/lib/eos/jao-ednc.el @@ -0,0 +1,148 @@ +;;; jao-ednc.el --- Minibuffer notifications using EDNC -*- lexical-binding: t; -*- + +;; Copyright (C) 2020, 2021 jao + +;; Author: jao +;; Keywords: tools, abbrev + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Use the ednc package to provide a notification daemon that uses +;; the minibuffer to display them. + +;;; Code: + +(require 'ednc) +(require 'jao-minibuffer) + +(declare-function tracking-add-buffer "tracking") +(declare-function tracking-remove-buffer "tracking") + +(defvar jao-ednc--count-format " {%d} ") +(defvar jao-ednc--notifications ()) +(defvar jao-ednc--handlers ()) + +(defvar jao-ednc-use-minibuffer-notifications nil) +(defvar jao-ednc-use-tracking nil) + +(defface jao-ednc-tracking '((t :inherit warning)) + "Tracking notifications face" + :group 'jao-ednc) + +(defun jao-ednc--last-notification () (car jao-ednc--notifications)) + +(defun jao-ednc--format-last () + (when (jao-ednc--last-notification) + (let ((s (ednc-format-notification (jao-ednc--last-notification) t))) + (replace-regexp-in-string "\n" " " (substring-no-properties s))))) + +(defun jao-ednc--count () + (let ((no (length jao-ednc--notifications))) + (if (> no 0) + (propertize (format jao-ednc--count-format no) 'face 'warning) + ""))) + +(defun jao-ednc-add-handler (app handler) + (add-to-list 'jao-ednc--handlers (cons app handler))) + +(defun jao-ednc-ignore-app (app) + (jao-ednc-add-handler app (lambda (not _) (ednc-dismiss-notification not)))) + +(defun jao-ednc--pop-minibuffer () + (if jao-ednc-use-minibuffer-notifications + (jao-minibuffer-pop-notification) + (jao-minibuffer-refresh))) + +(defun jao-ednc--clean (&optional notification) + (tracking-remove-buffer (get-buffer ednc-log-name)) + (if notification + (remove notification jao-ednc--notifications) + (pop jao-ednc--notifications)) + (jao-ednc--pop-minibuffer)) + +(defun jao-ednc--show-last () + (if jao-ednc-use-minibuffer-notifications + (jao-minibuffer-push-notification '(:eval (jao-ednc--format-last))) + (message "%s" (jao-ednc--format-last)))) + +(defun jao-ednc--default-handler (notification newp) + (if (not newp) + (jao-ednc--clean notification) + (tracking-add-buffer (get-buffer ednc-log-name) '(jao-ednc-tracking)) + (push notification jao-ednc--notifications) + (jao-ednc--show-last))) + +(defun jao-ednc--handler (notification) + (alist-get (ednc-notification-app-name notification) + jao-ednc--handlers + #'jao-ednc--default-handler + nil + 'string=)) + +(defun jao-ednc--on-notify (old new) + (when old (funcall (jao-ednc--handler old) old nil)) + (when new (funcall (jao-ednc--handler new) new t))) + +;;;###autoload +(defun jao-ednc-setup (minibuffer-order) + (setq jao-notify-use-messages-p t) + (with-eval-after-load "tracking" + (when jao-ednc-use-tracking + (add-to-list 'tracking-faces-priorities 'jao-ednc-tracking) + (when (listp tracking-shorten-modes) + (add-to-list 'tracking-shorten-modes 'ednc-view-mode)))) + (when minibuffer-order + (jao-minibuffer-add-variable '(jao-ednc--count) minibuffer-order)) + (add-hook 'ednc-notification-presentation-functions #'jao-ednc--on-notify) + (ednc-mode)) + +;;;###autoload +(defun jao-ednc-pop () + (interactive) + (pop-to-buffer-same-window ednc-log-name)) + +;;;###autoload +(defun jao-ednc-show () + (interactive) + (if (not (jao-ednc--last-notification)) + (jao-ednc-pop) + (jao-ednc--show-last))) + +;;;###autoload +(defun jao-ednc-invoke-last-action () + (interactive) + (if (jao-ednc--last-notification) + (ednc-invoke-action (jao-ednc--last-notification)) + (message "No active notifications")) + (jao-ednc--clean)) + +;;;###autoload +(defun jao-ednc-dismiss () + (interactive) + (when (jao-ednc--last-notification) + (ignore-errors + (with-current-buffer ednc-log-name + (ednc-dismiss-notification (jao-ednc--last-notification))))) + (jao-ednc--clean)) + +;;;###autoload +(defun jao-ednc-dismiss-all () + (interactive) + (while (jao-ednc--last-notification) + (jao-ednc-dismiss))) + +(provide 'jao-ednc) +;;; jao-ednc.el ends here diff --git a/lib/eos/jao-embark-targets.el b/lib/eos/jao-embark-targets.el new file mode 100644 index 0000000..1887b79 --- /dev/null +++ b/lib/eos/jao-embark-targets.el @@ -0,0 +1,97 @@ +;;; jao-embark-targets.el --- embark actions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 jao + +;; Author: jao +;; Keywords: convenience + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Embark targets and actions + +;;; Code: + +(require 'embark) + +(declare-function w3m-anchor "w3m") +(declare-function org-link-any-re "ol") +(declare-function org-open-link-from-string "ol") +(declare-function org-in-regexp "org-macs") + +(defun jao-embark-targets--org-link () + (when (derived-mode-p 'org-mode) + (when (org-in-regexp org-link-any-re) + (let ((lnk (match-string-no-properties 2))) + (if (string-match-p "http://.+" lnk) + (cons 'url lnk) + (cons 'org-link (match-string-no-properties 0))))))) + +(embark-define-keymap jao-embark-targets-org-link-map + "Actions for org links" + ((kbd "RET") org-open-link-from-string)) + +(add-to-list 'embark-target-finders #'jao-embark-targets--org-link) +(add-to-list 'embark-keymap-alist '(org-link . jao-embark-targets-org-link-map)) + +(defvar jao-embark-targets-video-url-rx + (format "^https?://\\(?:www\\.\\)?%s/.+" + (regexp-opt '("youtu.be" + "youtube.com" + "blip.tv" + "vimeo.com" + "infoq.com") + t)) + "A regular expression matching URLs that point to video streams") + +(defun jao-embark-targets--w3m-anchor () + (when (not (region-active-p)) + (when-let ((url (or (w3m-anchor) w3m-current-url))) + (cons 'url url)))) + +(defun jao-embark-targets--refine-url (url) + (if (string-match-p jao-embark-targets-video-url-rx url) + (cons 'video-url url) + (cons 'url url))) + +(defun jao-embark-targets--play-video (player url) + (interactive "sURL: ") + (let ((cmd (format "%s %s" player (shell-quote-argument url)))) + (start-process-shell-command player nil cmd))) + +(defun jao-embark-targets-mpv (&optional url) + "Play video stream with mpv" + (interactive "sURL: ") + (jao-embark-targets--play-video "mpv" url)) + +(defun jao-embark-targets-vlc (&optional url) + "Play video stream with vlc" + (interactive "sURL: ") + (jao-embark-targets--play-video "vlc" url)) + +(embark-define-keymap jao-embark-targets-video-url-map + "Actions on URLs pointing to remote video streams." + :parent embark-url-map + ("v" jao-embark-targets-vlc) + ("m" jao-embark-targets-mpv)) + +(define-key embark-url-map (kbd "f") #'browse-url-firefox) + +(add-to-list 'embark-target-finders #'jao-embark-targets--w3m-anchor) +(add-to-list 'embark-transformer-alist '(url . jao-embark-targets--refine-url)) +(add-to-list 'embark-keymap-alist '(video-url . jao-embark-targets-video-url-map)) + +(provide 'jao-embark-targets) +;;; jao-embark-targets.el ends here diff --git a/lib/eos/jao-minibuffer.el b/lib/eos/jao-minibuffer.el new file mode 100644 index 0000000..91662bf --- /dev/null +++ b/lib/eos/jao-minibuffer.el @@ -0,0 +1,138 @@ +;;; jao-minibuffer.el --- using the minibuffer to report status -*- lexical-binding: t; -*- + +;; Copyright (C) 2020, 2021 jao + +;; Author: jao +;; Keywords: extensions + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Simple asynchronous display of information in the minibuffer. + +;;; Code: + +(defvar jao-minibuffer-info ()) +(defvar jao-minibuffer-notification nil) +(defvar jao-minibuffer-align-right-p t) +(defvar jao-minibuffer-right-margin (if window-system 0 1)) +(defvar jao-minibuffer-maximized-frames-p nil) +(defvar jao-minibuffer-frame-width nil) +(defvar jao-minibuffer-notification-timeout 5) +(defvar jao-minibuffer-enabled-p t) + +(defconst jao-minibuffer--name " *Minibuf-0*") + +(defun jao-minibuffer--trim (s w) + (if (<= (string-width (or s "")) w) + (format (format "%%%ds" (if jao-minibuffer-align-right-p w (- w))) s) + (substring s 0 w))) + +(defun jao-minibuffer--current () + (with-current-buffer jao-minibuffer--name + (buffer-substring (point-min) (point-max)))) + +(defun jao-minibuffer--width () + (cond ((numberp jao-minibuffer-frame-width) jao-minibuffer-frame-width) + (jao-minibuffer-maximized-frames-p (frame-width)) + (t (min (frame-width) (window-width (minibuffer-window)))))) + +(defun jao-minibuffer--format-info () + (mapconcat 'string-trim + (seq-filter (lambda (s) (not (string-blank-p s))) + (mapcar 'format-mode-line + (if jao-minibuffer-align-right-p + jao-minibuffer-info + (reverse jao-minibuffer-info)))) + " ")) + +(defun jao-minibuffer--aligned (&optional w currentp) + (let* ((msg (cond (currentp (jao-minibuffer--current)) + (jao-minibuffer-notification + (format-mode-line jao-minibuffer-notification)) + (t (jao-minibuffer--format-info)))) + (msg (if jao-minibuffer-align-right-p + (string-trim msg) + (string-trim-left msg))) + (msg (propertize msg :minibuffer-message t))) + (when (not (string-empty-p msg)) + (let* ((mw (jao-minibuffer--width)) + (w (mod (or w (string-width (or (current-message) ""))) mw)) + (w (- mw w jao-minibuffer-right-margin))) + (if (> w 0) (jao-minibuffer--trim msg w) ""))))) + +(defun jao-minibuffer--set-message (msg) + (if current-minibuffer-command + msg + (let* ((msg (string-trim (replace-regexp-in-string "\n" " " msg))) + (msg (if (string-blank-p msg) msg (concat msg " ")))) + (if jao-minibuffer-align-right-p + (concat msg (jao-minibuffer--aligned (string-width (or msg "")) t)) + (concat (jao-minibuffer--aligned (+ 3 (string-width (or msg ""))) t) + " " msg))))) + +(defun jao-minibuffer--insert (msg) + (with-current-buffer jao-minibuffer--name + (erase-buffer) + (insert msg))) + +;;;###autoload +(defun jao-minibuffer-refresh () + (interactive) + (when jao-minibuffer-enabled-p + (jao-minibuffer--insert (or (jao-minibuffer--aligned) "")))) + +;;;###autoload +(defun jao-minibuffer-add-variable (variable-name &optional order) + (add-to-ordered-list 'jao-minibuffer-info `(:eval ,variable-name) order)) + +(defvar jao-minibuffer--notification-timer nil) + +(defun jao-minibuffer--start-notification-timer (timeout) + (interactive) + (when jao-minibuffer--notification-timer + (cancel-timer jao-minibuffer--notification-timer)) + (setq jao-minibuffer--notification-timer + (run-with-idle-timer (or timeout jao-minibuffer-notification-timeout) + nil + 'jao-minibuffer-pop-notification))) + +;;;###autoload +(defun jao-minibuffer-push-notification (msg &optional timeout) + (setq jao-minibuffer-notification msg) + (jao-minibuffer--start-notification-timer timeout) + (jao-minibuffer-refresh)) + +;;;###autoload +(defun jao-minibuffer-pop-notification () + (interactive) + (setq jao-minibuffer-notification nil) + (jao-minibuffer-refresh)) + +;;;###autoload +(defun jao-minibuffer-toggle () + (interactive) + (setq jao-minibuffer-enabled-p (not jao-minibuffer-enabled-p)) + (if jao-minibuffer-enabled-p + (jao-minibuffer-refresh) + (jao-minibuffer--insert ""))) + +(setq set-message-function #'jao-minibuffer--set-message) +(setq clear-message-function #'jao-minibuffer-refresh) + +(setq resize-mini-windows nil) + +(provide 'jao-minibuffer) +;;; jao-minibuffer.el ends here diff --git a/lib/eos/jao-notify.el b/lib/eos/jao-notify.el new file mode 100644 index 0000000..dc48ca4 --- /dev/null +++ b/lib/eos/jao-notify.el @@ -0,0 +1,33 @@ +;; jao-notify.el -- Interacting with notification daemon + +;; Copyright (c) 2017, 2019, 2020 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sun Jan 08, 2017 20:24 + + +;;; Comentary: + +;; Simple notifications using echo or dbus notifications + +;;; Code: + +(defvar jao-notify-use-messages-p nil) +(defvar jao-notify-timeout 5000) + +(declare-function notifications-notify "notifications") + +(defun jao-notify (msg &optional title icon) + (if jao-notify-use-messages-p + (message "%s%s%s" (or title "") (if title ": " "") (or msg "")) + (let* ((args `(:timeout ,jao-notify-timeout)) + (args (append args + (if title `(:title ,title :body ,msg) `(:title ,msg)))) + (args (if (and (stringp icon) (file-exists-p icon)) + (append args `(:app-icon ,(format "%s" icon))) + args))) + (apply 'notifications-notify args)))) + + +(provide 'jao-notify) +;;; jao-notify.el ends here diff --git a/lib/eos/jao-osd.el b/lib/eos/jao-osd.el new file mode 100644 index 0000000..acdc629 --- /dev/null +++ b/lib/eos/jao-osd.el @@ -0,0 +1,55 @@ +;; candy +(defvar jao-osd-cat-color-fg "black") +(defvar jao-osd-cat-color-bg "white") +(defvar jao-osd-cat-font "Andika Basic 16") +;; (setq jao-osd-cat-font "Inconsolata 20") +(defun jao-osd-cat-font (&optional font) + (or font jao-osd-cat-font)) + +(defun jao-osd-process-args (&optional font fg bg) + `("-n" ,(jao-osd-cat-font font) + "-R" ,(or bg jao-osd-cat-color-fg) "-B" ,(or fg jao-osd-cat-color-bg) + "-b" "200" "-r" "255" + "-e" "0" "-t" "2" "-d" "10" "-p" "0" "-x" "10" "-y" "10" "-u" "5000")) + +(setq jao-osd-processes (make-hash-table)) + +(defsubst jao-osd--delete-process (name) + (remhash name jao-osd-processes)) + +(defun jao-osd-process (name &optional font color) + (let ((proc (gethash name jao-osd-processes))) + (or (and proc (eq (process-status proc) 'run) proc) + (puthash name + (apply 'start-process + `("notifications" + ,(format "*notifications/%s*" name) + "aosd_cat" + ,@(jao-osd-process-args))) + jao-osd-processes)))) + +(defun jao-osd-cat (name lines) + (let* ((proc (jao-osd-process name)) + (lines (if (listp lines) lines (list lines))) + (trail (- 5 (length lines)))) + (when proc + (dolist (line lines) + (send-string proc (format "%s\n" line)))))) + ; (when (> trail 0) (send-string proc (make-string trail ?\n)))))) + +(defun jao-osd--names () + (let (names) + (maphash (lambda (n k) (push n names)) jao-osd-processes) + (reverse names))) + +(defun jao-osd-kill (name) + (let ((proc (gethash name jao-osd-processes))) + (when (processp proc) + (kill-process proc)))) + +(defun jao-osd-kill-notifiers () + (interactive) + (maphash (lambda (n p) (ignore-errors (kill-process p))) jao-osd-processes) + (clrhash jao-osd-processes)) + +(provide 'jao-osd) diff --git a/lib/eos/jao-sleep.el b/lib/eos/jao-sleep.el new file mode 100644 index 0000000..93da0e7 --- /dev/null +++ b/lib/eos/jao-sleep.el @@ -0,0 +1,58 @@ +;;; jao-sleep.el --- Actions upon sleep/awake -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 jao + +;; Author: jao +;; Keywords: hardware + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Code: + +(require 'dbus) + +(defvar jao-sleep-sleep-functions nil) +(defvar jao-sleep-awake-functions nil) + +(defvar jao-sleep--dbus-registration-object nil) + +(defun jao-sleep--dbus-sleep-handler (sleep-start) + (condition-case nil + (if sleep-start + (progn (message "Running on sleep functions") + (run-hooks 'jao-sleep-sleep-functions)) + (message "Running on awake functions") + (run-hooks 'jao-sleep-awake-functions)) + (error (message "There was an error running %s" sleep-start)))) + +;;;###autoload +(defun jao-sleep-dbus-register (&optional session-dbus) + "Register actions to take on sleep and on awake, using the system D-BUS." + (when (featurep 'dbusbind) + (setq jao-sleep--dbus-sleep-registration-object + (dbus-register-signal (if session-dbus :session :system) + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "PrepareForSleep" + #'jao-sleep--dbus-sleep-handler)))) + +;;;###autoload +(defun jao-sleep-dbus-unregister () + (condition-case nil + (dbus-unregister-object jao-sleep--dbus-sleep-registration-object) + (wrong-type-argument nil))) + +(provide 'jao-sleep) +;;; jao-sleep.el ends here diff --git a/lib/media/espotify.org b/lib/media/espotify.org new file mode 100644 index 0000000..93338a9 --- /dev/null +++ b/lib/media/espotify.org @@ -0,0 +1,627 @@ +#+title: consulting spotify +#+date: <2021-01-08 04:02> +#+filetags: emacs +#+PROPERTY: header-args :tangle yes :comments no :results silent + +(/Note/: you can tangle this file (e.g., with =C-c C-v t= inside Emacs) +into three elisp libraries, =espotify.el=, =espotify-consult.el, +=espotify-embark=. and =espotify-counsel=) + +We have two kinds of interaction with Spotify: via its HTTP API to +perform operations such as search, and via our local DBUS to talk to +client players running in our computer, such as the official client, +[[https://github.com/Spotifyd/spotifyd][spotifyd]] or [[https://mopidy.com/ext/spotify/][mopidy-spotify]]. Our goal is to obtain via the former a +track or album identifier that we can send then to the latter to play, +with emacs completion mechanisms (consult and friends in this case) +providing the glue between both worlds. + +Let's start with an umbrella customization group: +#+begin_src emacs-lisp + ;;; espotify.el - spotify search and play - -*- lexical-binding: t; -*- + + (defgroup espotify nil + "Access to Spotify API and clients" + :group 'multimedia) +#+end_src + +* Access to Spotify's API: authentication + + I am stealing most of the ideas on how to establish authenticated + connections to the Spotify API and performing queries from + [[https://github.com/Lautaro-Garcia/counsel-spotify][counsel-spotify]], with many simplifications. + + We start defining a couple of end-points: + + #+begin_src emacs-lisp + (defvar espotify-spotify-api-url "https://api.spotify.com/v1") + (defvar espotify-spotify-api-authentication-url + "https://accounts.spotify.com/api/token") + #+end_src + + And we're going to need as well a client id and secret for our + application, which i am again defining as variables since i expect + them to be set in some secure manner instead of via customize: + + #+begin_src emacs-lisp + (defvar espotify-client-id nil "Spotify application client ID.") + (defvar espotify-client-secret nil "Spotify application client secret.") + #+end_src + + To get valid values for them, one just needs to [[https://developer.spotify.com/my-applications][register a Spotify + application]]. From them we can derive a base64-encoded credentials + value: + + #+begin_src emacs-lisp + (defun espotify--basic-auth-credentials () + (let ((credential (concat espotify-client-id ":" espotify-client-secret))) + (concat "Basic " (base64-encode-string credential t)))) + #+end_src + + The return value of the function above is to be used as the + "Authorization" header of our requests to the authorization + end-point, which is going to answer with an authorization token + that we can then use to further requests. Let's define a function to + wrap that operation: + + #+begin_src emacs-lisp + (defun espotify--with-auth-token (callback) + (let ((url-request-method "POST") + (url-request-data "&grant_type=client_credentials") + (url-request-extra-headers + `(("Content-Type" . "application/x-www-form-urlencoded") + ("Authorization" . ,(espotify--basic-auth-credentials))))) + (url-retrieve espotify-spotify-api-authentication-url + (lambda (_status) + (goto-char url-http-end-of-headers) + (funcall callback + (alist-get 'access_token (json-read))))))) + #+end_src + + For instance: + #+begin_src emacs-lisp :load no :tangle no + (espotify--with-auth-token + (lambda (token) (message "Your token is: %s" token))) + #+end_src + + obtains an auth token and prints it as a message. Note that ~body~ + is evaluated asynchronously by ~url-retrieve~, so invocations to + ~espotify-with-auth-token~ evaluate to the request's buffer and are + usually discarded. + +* Search queries using the Spotify API + + We are interested in performing a search for some ~term~, of items + of a given ~types~ (~:track~, ~:album~, ~:artist~, etc.), possibly with an + additional ~filter~. That's specified in a GET request's URL + as constructed by this function: + + #+begin_src emacs-lisp + (defun espotify--make-search-url (term types &optional filter) + (when (null types) + (error "Must supply a non-empty list of types to search for")) + (let ((term (url-encode-url term))) + (format "%s/search?q=%s&type=%s&limit=50" + espotify-spotify-api-url + (if filter (format "%s:%s" filter term) term) + (mapconcat #'symbol-name types ",")))) + #+end_src + + For instance: + + #+begin_src emacs-lisp :load no :tangle no :results replace + (espotify--make-search-url "dream blue turtles" '(album)) + #+end_src + + #+RESULTS: + : https://api.spotify.com/v1/search?q=dream%20blue%20turtles&type=album&limit=50 + + If we have an [[*Access to Spotify's API: authentication][authorisation token]] and a search URL in our hands, + we can use them as in the following helper function, which will + calls the given callback with the results of the query: + + #+begin_src emacs-lisp + (defun espotify--with-query-results (token url callback) + (let ((url-request-extra-headers + `(("Authorization" . ,(concat "Bearer " token))))) + (url-retrieve url + (lambda (_status) + (goto-char url-http-end-of-headers) + (funcall callback + (let ((json-array-type 'list)) + (thread-first + (buffer-substring (point) (point-max)) + (decode-coding-string 'utf-8) + (json-read-from-string)))))))) + #+end_src + + So we can combine this macro with ~espotify--with-auth-token~ in a + single search function that takes a callback that will be applied + to a given query, specified as a triple of term, types and filter: + + #+begin_src emacs-lisp + (defun espotify-get (callback url) + (espotify--with-auth-token + (lambda (token) + (espotify--with-query-results token url callback)))) + + (defun espotify-search (callback term types &optional filter) + (espotify-get callback (espotify--make-search-url term types filter))) + #+end_src + + For instance: + #+begin_src emacs-lisp :load no :tangle no + (defvar espotify-query-result nil) + (espotify-search (lambda (res) (setq espotify-query-result res)) + "dream blue turtles" + '(album artist)) + (sit-for 0) + #+end_src + + #+begin_src emacs-lisp :load no :tangle no :results replace + (mapcar 'car espotify-query-result) + #+end_src + + #+RESULTS: + | albums | artists | + + So Spotify is returning a results entry per type, which in turn, + contains an ~items~ with the list of actual results. So let's + provide an interface for a callback that takes as many lists of + items as types it asks for: + + #+begin_src emacs-lisp + (defun espotify--type-items (res type) + (alist-get 'items (alist-get (intern (format "%ss" type)) res))) + + (defun espotify-search* (callback term types &optional filter) + (let* ((types (if (listp types) types (list types))) + (cb (lambda (res) + (let ((its (mapcar (lambda (tp) + (espotify--type-items res tp)) + types))) + (apply callback its))))) + (espotify-search cb term types filter))) + #+end_src + + For example: + + #+begin_src emacs-lisp :load no :tangle no + (defvar espotify-query-result nil) + (espotify-search* (lambda (al ar) + (message "Found %s albums, %s artists" + (length al) (length ar)) + (setq espotify-query-result (cons al ar))) + "blue turtles" + '(album artist)) + (sit-for 0) + (list (mapcar 'car (car (car espotify-query-result))) + (mapcar 'car (car (cdr espotify-query-result)))) + #+end_src + + #+RESULTS: + | album_type | artists | available_markets | external_urls | href | id | images | name | release_date | release_date_precision | total_tracks | type | uri | + | external_urls | followers | genres | href | id | images | name | popularity | type | uri | | | | + + Another strategy would be to search for several types and pass to + our callback the concatenation of all items: + + #+begin_src emacs-lisp + (defun espotify-search-all (callback term &optional types filter) + (let ((types (or types '(album track artist playlist)))) + (espotify-search* (lambda (&rest items) + (funcall callback (apply 'append items))) + term + types + filter))) + #+end_src + +* Listing user resources in the Spotify API + + It is also possible to obtain lists of items of a given type for the + current user, with a standard URL format: + + #+begin_src emacs-lisp + (defun espotify--make-user-url (type) + (format "%s/me/%ss" espotify-spotify-api-url (symbol-name type))) + #+end_src + + and we can then use ~espotify-get~ to offer access to our playlists, + albums, etc.: + + #+begin_src emacs-lisp + (defun espotify-with-user-resources (callback type) + (espotify-get (lambda (res) (funcall callback (alist-get 'items res))) + (espotify--make-user-url type))) + #+end_src + +* Sending commands to local players + + Once we now the URI we want to play (that ~uri~ entry in our items), + sending it to a local player via DBUS is fairly easy. Let's + define a couple of customizable variables pointing to the service + name and bus: + + #+begin_src emacs-lisp + (defcustom espotify-service-name "mopidy" + "Name of the DBUS service used by the client we talk to. + + The official Spotify client uses `spotify', but one can also use + alternative clients such as mopidy or spotifyd." + :type 'string) + + (defcustom espotify-use-system-bus-p t + "Whether to access the spotify client using the system DBUS.") + #+end_src + + and then using the Emacs DBUS API to send methods to it is a + breeze: + + #+begin_src emacs-lisp + (defun espotify-call-spotify-via-dbus (method &rest args) + "Tell Spotify to execute METHOD with ARGS through DBUS." + (apply #'dbus-call-method `(,(if espotify-use-system-bus-p :system :session) + ,(format "org.mpris.MediaPlayer2.%s" + espotify-service-name) + "/org/mpris/MediaPlayer2" + "org.mpris.MediaPlayer2.Player" + ,method + ,@args))) + + (defun espotify-play-uri (uri) + (espotify-call-spotify-via-dbus "OpenUri" uri)) + #+end_src + +* Search front-end using consult + :PROPERTIES: + :header-args: :tangle espotify-consult.el + :END: + + I am exploring [[https://github.com/minad/consult][consult.el]] (and friends) to replace ivy/counsel, + inspired in part by [[https://protesilaos.com/codelog/2021-01-06-emacs-default-completion/][Protesilaos Stavrou's musings]], and liking a + lot what i see. Up till now, everything i had with counsel is + supported, often in better ways, with one exception: completing + search of spotify albums using [[https://github.com/Lautaro-Garcia/counsel-spotify][counsel-spotify]]. So let's fix that + by defining an asynchronous consult function that does precisely + that! + + The top-level command will have this form: + + #+begin_src emacs-lisp + ;;; espotify-consult.el - consult support - -*- lexical-binding: t; -*- + + (require 'espotify) + (require 'consult) + + (defvar espotify-consult-history nil) + + (defun espotify-consult-by (type &optional filter) + (let ((orderless-matching-styles '(orderless-literal))) + (consult--read (format "Search %ss: " type) + (espotify--search-generator type filter) + :lookup 'espotify--consult-lookup + :category 'espotify-search-item + :history 'espotify-consult-history + :initial consult-async-default-split + :require-match t))) + #+end_src + + where we can write an asynchronous generator of search results + with the helper function: + + #+begin_src emacs-lisp + (defun espotify--search-generator (type filter) + (thread-first (consult--async-sink) + (consult--async-refresh-immediate) + (consult--async-map #'espotify--format-item) + (espotify--async-search type filter) + (consult--async-throttle) + (consult--async-split))) + #+end_src + + The above follows a generic consult pattern, where all functions + are pre-defined for us except ~espotify--async-search~, an + asynchronous dispatcher closure that must generate and handle a + list of candidates, responding to a set of action messages (init, + reset, get, flush, etc.) [fn:1] Here's its definition in our + case: + + #+begin_src emacs-lisp + (defun espotify--async-search (next type filter) + (let ((current "")) + (lambda (action) + (pcase action + ((pred stringp) + (when-let (term (espotify-check-term current action)) + (setq current term) + (espotify-search-all + (lambda (x) + (funcall next 'flush) + (funcall next x)) + current + type + filter))) + (_ (funcall next action)))))) + #+end_src + + We have introduced the convention that we're only launching a search + when the input string ends in "=", to avoid piling on HTTP + requests, and also played a bit with Levenshtein distance, both via + the function =espotify-check-search-term=: + + #+begin_src emacs-lisp :tangle espotify.el + (defvar espotify-search-suffix "=" + "Suffix in the search string launching an actual Web query.") + + (defvar espotify-search-threshold 8 + "Threshold to automatically launch an actual Web query.") + + (defun espotify-check-term (prev new) + (when (not (string-blank-p new)) + (cond ((string-suffix-p espotify-search-suffix new) + (substring new 0 (- (length new) (length espotify-search-suffix)))) + ((>= (string-distance prev new) espotify-search-threshold) new)))) + #+end_src + + In the consult case, a more natural choice for the search suffix is + + #+begin_src emacs-lisp + (setq espotify-search-suffix consult-async-default-split) + #+end_src + + When processing the results, we format them as a displayable + string, while hiding in a property the URI that will allow us to + play the item (and pass the formatter to ~consult-async--map~, in + ~espotify--search-generator~ above): + + #+begin_src emacs-lisp :tangle espotify.el + (defun espotify--additional-info (x) + (mapconcat 'identity + (seq-filter 'identity + `(,(alist-get 'name (alist-get 'album x)) + ,(alist-get 'name (car (alist-get 'artists x))) + ,(alist-get 'display_name (alist-get 'owner x)))) + ", ")) + + (defun espotify--format-item (x) + (propertize (format "%s%s" + (alist-get 'name x) + (if-let ((info (espotify--additional-info x))) + (format " (%s)" info) + "")) + 'espotify-item x)) + + (defun espotify--item (cand) + (get-text-property 0 'espotify-item cand)) + + (defun espotify--uri (cand) + (alist-get 'uri (espotify--item cand))) + #+end_src + + and then we make sure that we access that original string when + consult looks up for it using the ~:lookup~ function, which we can + simply define as: + + #+begin_src emacs-lisp + (require 'seq) + (defun espotify--consult-lookup (_input cands cand) + (seq-find (lambda (x) (string= cand x)) cands)) + #+end_src + + + With that, when we receive the final result from ~consult--read~, + we can play the selected URI right away: + + #+begin_src emacs-lisp :tangle espotify.el + (defun espotify--maybe-play (cand) + (when-let (uri (when cand (espotify--uri cand))) + (espotify-play-uri uri))) + #+end_src + + And here, finally, are our interactive command to search and play + albums using consult: + + #+begin_src emacs-lisp + (defun espotify-consult-album (&optional filter) + (interactive) + (espotify--maybe-play (espotify-consult-by 'album filter))) + #+end_src + + And likewise for playlists, artists and combinations thereof: + + #+begin_src emacs-lisp + (defun espotify-consult-artist (&optional filter) + (interactive) + (espotify--maybe-play (espotify-consult-by 'artist filter))) + + (defun espotify-consult-track (&optional filter) + (interactive) + (espotify--maybe-play (espotify-consult-by 'track filter))) + + (defun espotify-consult-playlist (&optional filter) + (interactive) + (espotify--maybe-play (espotify-consult-by 'playlist filter))) + #+end_src + +* Adding metadata to candidates using Marginalia + :PROPERTIES: + :header-args: :tangle espotify-consult.el + :END: + + Let's add metadata fields to our candidates, so that packages like + [[https://github.com/minad/marginalia][Marginalia]] can offer it to consult or selectrum. + + #+begin_src emacs-lisp + (defun espotify-marginalia-annotate (cand) + (when-let (x (espotify--item cand)) + (marginalia--fields + ((alist-get 'type x "") :face 'marginalia-mode :width 10) + ((if-let (d (alist-get 'duration_ms x)) + (let ((secs (/ d 1000))) + (format "%02d:%02d" (/ secs 60) (mod secs 60))) + "")) + ((if-let (d (alist-get 'total_tracks x)) (format "%s tracks" d) "") + :face 'marginalia-size :width 12) + ((if-let (d (alist-get 'release_date (alist-get 'album x x))) + (format "%s" d) + "") + :face 'marginalia-date :width 10)))) + + (add-to-list 'marginalia-annotators-heavy + '(espotify-search-item . espotify-marginalia-annotate)) + #+end_src + +* Embark actions + :PROPERTIES: + :header-args: :tangle espotify-embark.el + :END: + + In addition to the default action (play the URI in the selected + candidate), we can use embark to define other operations. For + instance, we could print the full item alist in its own buffer, or + always look for an album to play: + + #+begin_src emacs-lisp + (require 'espotify-consult) + (require 'embark) + + (defvar espotify--current-item nil) + + (defun espotify--show-info (name) + "Show low-level info (an alist) about selection." + (interactive "s") + (pop-to-buffer (get-buffer-create "*espotify info*")) + (read-only-mode -1) + (delete-region (point-min) (point-max)) + (insert (propertize name 'face 'bold)) + (newline) + (when espotify--current-item + (insert (pp-to-string espotify--current-item))) + (newline) + (goto-char (point-min)) + (read-only-mode 1)) + + (defun espotify--play-album (ignored) + "Play album associated with selected item." + (interactive "i") + (if-let (album (if (string= "album" + (alist-get 'type espotify--current-item "")) + espotify--current-item + (alist-get 'album espotify--current-item))) + (espotify-play-uri (alist-get 'uri album)) + (error "No album for %s" (alist-get 'nmae espotify--current-item)))) + + (embark-define-keymap espotify-item-keymap + "Actions for Spotify search results" + ("a" espotify--play-album) + ("h" espotify--show-info)) + + (defun espotify--annotate-item (cand) + (setq espotify--current-item (espotify--item cand)) + (cons 'espotify-search-item cand)) + + (add-to-list 'embark-transformer-alist + '(espotify-search-item . espotify--annotate-item)) + + (add-to-list 'embark-keymap-alist + '(espotify-search-item . espotify-item-keymap)) + #+end_src + +* Search fronted using ivy + :PROPERTIES: + :header-args: :tangle espotify-counsel.el + :END: + + #+begin_src emacs-lisp + ;;; counsel-espotify.el - counsel and spotify - -*- lexical-binding: t; -*- + (require 'espotify) + (require 'ivy) + #+end_src + + It is is also not too complicated to provide a counsel collection of + functions. Here, we use =ivy-read= to access the completion + interface, with the flag =dynamic-collection= set. Ivy will wait + until we call =ivy-candidate-updates= with our items. + + #+begin_src emacs-lisp + (defun espotify-counsel--search-by (type filter) + (let ((current-term "")) + (lambda (term) + (when-let (term (espotify-check-term current-term term)) + (espotify-search-all (lambda (its) + (let ((cs (mapcar #'espotify--format-item its))) + (ivy-update-candidates cs))) + (setq current-term term) + type + filter)) + 0))) + #+end_src + + With that, we can define our generic completing read: + + #+begin_src emacs-lisp + + (defun espotify-counsel--play-album (candidate) + "Play album associated with selected item." + (interactive "s") + (let ((item (espotify--item candidate))) + (if-let (album (if (string= "album" (alist-get 'type item "")) + item + (alist-get 'album item))) + (espotify-play-uri (alist-get 'uri album)) + (error "No album for %s" (alist-get 'name item))))) + + (defun espotify-search-by (type filter) + (ivy-read (format "Search %s: " type) + (espotify-counsel--search-by type filter) + :dynamic-collection t + :action `(1 ("a" espotify-counsel--play-album "Play album") + ("p" espotify--maybe-play ,(format "Play %s" type))))) + #+end_src + + and our collection of searching commands: + + #+begin_src emacs-lisp + (defun espotify-counsel-album (&optional filter) + (interactive) + (espotify-search-by 'album filter)) + + (defun espotify-counsel-artist (&optional filter) + (interactive) + (espotify-search-by 'artist filter)) + + (defun espotify-counsel-track (&optional filter) + (interactive) + (espotify-search-by 'track filter)) + + (defun espotify-counsel-playlist (&optional filter) + (interactive) + (espotify-search-by 'playlist filter)) + #+end_src + + Simpler than our initial consult, although it's true that we already + had part of the job done. The nice "split search" that counsult + offers out of the box, though, is much more difficult to get. + +* Postamble + + #+begin_src emacs-lisp + (provide 'espotify) + #+end_src + + #+begin_src emacs-lisp :tangle espotify-consult.el + (provide 'espotify-consult) + #+end_src + + #+begin_src emacs-lisp :tangle espotify-embark.el + (provide 'espotify-embark) + #+end_src + + #+begin_src emacs-lisp :tangle espotify-counsel.el + (provide 'espotify-counsel) + #+end_src + +* Footnotes + +[fn:1] This is an elegant strategy i first learnt about in SICP, many, +many years ago, and i must say that it is very charming to find it +around in the wild! diff --git a/lib/media/jao-emms-info-track.el b/lib/media/jao-emms-info-track.el new file mode 100644 index 0000000..839ef73 --- /dev/null +++ b/lib/media/jao-emms-info-track.el @@ -0,0 +1,212 @@ +;; jao-emms-info-track.el -- utilities to show tracks -*- lexical-binding:t; -*- + +;; Copyright (C) 2009, 2010, 2013, 2017, 2020, 2021 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:47 + +;; 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 of the License, 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 this program. If not, see . + +;;; Code: + +(require 'emms) +(require 'emms-tag-editor) +(require 'emms-player-mpd) +(require 'jao-osd) +(require 'jao-emms) +(require 'jao-minibuffer) + +(defgroup jao-emms-faces nil "Faces" + :group 'faces + :group 'jao-emms) + +(defface jao-emms-font-lock-album '((t (:foreground "lightgoldenrod2"))) + "Album name in EMMS track message." + :group 'jao-emms-faces) + +(defface jao-emms-font-lock-track '((t (:bold t))) + "Track number in EMMS track message." + :group 'jao-emms-faces) + +(defface jao-emms-font-lock-title '((t (:foreground "dodgerblue2"))) + "Track title in EMMS track message." + :group 'jao-emms-faces) + +(defface jao-emms-font-lock-artist '((t (:foreground "dodgerblue3"))) + "Artist name in EMMS track message." + :group 'jao-emms-faces) + +(defcustom jao-emms-show-osd-p nil + "Whether to show osd notices on track change" + :group 'jao-emms) + + + +(defun jao-emms-info-track-stream (track) + "Return track info for streams" + (let ((name (emms-track-name track)) + (title (or (emms-track-get track 'title nil) + (car (emms-track-get track 'metadata nil)) + (car (split-string (shell-command-to-string "mpc status") + "\n"))))) + (format "♪ %s (%s)" (or title "") (if title (emms-track-type track) name)))) + +(defsubst jao--put-face (str face) + (put-text-property 0 (length str) 'face face str) + str) + +(defun jao-emms--to-number (x) + (or (and (numberp x) x) + (and (stringp x) + (string-match "\\`\\(:?[0-9]+\\)" x) + (string-to-number (match-string 1 x))))) + +(defun jao-emms--fmt-time (x suffix) + (if x (format "%02d:%02d%s" (/ x 60) (mod x 60) (or suffix "")) "")) + +(defun jao-emms--fmt-song-times (track lapsed pre post) + (if lapsed + (let ((time (when track (emms-track-get track 'info-playing-time)))) + (format "%s%s%s%s" + (or pre "") + (jao-emms--fmt-time lapsed (when time "/")) + (jao-emms--fmt-time time "") + (or post ""))) + "")) + +(defun jao-emms-info-track-file (track &optional lapsed plen titlesep) + "Return a description of the current track." + (let* ((no (jao-emms--to-number (emms-track-get track 'info-tracknumber "0"))) + (time (emms-track-get track 'info-playing-time)) + (year (emms-track-get track 'info-year)) + (year (if year (format " (%s)" year) "")) + (artist (emms-track-get track 'info-artist "")) + (composer (emms-track-get track 'info-composer nil)) + (title (emms-track-get track 'info-title "")) + (album (emms-track-get track 'info-album)) + (last-played (or (emms-track-get track 'last-played) '(0 0 0))) + (play-count (or (emms-track-get track 'play-count) 0)) + (playlength (if plen (format "/%02d" (string-to-number plen)) ""))) + (if (or (not title) (not album)) + (emms-track-simple-description track) + (format "🎵 %s%s%s%s%s%s%s" + (jao--put-face (if (zerop no) "" (format "%02d%s " no playlength)) + 'jao-emms-font-lock-track) + (jao--put-face title + 'jao-emms-font-lock-title) + (or titlesep " ") + (jao-emms--fmt-song-times track lapsed "[" "] ") + (jao--put-face artist 'jao-emms-font-lock-artist) + (jao--put-face (if composer (format " [%s]" composer) "") + 'jao-emms-font-lock-artist) + (jao--put-face (if album + (format " (%s%s)" album year) + (format "%s *") year) + 'jao-emms-font-lock-album))))) + +;;;###autoload +(defun jao-emms-info-track-description (track &optional lapsed plen tsep) + (if (memq (emms-track-type track) '(streamlist url)) + (jao-emms-info-track-stream track) + (jao-emms-info-track-file track lapsed plen tsep))) + +;;;###autoload +(defun jao-emms-toggle-osd () + (interactive) + (setq jao-emms-show-osd-p (not jao-emms-show-osd-p)) + (message "Emms OSD %s" (if jao-emms-show-osd-p "enabled" "disabled"))) + +(defvar jao-emms-show-icon nil) + +(defun jao-emms--with-mpd-track (callback) + (emms-player-mpd-get-status + nil + (lambda (_ st) + (let* ((lapsed (jao-emms--to-number (cdr (assoc "time" st)))) + (plen (cdr (assoc "playlistlength" st))) + (song (jao-emms--to-number (cdr (assoc "song" st)))) + (track (emms-playlist-current-selected-track))) + (when (and track song) + (emms-track-set track 'info-tracknumber (format "%d" (1+ song)))) + (funcall callback track lapsed plen))))) + +;;;###autoload +(defun jao-emms-show-osd () + (interactive) + (jao-emms--with-mpd-track + (lambda (track lapsed play-len) + (let* ((sep "~~~~~") + (s (jao-emms-info-track-description track lapsed play-len sep)) + (s (substring-no-properties s 2)) + (cs (split-string s sep))) + (jao-notify (car cs) (cadr cs) jao-emms-show-icon))))) + +(defun jao-emms-show-osd-hook () + (interactive) + (when jao-emms-show-osd-p (jao-emms-show-osd))) + +(defun jao-emms-install-id3v2 () + (add-to-list 'emms-tag-editor-tagfile-functions + '("mp3" "id3v2" ((info-artist . "-a") + (info-title . "-t") + (info-album . "-A") + (info-tracknumber . "-T") + (info-year . "-y") + (info-genre . "-g") + (info-composer . "--TCOM") + (info-note . "-c"))))) + +(defvar jao-emms-echo-string "") + +(defun jao-emms--echo-string (v) + (setq jao-emms-echo-string v) + (jao-minibuffer-refresh)) + +(defun jao-emms-update-echo-string (&optional existing-track) + (if emms-player-playing-p + (jao-emms--with-mpd-track + (lambda (track lapsed play-len) + (jao-emms--echo-string + (cond ((and emms-player-paused-p existing-track) + (format "(%s/%s)" + (emms-track-get existing-track 'info-tracknumber) + play-len)) + (emms-player-paused-p "") + (t (jao-emms-info-track-description track nil play-len)))))) + (jao-emms--echo-string ""))) + +(defun jao-emms-enable-minibuffer (minibuffer-order) + (jao-minibuffer-add-variable 'jao-emms-echo-string minibuffer-order) + (dolist (h '(emms-track-updated-functions + emms-player-finished-hook + emms-player-stopped-hook + emms-player-started-hook + emms-player-paused-hook)) + (add-hook h #'jao-emms-update-echo-string))) + +;;;###autoload +(defun jao-emms-info-setup (&optional minibuffer show-osd show-echo-line id3) + (setq emms-track-description-function 'jao-emms-info-track-description) + (setq jao-emms-show-osd-p show-osd) + (add-hook 'emms-player-started-hook 'jao-emms-show-osd-hook) + (when minibuffer (jao-emms-enable-minibuffer minibuffer)) + (unless show-echo-line + (eval-after-load 'emms-player-mpd + '(remove-hook 'emms-player-started-hook 'emms-player-mpd-show))) + (when id3 (jao-emms-install-id3v2)) + (ignore-errors (emms-player-mpd-connect))) + + +(provide 'jao-emms-info-track) +;;; jao-emms-info-track.el ends here diff --git a/lib/media/jao-emms-lyrics.el b/lib/media/jao-emms-lyrics.el new file mode 100644 index 0000000..0ea52e0 --- /dev/null +++ b/lib/media/jao-emms-lyrics.el @@ -0,0 +1,41 @@ +;; jao-emms-lyrics.el -- simple show lyrics in emms + +;; Copyright (C) 2009, 2010, 2017, 2019, 2020 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:41 + +;; 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 of the License, 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 this program. If not, see . + +;;; Code: + +(require 'emms) +(require 'jao-lyrics) + +;;;###autoload +(defun jao-emms-lyrics-track-data () + (let ((track (or (emms-playlist-current-selected-track) + (error "No playing track")))) + (cons (or (emms-track-get track 'info-artist nil) + (error "No artist")) + (or (emms-track-get track 'info-title nil) + (error "No artist"))))) + +;;;###autoload +(defun jao-emms-show-lyrics (&optional force) + (let ((jao-lyrics-info-function 'jao-emms-lyrics-track-data)) + (jao-show-lyrics force))) + +(provide 'jao-emms-lyrics) +;;; jao-emms-lyrics.el ends here diff --git a/lib/media/jao-emms-random-album.el b/lib/media/jao-emms-random-album.el new file mode 100644 index 0000000..72e056b --- /dev/null +++ b/lib/media/jao-emms-random-album.el @@ -0,0 +1,118 @@ +;; jao-emms-random-album.el -- play random albums in emms + +;; Copyright (C) 2009, 2010, 2017, 2018, 2020 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:06 + +;; 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 of the License, 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 this program. If not, see . + + +(require 'emms) +(require 'jao-minibuffer) + +(defvar jao-emms-random-album-p t) +(defvar jao-emms-random-lines nil) +(defvar jao-emms-random-lines-file + (expand-file-name "~/.emacs.d/random-lines")) +(defvar jao-emms-random-album-notify-p t) +(defvar jao-emms-random-album-notify-icon nil) + +(defun jao-emms-random-lines () + (or jao-emms-random-lines + (and (file-exists-p jao-emms-random-lines-file) + (with-current-buffer + (find-file-noselect jao-emms-random-lines-file) + (goto-char (point-min)) + (setq jao-emms-random-lines (read (current-buffer))))) + (dotimes (n (1- (line-number-at-pos (point-max))) + jao-emms-random-lines) + (push (1+ n) jao-emms-random-lines)))) + +(defun jao-emms-random-lines-save () + (with-current-buffer (find-file-noselect jao-emms-random-lines-file) + (delete-region (point-min) (point-max)) + (insert (format "%s\n" jao-emms-random-lines)) + (save-buffer))) + +(defun jao-emms-goto-random-album () + (let* ((pos (random (length (jao-emms-random-lines)))) + (line (nth pos jao-emms-random-lines))) + (setq jao-emms-random-lines (remove line jao-emms-random-lines)) + (jao-emms-random-lines-save) + (goto-line line))) + +(defun jao-emms-next-noerror () + (interactive) + (when emms-player-playing-p + (error "A track is already being played")) + (cond (emms-repeat-track + (emms-start)) + ((condition-case nil + (progn + (emms-playlist-current-select-next) + t) + (error nil)) + (emms-start)) + (t + (if jao-emms-random-album-p + (jao-emms-random-album-next) + (message "No next track in playlist"))))) + + +;; User interface +;;;###autoload +(defun jao-emms-random-album-start () + (interactive) + (setq jao-emms-random-album-p t) + (jao-emms-random-album-next)) + +;;;###autoload +(defun jao-emms-random-album-stop () + (interactive) + (setq jao-emms-random-album-p nil) + (emms-stop)) + +;;;###autoload +(defun jao-emms-random-album-toggle () + (interactive) + (setq jao-emms-random-album-p (not jao-emms-random-album-p)) + (message "Random album %s" + (if jao-emms-random-album-p "enabled" "disabled"))) + +;;;###autoload +(defun jao-emms-random-album-next () + (interactive) + (save-excursion + (ignore-errors (emms-browser-clear-playlist)) + (emms-browse-by-album) + (jao-emms-goto-random-album) + (let ((album (substring-no-properties (thing-at-point 'line) 0 -1))) + (emms-browser-add-tracks-and-play) + (when jao-emms-random-album-notify-p + (jao-notify album "Next album" jao-emms-random-album-notify-icon))) + (emms-browser-bury-buffer) + (jao-minibuffer-refresh))) + +;;;###autoload +(defun jao-emms-random-album-reset () + (interactive) + (setq jao-emms-random-lines nil) + (jao-emms-random-lines-save)) + +(setq emms-player-next-function 'jao-emms-next-noerror) + + +(provide 'jao-emms-random-album) +;;; jao-emms-random-album.el ends here diff --git a/lib/media/jao-emms.el b/lib/media/jao-emms.el new file mode 100644 index 0000000..53b3513 --- /dev/null +++ b/lib/media/jao-emms.el @@ -0,0 +1,27 @@ +;; jao-emms.el -- shared bits + +;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:51 + +;; 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 of the License, 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 this program. If not, see . + +;;; Code: + +(defgroup jao-emms nil "Emms extensions" :group 'emms) + + +(provide 'jao-emms) +;;; jao-emms.el ends here diff --git a/lib/media/jao-lyrics.el b/lib/media/jao-lyrics.el new file mode 100644 index 0000000..dd85da1 --- /dev/null +++ b/lib/media/jao-lyrics.el @@ -0,0 +1,152 @@ +;; jao-lyrics.el -- simple show lyrics using glyrc + +;; Copyright (C) 2009, 2010, 2017, 2019, 2020 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:41 + +;; 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 of the License, 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 this program. If not, see . + +;;; Code: + +(defgroup jao-lyrics-faces nil "Faces" + :group 'faces) + +(defface jao-lyrics-font-lock-album '((t (:foreground "lightgoldenrod2"))) + "Album name in lyrics." + :group 'jao-lyrics-faces) + +(defface jao-lyrics-font-lock-title '((t (:foreground "dodgerblue2"))) + "Track title in lyrics." + :group 'jao-lyrics-faces) + +(defface jao-lyrics-font-lock-artist '((t (:foreground "dodgerblue3"))) + "Artist name in lyrics." + :group 'jao-lyrics-faces) + +(defvar jao-lyrics-cache-dir "~/.lyrics") + +(defun jao-lyrics--filename (artist title) + (expand-file-name (format "%s - %s.txt" artist title) + jao-lyrics-cache-dir)) + +(defun jao-lyrics--get-cached (artist title) + (let ((candidate (jao-lyrics--filename artist title))) + (and (file-exists-p candidate) + (with-current-buffer (find-file-noselect candidate) + (prog1 + (buffer-string) + (kill-buffer)))))) + +(defun jao-lyrics--cache (artist title lyrics) + (with-current-buffer + (find-file-noselect (jao-lyrics--filename artist title)) + (delete-region (point-min) (point-max)) + (insert lyrics) + (save-buffer) + (kill-buffer))) + +(make-variable-buffer-local + (defvar jao-lyrics--path nil)) + +(defvar jao-lyrics-mode-map) +(setq jao-lyrics-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [?q] 'bury-buffer) + (define-key map [?g] 'jao-show-lyrics) + (define-key map [?G] (lambda () (interactive) (jao-show-lyrics t))) + (define-key map [?e] 'jao-edit-lyrics) + map)) + +(defun jao-lyrics-mode () + (interactive) + (kill-all-local-variables) + (use-local-map jao-lyrics-mode-map) + (setq major-mode 'jao-lyrics-mode) + (setq mode-name "lyrics") + (toggle-read-only 1)) + +(defun jao-lyrics-buffer () + (or (get-buffer "*Lyrics*") + (with-current-buffer (get-buffer-create "*Lyrics*") + (jao-lyrics-mode) + (current-buffer)))) + +(defun jao-edit-lyrics () + (interactive) + (unless jao-lyrics--path + (error "No track data available.")) + (find-file-other-window jao-lyrics--path)) + + + +(defun jao-lyrics--clean-download (fn) + (with-current-buffer (find-file-noselect fn) + (goto-char (point-min)) + (when (re-search-forward + "^\\(CreditsWritten by:\\|External linksNominate\\)" nil t) + (beginning-of-line) + (kill-region (point) (point-max))) + (replace-string " " "" nil (point-min) (point-max)) + (replace-string "\\'" "'" nil (point-min) (point-max)) + (save-buffer))) + +(defun jao-lyrics--download (artist title &optional noartist) + (message "Retrieving lyrics...") + (or (executable-find "glyrc") + (error "glyrc not installed")) + (let ((fn (jao-lyrics--filename (or noartist artist) title))) + (shell-command-to-string (format "glyrc lyrics -n 1-8 -Y -a %s -t %s -w %s" + (shell-quote-argument artist) + (shell-quote-argument title) + (shell-quote-argument fn))) + (jao-lyrics--clean-download fn) + (prog1 (jao-lyrics--get-cached artist title) (message nil)))) + +(defvar jao-lyrics-info-function) +(defvar-local jao-lyrics--info-function nil) + +;;;###autoload +(defun jao-show-lyrics (&optional force info-function) + (interactive "P") + (let* ((a/t (funcall (or info-function + jao-lyrics--info-function + jao-lyrics-info-function))) + (artist (car a/t)) + (title (cdr a/t)) + (artist (if force (read-string "Artist: " artist) artist)) + (title (if force (read-string "Title: " title) title)) + (buffer (jao-lyrics-buffer)) + (cached (and (not force) (jao-lyrics--get-cached artist title))) + (cached (and (not (zerop (length cached))) cached)) + (lyrics (or cached + (jao-lyrics--download artist title) + (jao-lyrics--download "" title artist))) + (inhibit-read-only t)) + (with-current-buffer buffer + (when info-function + (setq-local jao-lyrics--info-function info-function)) + (delete-region (point-min) (point-max)) + (insert (format "♪ %s - %s\n\n" + (propertize artist 'face 'jao-lyrics-font-lock-artist) + (propertize title 'face 'jao-lyrics-font-lock-title))) + (when lyrics (insert lyrics)) + (goto-char (point-min)) + (setq jao-lyrics--path (jao-lyrics--filename artist title))) + (pop-to-buffer buffer))) + + +(provide 'jao-lyrics) +;;; jao-lyrics.el ends here diff --git a/lib/media/jao-mpris.el b/lib/media/jao-mpris.el new file mode 100644 index 0000000..ad4b452 --- /dev/null +++ b/lib/media/jao-mpris.el @@ -0,0 +1,139 @@ +;;; jao-mpris.el --- mpris players control -*- lexical-binding: t; -*- + +;; Copyright (C) 2020, 2021 jao + +;; Author: jao +;; Keywords: multimedia + +;; This program 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 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; controlling and showing info on mpris players + +;;; Code: + +(require 'dbus) +(require 'jao-minibuffer) +(require 'jao-emms-info-track) + +(defun jao-mpris--playerctl (&rest args) + (shell-command-to-string (format "playerctl %s" + (mapconcat #'shell-quote-argument args " ")))) + +(defmacro jao-playerctl--def (name &rest args) + `(defun ,name () (interactive) (jao-mpris--playerctl ,@args))) + +(jao-playerctl--def jao-mpris-play-pause "play-pause") +(jao-playerctl--def jao-mpris-next "next") +(jao-playerctl--def jao-mpris-previous "previous") + +(defun jao-playerctl--status (&optional sep) + (let* ((sep (or sep " ||| ")) + (fmt (mapconcat 'identity + '("{{status}}" + "{{xesam:trackNumber}}" + "{{title}}" + "{{artist}}" + "{{album}}" + "{{duration(mpris:length)}}") + sep)) + (m (jao-mpris--playerctl "metadata" "--format" fmt))) + (split-string (car (split-string m "\n")) sep))) + +;;;###autoload +(defun jao-mpris-status-times () + (interactive) + (let ((m (jao-mpris--playerctl "metadata" "--format" + (concat "{{duration(position)}}/" + "{{duration(mpris:length)}}")))) + (jao-notify (string-trim m) "Playing"))) + +(defvar jao-mpris--current nil) +(defvar jao-mpris-track-string "") + +(defun jao-mpris--get (k &optional l) + (alist-get k (or l jao-mpris--current))) + +(defun jao-mpris--format (&optional info) + (let* ((artist (jao-mpris--get 'artist info)) + (title (jao-mpris--get 'title info)) + (track (jao-mpris--get 'track info)) + (album (jao-mpris--get 'album info)) + (len (jao-mpris--get 'length info)) + (duration (cond ((stringp len) len) + ((numberp len) (jao-emms--fmt-time (/ len 1e6) ""))))) + (format "ï…„ %s %s %s%s%s" + (jao--put-face (format "%s" (or track "")) 'jao-emms-font-lock-track) + (jao--put-face title 'jao-emms-font-lock-title) + (jao--put-face artist 'jao-emms-font-lock-artist) + (jao--put-face (if album (format " (%s)" album) "") + 'jao-emms-font-lock-album) + (if duration (format " [%s]" duration) "")))) + +(defun jao-mpris--track (&optional info) + (let ((info (or info (jao-playerctl--status)))) + (if (string= "Playing" (jao-mpris--get 'status info)) + (setq jao-mpris-track-string (jao-mpris--format info)) + (setq jao-mpris-track-string ""))) + (jao-minibuffer-refresh)) + +;;;###autoload +(defun jao-mpris-artist-title () + (when jao-mpris--current + (cons (jao-mpris--get 'artist) (jao-mpris--get 'title)))) + +;;;###autoload +(defun jao-mpris-show-osd () + (interactive) + (when jao-mpris--current + (jao-notify (format "%s: %s" (jao-mpris--get 'status) (jao-mpris--format))))) + +(defun jao-mpris-minibuffer-order (order) + (jao-minibuffer-add-variable 'jao-mpris-track-string order)) + +(defun jao-mpris--handler (iname properties &rest args) + (when properties + (let ((st (caadr (assoc "PlaybackStatus" properties))) + (md (caadr (assoc "Metadata" properties)))) + (cond ((and st (not (string= "Playing" st))) + (setq jao-mpris-track-string "") + (setq jao-mpris--current + (cons (cons 'status st) + (assq-delete-all 'status jao-mpris--current))) + (jao-minibuffer-refresh) + (message "Music %s" st)) + (md (let ((tno (caadr (assoc "xesam:trackNumber" md))) + (tlt (caadr (assoc "xesam:title" md))) + (art (caaadr (assoc "xesam:artist" md))) + (alb (caadr (assoc "xesam:album" md))) + (len (caadr (assoc "mpris:length" md)))) + (setq jao-mpris--current + `((track . ,tno) (title . ,tlt) + (artist . ,art) (album . ,alb) + (length . ,len) (status . ,st))) + (jao-mpris--track jao-mpris--current))))))) + +;;;###autoload +(defun jao-mpris-minibuffer-register (name &optional bus) + (dbus-register-signal (or bus :session) + name + "/org/mpris/MediaPlayer2" + "org.freedesktop.DBus.Properties" + "PropertiesChanged" + 'jao-mpris--handler)) + + +(provide 'jao-mpris) +;;; jao-mpris.el ends here diff --git a/lib/media/jao-random-album.el b/lib/media/jao-random-album.el new file mode 100644 index 0000000..7158417 --- /dev/null +++ b/lib/media/jao-random-album.el @@ -0,0 +1,101 @@ +;; jao-random-album.el -- play random albums + +;; Copyright (C) 2009, 2010, 2017, 2018, 2019 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Jul 04, 2009 13:06 + +;; 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 of the License, 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 this program. If not, see . + +(require 'jao-notify) + +(defvar jao-random-album-p t) +(defvar jao-random-lines nil) +(defvar jao-random-lines-file (expand-file-name "~/.emacs.d/random-lines")) +(defvar jao-random-album-notify-p t) +(defvar jao-random-album-notify-icon nil) +(defvar jao-random-album-skip-lines 2) + +(defun jao-random-lines () + (or jao-random-lines + (and (file-exists-p jao-random-lines-file) + (with-current-buffer + (find-file-noselect jao-random-lines-file) + (goto-char (point-min)) + (setq jao-random-lines (read (current-buffer))))) + (dotimes (n (1- (line-number-at-pos (point-max))) + jao-random-lines) + (when (> n jao-random-album-skip-lines) + (push (1+ n) jao-random-lines))))) + +(defun jao-random-lines-save () + (with-current-buffer (find-file-noselect jao-random-lines-file) + (delete-region (point-min) (point-max)) + (insert (format "%s\n" jao-random-lines)) + (save-buffer))) + +(defun jao-goto-random-album () + (let* ((pos (random (length (jao-random-lines)))) + (line (nth pos jao-random-lines))) + (setq jao-random-lines (remove line jao-random-lines)) + (jao-random-lines-save) + (goto-line line))) + + +;; User interface +(defvar jao-random-album-buffer) +(defvar jao-random-album-add-tracks-and-play) +(defvar jao-random-album-stop) + +(defun jao-random-album-start () + (interactive) + (setq jao-random-album-p t) + (jao-random-album-next)) + +(defun jao-random-album-stop () + (interactive) + (setq jao-random-album-p nil) + (funcall jao-random-album-stop)) + +(defun jao-random-album-toggle () + (interactive) + (setq jao-random-album-p (not jao-random-album-p)) + (message "Random album %s" + (if jao-random-album-p "enabled" "disabled"))) + +(defun jao-random-album-next () + (interactive) + (with-current-buffer (get-buffer (funcall jao-random-album-buffer)) + (save-excursion + (jao-goto-random-album) + (let ((album (string-trim + (substring-no-properties (thing-at-point 'line) 0 -1)))) + (funcall jao-random-album-add-tracks-and-play) + (when jao-random-album-notify-p + (jao-notify album "Next album" jao-random-album-notify-icon)))))) + +(defun jao-random-album-reset () + (interactive) + (setq jao-random-lines nil) + (jao-random-lines-save)) + +(defun jao-random-album-setup (album-buffer add-and-play stop &optional icon) + (setq jao-random-album-buffer album-buffer + jao-random-album-add-tracks-and-play add-and-play + jao-random-album-stop stop + jao-random-album-notify-icon icon)) + + +(provide 'jao-random-album) +;;; jao-random-album.el ends here diff --git a/lib/media/leoslyrics.py b/lib/media/leoslyrics.py new file mode 100755 index 0000000..5e4f8c8 --- /dev/null +++ b/lib/media/leoslyrics.py @@ -0,0 +1,84 @@ +#!/usr/bin/python +# +# (c) 2004-2008 The Music Player Daemon Project +# http://www.musicpd.org/ +# +# This program 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 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# + +# +# Load lyrics from leoslyrics.com +# + +from sys import argv, exit +from urllib import urlencode, urlopen +from xml.sax import make_parser, SAXException +from xml.sax.handler import ContentHandler + +class SearchContentHandler(ContentHandler): + def __init__(self): + self.code = None + self.hid = None + + def startElement(self, name, attrs): + if name == 'response': + self.code = int(attrs['code']) + elif name == 'result': + if self.hid is None or attrs['exactMatch'] == 'true': + self.hid = attrs['hid'] + +def search(artist, title): + query = urlencode({'auth': 'ncmpc', + 'artist': artist, + 'songtitle': title}) + url = "http://api.leoslyrics.com/api_search.php?" + query + f = urlopen(url) + handler = SearchContentHandler() + parser = make_parser() + parser.setContentHandler(handler) + parser.parse(f) + return handler.hid + +class LyricsContentHandler(ContentHandler): + def __init__(self): + self.code = None + self.is_text = False + self.text = None + + def startElement(self, name, attrs): + if name == 'text': + self.text = '' + self.is_text = True + else: + self.is_text = False + + def characters(self, chars): + if self.is_text: + self.text += chars + +def lyrics(hid): + query = urlencode({'auth': 'ncmpc', + 'hid': hid}) + url = "http://api.leoslyrics.com/api_lyrics.php?" + query + f = urlopen(url) + handler = LyricsContentHandler() + parser = make_parser() + parser.setContentHandler(handler) + parser.parse(f) + return handler.text + +hid = search(argv[1], argv[2]) +if hid is None: + exit(2) +print lyrics(hid).encode('utf-8') diff --git a/lib/media/lyricwiki.rb b/lib/media/lyricwiki.rb new file mode 100755 index 0000000..f163fa4 --- /dev/null +++ b/lib/media/lyricwiki.rb @@ -0,0 +1,52 @@ +#!/usr/bin/env ruby +# +# (c) 2004-2008 The Music Player Daemon Project +# http://www.musicpd.org/ +# +# This program 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 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# + +# +# Load lyrics from lyrics.wikia.com, formerly lyricwiki.org +# + +require 'uri' +require 'net/http' +require 'cgi' + +url = "http://lyrics.wikia.com/api.php?action=lyrics&fmt=xml&func=getSong" + \ + "&artist=#{URI.escape(ARGV[0])}&song=#{URI.escape(ARGV[1])}" +response = Net::HTTP.get(URI.parse(url)) + +if not response =~ /\s*(.*?)\s*<\/url>/im + $stderr.puts "No URL in response!" + exit(1) +end + +url = $1 +exit(69) if url =~ /action=edit$/ + +response = Net::HTTP.get(URI.parse(url)) +if not response =~ /
      \s*(.*?)\s*