diff options
| author | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2010-10-12 23:39:29 +0200 |
|---|---|---|
| committer | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2010-10-12 23:39:29 +0200 |
| commit | 1b0abee054235ea4ac7589dd92d3939e1386d24a (patch) | |
| tree | 91d2aa7d5a810bb0032dfe1585ad8e0023c5f81e | |
| download | elibs-1b0abee054235ea4ac7589dd92d3939e1386d24a.tar.gz elibs-1b0abee054235ea4ac7589dd92d3939e1386d24a.tar.bz2 | |
Initial contents
61 files changed, 6401 insertions, 0 deletions
diff --git a/README.org b/README.org new file mode 100644 index 0000000..49f7038 --- /dev/null +++ b/README.org @@ -0,0 +1,10 @@ +* Elisp libraries + + - *themes* color themes based on Emacs builtin custom themes + - *org* utilities for org-mode + - *emms* utilities for EMMS + - *prog* utilities for programming modes + - *skels* skeletons for source files + - *net* utilities for networking (w3m &c.) + - *sys* generic utilities for external programs + - *bmk* a web bookmark manager diff --git a/bmk/bmk-mgr-w3.el b/bmk/bmk-mgr-w3.el new file mode 100644 index 0000000..c22700f --- /dev/null +++ b/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 <jao@gnu.org> +;; 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 new file mode 100644 index 0000000..cc53d41 --- /dev/null +++ b/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 <jao@gnu.org> +;; 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 + "<!--End of section (do not delete this comment)-->\n"))) + (insert-file-contents file) + (goto-char 1) + (while (re-search-forward "<h2>\\([^<]+\\)</h2>\n<ul>\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 "<li><a href=\"" limit t) + (if (re-search-forward "\\([^\"]+\\)\">\\([^<]+\\)</a>\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 new file mode 100644 index 0000000..336447b --- /dev/null +++ b/bmk/bmk-mgr.el @@ -0,0 +1,1478 @@ +;;; bmk-mgr.el --- Bookmark manager: + +;; Copyright (C) 2003, 2004, 2006, 2007 Jose Antonio Ortega Ruiz. +;; + +(defconst bmk-mgr-version "0.1.2") + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; 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 "<up>") 'bmk-mgr-previous-line) + (define-key map (kbd "<down>") 'bmk-mgr-next-line) + (define-key map (kbd "<left>") 'beginning-of-line) + (define-key map (kbd "<right>") 'end-of-line) + (define-key map (kbd "<mouse-1>") 'bmk-mgr-mouse-click) + (define-key map (kbd "<mouse-2>") 'bmk-mgr-mouse-click-alt) + (define-key map (kbd "<S-return>") '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) + "\\<bmk-mgr-mode-map> + Major mode for displaying bookmark files. + +Commands: + +<DIGIT>+<key>\tRepeat command denoted by <key> 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 new file mode 100644 index 0000000..01f00d0 --- /dev/null +++ b/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/bmk/folder-closed.xpm b/bmk/folder-closed.xpm new file mode 100644 index 0000000..ece8a9e --- /dev/null +++ b/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/bmk/folder-open.xpm b/bmk/folder-open.xpm new file mode 100644 index 0000000..f03f65c --- /dev/null +++ b/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/bmk/url-alt.xpm b/bmk/url-alt.xpm new file mode 100644 index 0000000..4cb2c14 --- /dev/null +++ b/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/bmk/url.xpm b/bmk/url.xpm new file mode 100644 index 0000000..60cad93 --- /dev/null +++ b/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/emms/jao-emms-info-track.el b/emms/jao-emms-info-track.el new file mode 100644 index 0000000..5fac8f3 --- /dev/null +++ b/emms/jao-emms-info-track.el @@ -0,0 +1,123 @@ +;; jao-emms-info-track.el -- utilities to show tracks + +;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'emms) +(require 'jao-osd) +(require 'jao-emms) + +(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))))) + (format "♪ %s (%s)" 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-info-track-file (track) + "Return a description of the current track." + (let ((no (string-to-number (emms-track-get track 'info-tracknumber "0"))) + (time (emms-track-get track 'info-playing-time)) + (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))) + (if (or (not title) (not album)) + (emms-track-simple-description track) + (format "♪ %s%s%s%s%s %s" + (if time (format "[%02d:%02d] " (/ time 60) (mod time 60)) "") + (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)" album) " *") + 'jao-emms-font-lock-album) + (jao--put-face (if (zerop no) "" (format " %02d." no)) + 'jao-emms-font-lock-track) + (jao--put-face title + 'jao-emms-font-lock-title))))) + +(defun jao-emms-info-track-description (track) + (if (memq (emms-track-type track) '(streamlist url)) + (jao-emms-info-track-stream track) + (jao-emms-info-track-file track))) + +(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"))) + +(defsubst jao-emms-current-track-str () + (substring-no-properties (jao-emms-info-track-description + (emms-playlist-current-selected-track)))) + +(defun jao-emms-show-osd () + (interactive) + (let ((str (jao-emms-current-track-str))) + (when str (jao-osd-cat 'emms (substring str 2))) + t)) + +(defun jao-emms-show-osd-hook () + (interactive) + (when jao-emms-show-osd-p (jao-emms-show-osd)) + t) + +(defun jao-emms-info-setup (&optional show-osd show-echo-line) + (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) + (unless show-echo-line + (eval-after-load 'emms-player-mpd + '(remove-hook 'emms-player-started-hook 'emms-player-mpd-show)))) + + +(provide 'jao-emms-info-track) +;;; jao-emms-info-track.el ends here diff --git a/emms/jao-emms-lyrics.el b/emms/jao-emms-lyrics.el new file mode 100644 index 0000000..965f7cd --- /dev/null +++ b/emms/jao-emms-lyrics.el @@ -0,0 +1,171 @@ +;; jao-emms-lyrics.el -- simple show lyrics in emms + +;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'emms) + +(defvar jao-emms-lyrics-cache-dir "~/.emacs.d/emms-lyrics") + +(defun jao-emms-lyrics--filename (artist title) + (expand-file-name (format "%s.lyr" title) + (jao-emms-lyrics--ensure-dir artist))) + +(defun jao-emms-lyrics--ensure-dir (artist) + (let ((candidate (expand-file-name artist jao-emms-lyrics-cache-dir))) + (unless (file-directory-p candidate) + (make-directory candidate t)) + candidate)) + +(defun jao-emms-lyrics--get-cached (artist title) + (let ((candidate (jao-emms-lyrics--filename artist title))) + (and (file-exists-p candidate) + (with-current-buffer (find-file-noselect candidate) + (prog1 + (buffer-string) + (kill-buffer)))))) + +(defun jao-emms-lyrics--cache (artist title lyrics) + (with-current-buffer + (find-file-noselect (jao-emms-lyrics--filename artist title)) + (delete-region (point-min) (point-max)) + (insert lyrics) + (save-buffer) + (kill-buffer))) + +(make-variable-buffer-local + (defvar jao-emms-lyrics--path nil)) + +(defvar jao-emms-lyrics-mode-map) +(setq jao-emms-lyrics-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [?q] 'bury-buffer) + (define-key map [?g] 'jao-emms-show-lyrics) + (define-key map [?G] 'jao-emms-show-lyrics-force) + (define-key map [?e] 'jao-emms-edit-lyrics) + map)) + +(defvar jao-emms-font-lock-artist 'bold) +(defvar jao-emms-font-lock-title 'bold) + +(defun jao-emms-lyrics-mode () + (interactive) + (kill-all-local-variables) + (use-local-map jao-emms-lyrics-mode-map) + (setq major-mode 'jao-emms-lyrics-mode) + (setq mode-name "lyrics") + (toggle-read-only 1)) + +(defun jao-emms-lyrics-buffer () + (or (get-buffer "*Emms Lyrics*") + (with-current-buffer (get-buffer-create "*Emms Lyrics*") + (jao-emms-lyrics-mode) + (current-buffer)))) + +(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"))))) + +(defun jao-emms-edit-lyrics () + (interactive) + (unless jao-emms-lyrics--path + (error "No track data available.")) + (find-file-other-window jao-emms-lyrics--path)) + + + +(defconst jao-emms--wiki-fmt + (concat"http://lyrics.wikia.com/api.php?action=lyrics&fmt=xml&func=getSong" + "&artist=%s&song=%s")) + +(defun jao-emms-show-lyrics/wiki () + (interactive) + (let* ((a/t (jao-emms-lyrics-track-data)) + (artist (car a/t)) + (title (cdr a/t)) + (buffer (jao-emms-lyrics-buffer)) + (url (format jao-emms--wiki-fmt + (url-hexify-string artist) + (url-hexify-string title))) + (url-request-method "GET") + (data-buffer (url-retrieve-synchronously url)) + (inhibit-read-only t)) + (set-buffer data-buffer) + ;; (unless (re-search-forward "<pre>" nil t) + ;; (error "Lyrics not found")) + (let ((begin (point))) + ;; (unless (re-search-forward "</pre>" nil t) + ;; (error "Lyrics not found")) + (copy-to-buffer buffer begin (match-beginning 0))) + (with-current-buffer buffer + (goto-char (point-min)) + (insert (format "♪ %s - %s\n" artist title))) + (pop-to-buffer buffer))) + +(defvar jao-emms-show-lyrics/script + (expand-file-name "lyricwiki.rb" (file-name-directory load-file-name))) + +(defun jao-emms-lyrics--download (artist title) + (message "Retrieving lyrics...") + (prog1 + (shell-command-to-string (format "%s \"%s\" \"%s\"" + jao-emms-show-lyrics/script + artist title)) + (message nil))) + +(defun jao-emms-show-lyrics (&optional force) + (interactive "P") + (let* ((a/t (jao-emms-lyrics-track-data)) + (artist (or (car a/t) "")) + (title (or (cdr a/t) "")) + (buffer (jao-emms-lyrics-buffer)) + (cached (and (not force) (jao-emms-lyrics--get-cached artist title))) + (cached (and (not (zerop (length cached))) cached)) + (lyrics (or cached (jao-emms-lyrics--download artist title))) + (inhibit-read-only t)) + (with-current-buffer buffer + (delete-region (point-min) (point-max)) + (insert (format "♪ %s - %s\n\n" + (propertize artist 'face jao-emms-font-lock-artist) + (propertize title 'face jao-emms-font-lock-title))) + (when lyrics + (insert lyrics) + (goto-char (point-min)) + (when (not cached) + (save-excursion + (while (search-forward "
" nil t) + (replace-match "" nil t))))) + (when (and lyrics (not cached)) + (jao-emms-lyrics--cache artist title lyrics)) + (setq jao-emms-lyrics--path (jao-emms-lyrics--filename artist title))) + (pop-to-buffer buffer))) + +(defun jao-emms-show-lyrics-force () + (interactive) + (jao-emms-show-lyrics t)) + + +(provide 'jao-emms-lyrics) +;;; jao-emms-lyrics.el ends here diff --git a/emms/jao-emms-random-album.el b/emms/jao-emms-random-album.el new file mode 100644 index 0000000..04dcd89 --- /dev/null +++ b/emms/jao-emms-random-album.el @@ -0,0 +1,113 @@ +;; jao-emms-random-album.el -- play random albums in emms + +;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + + +(require 'emms) + +(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")) + +(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 +(defun jao-emms-random-album-start () + (interactive) + (setq jao-emms-random-album-p t) + (jao-emms-random-album-next)) + +(defun jao-emms-random-album-stop () + (interactive) + (setq jao-emms-random-album-p nil) + (emms-stop)) + +(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"))) + +(defun jao-emms-random-album-next () + (interactive) + (let ((buffer (emms-browser-get-buffer))) + (save-excursion + (if buffer (set-buffer buffer) (emms-browser)) + (ignore-errors (emms-browser-clear-playlist)) + (emms-browse-by-album) + (jao-emms-goto-random-album) + (emms-browser-add-tracks-and-play) + (jao-osd-cat 'emms + (format "Next album %s" + (substring-no-properties (thing-at-point 'line) + 0 -1))) + (emms-browser-bury-buffer)))) + +(defun jao-emms-random-album-reset () + (interactive) + (setq jao-emms-random-lines nil) + (jao-emms-random-lines-save)) + +(defun jao-emms-random-album-setup () + (setq emms-player-next-function 'jao-emms-next-noerror)) + + +(provide 'jao-emms-random-album) +;;; jao-emms-random-album.el ends here diff --git a/emms/jao-emms.el b/emms/jao-emms.el new file mode 100644 index 0000000..53b3513 --- /dev/null +++ b/emms/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 <jao@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(defgroup jao-emms nil "Emms extensions" :group 'emms) + + +(provide 'jao-emms) +;;; jao-emms.el ends here diff --git a/emms/leoslyrics.py b/emms/leoslyrics.py new file mode 100755 index 0000000..5e4f8c8 --- /dev/null +++ b/emms/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/emms/lyricwiki.rb b/emms/lyricwiki.rb new file mode 100755 index 0000000..db7b970 --- /dev/null +++ b/emms/lyricwiki.rb @@ -0,0 +1,51 @@ +#!/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 =~ /<url>\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 =~ /<div class='lyricbox'>\s*(.*?)\s*<!--/im + $stderr.puts "No <div class='lyricbox'> in lyrics page!\n" + exit(1) +end + +if not $1 =~ /^.*<\/div>(.*?)$/im + $stderr.puts "Couldn't remove leading XML tags in lyricbox!\n" + exit(1) +end + +puts CGI::unescapeHTML($1.gsub(/<br \/>/, "\n")) diff --git a/net/jao-frm.el b/net/jao-frm.el new file mode 100644 index 0000000..1635f00 --- /dev/null +++ b/net/jao-frm.el @@ -0,0 +1,214 @@ +;;; jao-frm.el --- use frm to show mailbox + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: mail + +;; 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: + +;; Little hack to see the contents of your mailbox using GNU mailutils' +;; `frm' program. +;; +;; Just put (require 'jao-frm) in your .emacs, and M-x jao-frm will pop up a +;; new window with your mailbox contents (from and subject) as +;; printed by frm. In this buffer, use `n' and `p' to move, `q' to close +;; the window. `g' will call Gnus. +;; + +;;; Code: + +;;;; Customisation: + +(defgroup jao-frm nil + "Frm-base mailbox checker" + :prefix "jao-frm-") + +(defcustom jao-frm-exec-path "frm" + "frm executable path" + :group 'jao-frm + :type 'file) + +(defcustom jao-frm-mail-command 'gnus + "Emacs function to invoke when `g' is pressed on an frm buffer." + :group 'jao-frm + :type 'symbol) + +(defcustom jao-frm-mailboxes nil + "List of mailboxes to check, or directory containing them." + :group 'jao-frm + :type '(choice directory (repeat file))) + +(defface jao-frm-mailno-face '((t (:foreground "dark slate grey"))) + "Face for the mail number." + :group 'jao-frm) + +(defface jao-frm-from-face '((t (:foreground "slate grey"))) + "Face for From: header." + :group 'jao-frm) + +(defface jao-frm-subject-face '((t (:foreground "slate blue"))) + "Face for Subject: header." + :group 'jao-frm) + +(defface jao-frm-mailbox-face '((t (:bold t :weight bold))) + "Face for mailbox name." + :group 'jao-frm) + +;;;; Mode: + +(defvar jao-frm-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [?q] 'jao-frm-delete-window) + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?g] jao-frm-mail-command) + (define-key map [(control k)] 'jao-frm-delete-message) + map)) + +(setq jao-frm-font-lock-keywords + '(("^[^ :]+:" . 'jao-frm-mailbox-face) + ("^\\([ 0-9]+\\):\t+\\([^\t]+\\)\t+\\([^\n]+$\\)" + (1 'jao-frm-mailno-face) + (2 'jao-frm-from-face) + (3 'jao-frm-subject-face)))) + +(defvar jao-frm-mode-syntax-table + (let ((st (make-syntax-table))) + st)) + +(defun jao-frm-mode () + "Major mode for displaying frm output." + (interactive) + (kill-all-local-variables) + (buffer-disable-undo) + (use-local-map jao-frm-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(jao-frm-font-lock-keywords)) + (set (make-local-variable 'truncate-lines) t) + (set (make-local-variable 'kill-whole-line) t) + (set (make-local-variable 'next-line-add-newlines) nil) + (setq major-mode 'jao-frm-mode) + (setq mode-name "frm") + (toggle-read-only 1) + (goto-char 1)) + +;;;; Mode commands: +(defvar jao-frm-last-config nil) + +(defun jao-frm-delete-window () + "Delete frm window and restore last win config" + (interactive) + (if (and (consp jao-frm-last-config) + (window-configuration-p (car jao-frm-last-config))) + (progn + (set-window-configuration (car jao-frm-last-config)) + (goto-char (cadr jao-frm-last-config)) + (setq jao-frm-last-config nil)) + (bury-buffer))) + +(defun jao-frm-delete-message () + "Delete message at point" + (interactive) + (when (eq (current-buffer) (get-buffer "*frm*")) + (beginning-of-line) + (when (search-forward-regexp "^ +\\([0-9]+\\):" nil t) + (let ((mn (string-to-number (match-string 1)))) + (when (y-or-n-p (format "Delete message number %d? " mn)) + (toggle-read-only -1) + (shell-command (format "echo 'd %d'|mail" mn) t) + (jao-frm) + (when (= (point-max) (point-min)) + (jao-frm-delete-window) + (message "Mailbox is empty"))))))) + +;;;; Activate frm: +(defun jao-frm-mbox-mails (mbox) + (let ((no (ignore-errors + (substring + (shell-command-to-string (format "frm %s|wc -l" mbox)) 0 -1)))) + (if (stringp no) (string-to-number no) 0))) + +(defun jao-frm-mail-number () + (let ((no 0)) + (dolist (b (jao-frm-mboxes) no) (setq no (+ no (jao-frm-mbox-mails b)))))) + +(defun jao-frm-default-count-formatter (m n) + (format "%s: %s" (file-name-sans-extension (file-name-nondirectory m)) n)) + +(defun jao-frm-mail-counts (fmt) + (let ((fmt (or fmt 'jao-frm-default-count-formatter))) + (remove nil + (mapcar (lambda (m) + (let ((n (jao-frm-mbox-mails m))) + (unless (zerop n) (funcall fmt m n)))) + (jao-frm-mboxes))))) + +(defun jao-frm-display-mailbox (mbox) + (when (not (zerop (jao-frm-mbox-mails mbox))) + (insert (or (file-name-nondirectory mbox) mbox) ":\n\n") + (apply 'call-process + `(,jao-frm-exec-path nil ,(current-buffer) nil + "-n" "-t" ,@(and mbox (list mbox)))) + (newline 2))) + +(defun jao-frm-mboxes () + (cond ((null jao-frm-mailboxes) (list (getenv "MAIL"))) + ((listp jao-frm-mailboxes) jao-frm-mailboxes) + ((stringp jao-frm-mailboxes) + (if (file-directory-p jao-frm-mailboxes) + (directory-files jao-frm-mailboxes t "^[^.]") + (list jao-frm-mailboxes))) + (t (error "Error in mbox specification. Check `jao-frm-mailboxes'")))) + +(defun jao-frm () + "Run frm." + (interactive) + (let ((fbuff (get-buffer-create "*frm*")) + (inhibit-read-only t)) + (if (not (eq fbuff (current-buffer))) + (setq jao-frm-last-config + (list (current-window-configuration) (point-marker)))) + (with-current-buffer fbuff + (delete-region (point-min) (point-max)) + (mapc 'jao-frm-display-mailbox (jao-frm-mboxes)) + (unless (eq major-mode 'jao-frm-mode) + (jao-frm-mode)) + (goto-char (point-min)) + (if (= (point-min) (point-max)) + (message "Mailbox is empty.") + (pop-to-buffer fbuff)) + (when (and (boundp 'display-time-mode) display-time-mode) + (display-time-update))))) + +(defun jao-frm-show-mail-numbers () + (interactive) + (let ((counts (jao-frm-mail-counts nil))) + (message (if counts (mapconcat 'identity counts ", ") "No mail")))) + +(defun jao-frm-mail-string () + (let ((counts (jao-frm-mail-counts + (lambda (m n) + (let ((m (substring (file-name-nondirectory m) 0 1))) + (format "%s %s" m n)))))) + (mapconcat 'identity counts " "))) + +(provide 'jao-frm) + +;;; jao-frm.el ends here diff --git a/net/jao-w3m-session.el b/net/jao-w3m-session.el new file mode 100644 index 0000000..7b8979b --- /dev/null +++ b/net/jao-w3m-session.el @@ -0,0 +1,410 @@ +;;; w3m-session.el --- Persistent emacs-w3m sessions + +;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009 Jose A Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@member.fsf.org> +;; Version: 0.3.6 +;; Keywords: hypermedia, w3m, WWW + +;; 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: + +;; INTRODUCTION: +;; +;; jao-w3m-session provides persistent emacs-w3m browsing sessions. When +;; quitting w3m (or, if you request it, at any other time while using +;; it) you can save the current w3m session (that is, the set of open +;; tabs and the URLs they're visiting). Upon restarting emacs-w3m +;; (possibly after restarting Emacs itself) you'll have the possibity +;; of recovering the saved session (that is, of re-opening the saved +;; tabs and URLs). You also have at your disposal a command to recover +;; the saved session at any other time. +;; +;; INSTALLATION: +;; +;; Just put this file somewhere on your Emacs load path and add the +;; following line to your .emacs file: +;; +;; (require 'jao-w3m-session) +;; +;; After restarting Emacs (or evaluating the form above), each time +;; you start emacs-w3m with 'w3m' you'll get a prompt asking whether +;; your last browsing session should be loaded. Likewise, when +;; quitting the browser, you'll have the possibility of saving your +;; current session (overwriting the previous one). +;; +;; In addition, two new interactive functions are defined: +;; +;; jao-w3m-session-load -- load the last stored session +;; jao-w3m-session-save -- save the current session +;; +;; These functions can be invoked at any time while running emacs-w3m. +;; Optionally, you can bind them to key shortcuts with the proper +;; variations of the following elisp magic in your .emacs: +;; (defun w3m-add-keys () +;; (define-key w3m-mode-map "S" 'jao-w3m-session-save) +;; (define-key w3m-mode-map "L" 'jao-w3m-session-load)) +;; (add-hook 'w3m-mode-hook 'w3m-add-keys) +;; +;; CUSTOMIZATION: +;; +;; A new customization group, jao-w3m-session, is available. There you can +;; customize the following variables: +;; +;; jao-w3m-session-load-always -- if t, `jao-w3m-session-load' will *not* ask +;; for confirmation (default nil) +;; jao-w3m-session-save-always -- if t, `jao-w3m-session-save' will *not* ask +;; for confirmation (default nil) +;; jao-w3m-session-show-titles -- if t, the load prompt will list the +;; session URL titles (default t) +;; jao-w3m-session-duplicate-tabs -- what to do when loading a session that +;; contains a URL already open +;; jao-w3m-session-file -- the file where w3m session info +;; is stored (default "~/.jao-w3m-session") +;; jao-w3m-session-autosave-period -- the period, in seconds, for automatic +;; session backup file updating. +;; +;; +;; You can also customize them in your .emacs file, to wit: +;; +;; (setq jao-w3m-session-file "~/.emacs.d/jao-w3m-session") +;; (setq jao-w3m-session-save-always nil) +;; (setq jao-w3m-session-load-always nil) +;; (setq jao-w3m-session-show-titles t) +;; (setq jao-w3m-session-duplicate-tabs 'ask) ; 'never, 'always, 'ask +;; +;; HISTORY: +;; +;; Version 0.3.7 : +;; +;; - `jao-w3m-session-deactivate-builtin-sessions', to do what it +;; says. +;; +;; Version 0.3.6 (Sat Apr 19, 2008): +;; +;; - w3m-session -> jao-w3m-session to avoid collisions with +;; emacs-w3m's session manager. +;; +;; Version 0.3.5 (Sun Jan 14, 2007): +;; +;; - automatic session backup every `jao-w3m-session-autosave-period' +;; seconds. +;; +;; Version 0.3.4 (Wed Jul 19, 2006): +;; +;; - save session file on quitting Emacs (without using +;; desktop.el) +;; +;; Version 0.3.3 (Thu Jun 8, 2006): +;; +;; - save session file with pretty print. +;; - handle correctly multiple emacs-w3m (re)starts during a +;; single emacs session. +;; - save URLs in hexified form to allow & in them. +;; - code cleanup. +;; +;; Version 0.3.2 (Mon Sep 29, 2003): +;; +;; - bug fix: when searching or going to home/bookmarks/etc, +;; keep the current tab's focus. +;; +;; Version 0.3.1 (Tue Aug 26, 2003): +;; +;; - type of `jao-w3m-session-file' set to 'file' in customisation +;; buffer. +;; - bug fix: syntax error due to a typo in `jao-w3m-session-file' +;; +;; Version 0.3 (Mon Aug 25, 2003): +;; +;; - the load session tab lists the titles of the session's pages +;; (customizable via 'jao-w3m-session-show-titles'). +;; - the duplicated tab prompt displays also the URL's title. +;; - bug fix: active tab in session now is correctly saved. +;; +;; Version 0.2 (Fri Aug 22, 2003): +;; +;; - the session info now includes the active tab, which gets +;; displayed when the session is reloaded. +;; - when reloading a session in a running emacs-w3m, if the +;; session contains a URL that is already being displayed by the +;; browser, the tab can be reused or duplicated (customizable +;; via `jao-w3m-session-duplicate-tabs'). +;; +;; Version 0.1 (Wed Aug 20, 2003) -- Initial release. +;; + + +;;; Code: + +;;; Dependencies: + +(require 'w3m) +(require 'advice) +(require 'url-util) + +;;; Custom variables: + +(defgroup jao-w3m-session nil + "w3m - session saving in w3m." + :group 'w3m + :prefix "jao-w3m-session-") + +(defcustom jao-w3m-session-save-always nil + "If on, always save w3m session without asking." + :group 'jao-w3m-session + :type 'boolean) + +(defcustom jao-w3m-session-load-always nil + "If on, always load w3m session without asking." + :group 'jao-w3m-session + :type 'boolean) + +(defcustom jao-w3m-session-show-titles t + "If on, show URL titles in the load prompt." + :group 'jao-w3m-session + :type 'boolean) + +(defcustom jao-w3m-session-duplicate-tabs 'never + "How to treat session URL already being visited. + +When loading a session with `jao-w3m-session-load', if one of the URLs in +the session is already displayed in a w3m tab, jao-w3m-session can: +- `never' create a new tab (just reload it), or +- `always' duplicate the URL in a new tab, or +- `ask' the user what to do." + :group 'jao-w3m-session + :type '(choice (const :value never) + (const :value always) + (const :value ask))) + +(defcustom jao-w3m-session-file "~/.jao-w3m-session" + "File to save the w3m session data." + :group 'jao-w3m-session + :type 'file) + +(defvar jao-w3m-session-autosave-period 180 + "A backup of the current session is saved with this period (in secs).") + +(defvar jao-w3m-url-filters nil "URL filters.") + +;;; Interactive functions: + +(defun jao-w3m-session-save () + "Save the current w3m session." + (interactive) + (when (and (w3m-alive-p) + (or jao-w3m-session-save-always + (y-or-n-p "Save current w3m session? "))) + (jao-w3m-session-current-to-file) + (jao-w3m-session--restart--autosave))) + +(defun jao-w3m-session-load () + "Load last stored session into w3m." + (interactive) + (let ((s (jao-w3m-session-load-aux))) + (when s + (jao-w3m-session--restart--autosave) + (let* ((urls (jao-w3m-session-url s)) + (offset (jao-w3m-session-offset s)) + (buffers (unless (equal jao-w3m-session-duplicate-tabs 'always) + (jao-w3m-session-find-duplicated urls)))) + (w3m-goto-url-new-session urls t) + (when buffers (jao-w3m-session-close-buffers buffers)) + (unless (zerop offset) (w3m-next-buffer offset)))))) + +(defun jao-w3m-session-set-autosave-period (secs) + "Set new value for the period between session backup autosaves." + (interactive "p") + (let ((secs (or secs (read-number "New period (secs): " 0)))) + (when (> secs 0) + (setq jao-w3m-session-autosave-period secs) + (jao-w3m-session--restart--autosave)))) + +(defun jao-w3m-session-deactivate-builtin-sessions () + "Deactivate emacs-w3m's builtin session handling." + (setq w3m-session-deleted-save nil + w3m-session-autosave nil + w3m-session-deleted-keep-number 0 + w3m-session-crash-recovery nil)) + +;;; Internals: + +;;;; advice w3m to use session management + +(defadvice w3m (before jao-load-session activate) + "Optionally load last w3m session on startup." + (interactive + (let ((s (jao-w3m-session-load-aux))) + (list (or (and s (jao-w3m-session-url s)) w3m-home-page) t t)))) + +(defadvice w3m (after jao-select-tab activate) + "Goto the saved focused tab" + (interactive) + (let ((offset (jao-w3m-session-offset))) + (unless (zerop offset) + (w3m-next-buffer offset)) + (ad-deactivate 'w3m))) + +(defadvice w3m-quit (before jao-save-session activate) + "Save session before quitting." + (interactive) + (jao-w3m-session-save) + ;; this is a little hack: when quitting a w3m session with a tab + ;; selected other than the first, the frame is not automatically + ;; closed as should be when w3m-pop-up-frames is t: + (switch-to-buffer (car (w3m-list-buffers))) + (ad-activate 'w3m)) + +;;;; save session on exit +(add-to-list 'kill-emacs-query-functions + '(lambda () (jao-w3m-session-save) t)) + + +;;;; auxiliary functions + +(defvar jao-w3m-current-session '(jao-w3m-session 0 nil)) + +(defun jao-w3m-session--filter (url filters) + (cond ((not filters) url) + ((string-match-p (caar filters) url) + (cond ((functionp (cdar filters)) (funcall (cadr filters) url)) + ((stringp (cdar filters)) (cdar filters)))) + (t (jao-w3m-session--filter url (cdr filters))))) + +(defun jao-w3m-session--current-urls () + (let ((urls) + (current-buffer (w3m-alive-p)) + (pos 0) + (count 0)) + (dolist (b (w3m-list-buffers) (list pos (reverse urls))) + (set-buffer b) + (let ((url (jao-w3m-session--filter w3m-current-url jao-w3m-url-filters))) + (when url + (when (eq b current-buffer) (setq pos count)) + (setq count (1+ count)) + (push (cons (url-hexify-string url) (w3m-buffer-title b)) urls)))))) + +(defun jao-w3m-session-url (&optional s) + (let ((s (or s jao-w3m-current-session))) + (concat "group:" + (mapconcat 'car (nth 2 s) "&")))) + +(defun jao-w3m-session-offset (&optional s) + (let ((s (or s jao-w3m-current-session))) + (nth 1 s))) + +(defun jao-w3m-session-titles (&optional s) + (let ((s (or s jao-w3m-current-session))) + (mapcar 'cdr (nth 2 s)))) + +(defun jao-w3m-session-current (&optional s) + (save-current-buffer + (setq jao-w3m-current-session + (or s (cons 'jao-w3m-session (jao-w3m-session--current-urls)))))) + +(defun jao-w3m-session-current-url () + (when (w3m-alive-p) + (save-current-buffer + (concat "group:" + (mapconcat (lambda (b) (set-buffer b) w3m-current-url) + (w3m-list-buffers) "&"))))) + +(defun jao-w3m-session-find-duplicated (urls) + (when (w3m-alive-p) + (save-current-buffer + (let* ((duplicate-p + (lambda (b) + (y-or-n-p + (format "'%s' (%s) is already open. Duplicate tab? " + (w3m-buffer-title b) w3m-current-url)))) + (test-b + (lambda (b) + (set-buffer b) + (if (and + (string-match (regexp-quote w3m-current-url) urls) + (or (equal jao-w3m-session-duplicate-tabs 'never) + (not (funcall duplicate-p b)))) + b 'not))) + (buffers (mapcar test-b (w3m-list-buffers)))) + (delete 'not buffers))))) + +(defun jao-w3m-session-close-buffers (buffers) + (save-current-buffer + (mapc 'kill-buffer buffers))) + +(defun jao-w3m-session-load-aux () + (let ((new-session (jao-w3m-session-from-file + (expand-file-name jao-w3m-session-file)))) + (if (and new-session + (or jao-w3m-session-load-always + (y-or-n-p + (if jao-w3m-session-show-titles + (format "Load last w3m session %S? " + (jao-w3m-session-titles new-session)) + "Load last w3m session? ")))) + (jao-w3m-session-current new-session) + nil))) + +(defun jao-w3m-session-from-file (fname) + (let ((fname (jao-w3m-session--check--backup fname))) + (if (file-readable-p fname) + (with-temp-buffer + (insert-file-contents fname) + (goto-char (point-min)) + (let ((sexp (read (current-buffer)))) + (and (equal 'jao-w3m-session (car sexp)) sexp))) + nil))) + +(defsubst jao-w3m-session-current-to-file () + (jao-w3m-session--to--file jao-w3m-session-file)) + +(defun jao-w3m-session--to--file (filename &optional is-auto) + (require 'pp) + (let ((msg (if is-auto (current-message)))) + (with-temp-buffer + (insert ";;;; File generated by jao-w3m-session. DO NOT EDIT!\n") + (pp (jao-w3m-session-current) (current-buffer)) + (insert "\n" ";;;; End of " + (file-name-nondirectory jao-w3m-session-file) "\n") + (write-region (point-min) (point-max) (expand-file-name filename))) + (if is-auto (message msg)))) + +(defvar jao-w3m-session--timer nil) + +(defun jao-w3m-session--backup-name (fname) + (concat (expand-file-name fname) ".bak")) + +(defun jao-w3m-session--check--backup (fname) + (let ((bfname (jao-w3m-session--backup-name fname))) + (if (and (file-newer-than-file-p bfname fname) + (y-or-n-p "A newer autosaved session exists. Use it? ")) + bfname + fname))) + +(defun jao-w3m-session--restart--autosave () + (when (> jao-w3m-session-autosave-period 0) + (if jao-w3m-session--timer (cancel-timer jao-w3m-session--timer)) + (setq jao-w3m-session--timer + (run-at-time jao-w3m-session-autosave-period + jao-w3m-session-autosave-period + 'jao-w3m-session--to--file + (jao-w3m-session--backup-name jao-w3m-session-file) + t)))) + +(provide 'jao-w3m-session) + +;;; jao-w3m-session.el ends here diff --git a/net/jao-weather.el b/net/jao-weather.el new file mode 100644 index 0000000..6760eb1 --- /dev/null +++ b/net/jao-weather.el @@ -0,0 +1,219 @@ +;; Based on code by Thierry Volpiatto +;; (http://mercurial.intuxication.org/hg/xml-weather) + +(require 'xml) +(require 'derived) + + +;;; config: +(defvar jao-weather-format-id-url + "http://xoap.weather.com/search/search?where=%s") + +(defvar jao-weather-format-xml-from-id-url ; id, unit=m,day-forecast=5,login,key + "http://xoap.weather.com/weather/local/%s?cc=*&unit=%s&dayf=%s&prod=xoap&par=%s&key=%s") + +(defvar jao-weather-unit "m" + "*m mean metric, you will have wind speed in km/h, temperature in °C and so on.") + +(defvar jao-weather-login nil) +(defvar jao-weather-key nil) + +(defvar jao-weather-day-forecast-num 5 + "*Number of days for forecast; Maximum 5.") + +(defvar jao-weather-default-id "SPXX0015") + +(defvar jao-weather-timer-delay 3600) + +(defvar jao-weather-last-data nil) + + +;;; access: +(defun jao-weather-authentify () + "Authentify user from .authinfo file. +You have to setup correctly `auth-sources' to make this function +finding the path of your .authinfo file that is normally ~/.authinfo. +Entry in .authinfo should be: +machine xoap.weather.com port http login xxxxx password xxxxxx" + (let ((auth (auth-source-user-or-password '("login" "password") + "xoap.weather.com" + "http"))) + (setq jao-weather-login (car auth) + jao-weather-key (cadr auth)))) + +(defun jao-weather--url (id) + (unless (and jao-weather-login jao-weather-key) + (jao-weather-authentify)) + (format jao-weather-format-xml-from-id-url + (or id jao-weather-default-id) + jao-weather-unit + (min jao-weather-day-forecast-num 5) + jao-weather-login + jao-weather-key)) + +(defvar jao-weather-hook nil) + +;; http://xoap.weather.com/weather/local/[locid] +;; Replace the [locid], of course, with the location ID obtained in the previous step. +;; Appended to this URL is a mix of other parameters, +;; some required and some optional. A typical example might be: +;; http://xoap.weather.com/weather/local/NLXX0002?cc=*&dayf=5&prod=xoap&par=[partner id]&key=[license key] +(defun jao-weather--get-info-async (&optional id) + (let ((url (jao-weather--url id)) + (url-show-status nil)) + (url-retrieve url (lambda (res) + (when (not res) + (let ((data (jao-weather-get-alist))) + (when data + (setq jao-weather-last-data data) + (run-hooks 'jao-weather-hook)))) + (kill-buffer (current-buffer)))))) + +(defun jao-weather--get-info-now (&optional id) + (let* ((url (jao-weather--url id)) + (buffer (url-retrieve-synchronously url)) + (data (and buffer + (with-current-buffer buffer + (jao-weather-get-alist))))) + (when buffer (kill-buffer buffer)) + (when data + (setq jao-weather-last-data data) + (run-hooks 'jao-weather-hook)) + data)) + + +;;; formatting: +(defun jao-weather--flist (c fs) + (when c + (let (result) + (dolist (f fs result) + (let ((v (caddr (assoc (cadr f) c)))) + (when (and (stringp v) (not (string-equal v "N/A"))) + (push (cons (car f) v) result))))))) + +(defun jao-weather--parse-cc (cc) + (append (jao-weather--flist cc '((:date lsup) + (:observatory obst) + (:temperature tmp) + (:condition t) + (:pressure r))) + (jao-weather--flist (assoc 'wind cc) '((:windir d) + (:wind-tilt t) + (:gust gust))))) + +(defun jao-weather--parse-location (loc) + (jao-weather--flist loc '((:city dnam) + (:time tm) + (:latitude lat) + (:longitude lon) + (:sunrise sunr) + (:sunset suns)))) + +(defun jao-weather--parse-day (d) + (let ((p2 (assoc 'part + (remove (assoc 'part (cdr d)) + (cdr d)))) + (wday (or (cdr (assoc 't (cadr d))) "day"))) + `(,(cdr (assoc 'dt (cadr d))) + (:weekday . ,wday) + (:weekday-abbrev . ,(substring wday 0 3)) + ,@(jao-weather--flist (cdr d) '((:max hi) + (:min low) + (:sunrise sunr) + (:sunset suns) + (:humidity hmid))) + ,@(jao-weather--flist (assoc 'wind (assoc 'part (cdr d))) + '((:wind-dir 't) (:wind-speed 's))) + ,@(jao-weather--flist (assoc 'wind p2) '((:night-wind-dir wea) + (:night-wind-speed s))) + ,@(jao-weather--flist p2 + '((:night-condition t) (:night-humidity hmid)))))) + +(defun jao-weather-get-alist () + (let* ((pxml (car (xml-parse-region (point-min) (point-max)))) + (loc (car (xml-get-children pxml 'loc))) + (cc (car (xml-get-children pxml 'cc))) + (dayf (xml-get-children pxml 'dayf)) + (dayfs (xml-get-children (car dayf) 'day)) + (today (append (jao-weather--parse-cc cc) + (jao-weather--parse-location loc))) + (forecast (mapcar 'jao-weather--parse-day dayfs))) + `((today ,@today) (forecast ,@forecast)))) + +(defun jao-weather--format-fields (data fields sep) + (if data + (mapconcat '(lambda (kv) + (let ((v (cdr (assoc (car kv) data)))) + (if (not v) "" + (format (or (cdr kv) "%s") v)))) + fields + sep) + "")) + +(defsubst jao-weather--today-string (fields sep) + (jao-weather--format-fields (cdr (assoc 'today jao-weather-last-data)) + fields sep)) + +(defun jao-weather--forecast-string (n fields sep) + (jao-weather--format-fields (nth n (cdr (assoc 'forecast + jao-weather-last-data))) + fields sep)) + + +;;; update daemon: +(defvar jao-weather--timer nil) +(defun jao-weather-start (&optional delay) + (interactive) + (jao-weather-stop) + (setq jao-weather--timer + (run-with-timer (or delay 0) + jao-weather-timer-delay + 'jao-weather--get-info-async))) + +(defun jao-weather-stop () + (interactive) + (when jao-weather--timer + (cancel-timer jao-weather--timer) + (setq jao-weather--timer nil))) + + +;;; today +(defun jao-weather-today-msg (&optional arg) + (interactive "p") + (when (> arg 4) (jao-weather--get-info-now)) + (if (= 4 arg) (jao-weather-forecast-msg) + (message "%s" (jao-weather--today-string '((:temperature . " %s°C") + (:condition . "(%s)") + (:sunrise . "↑ %s") + (:sunset . "↓ %s") + (:date . "[%s]")) + " ")))) + +(defun jao-weather-forecast-msg (&optional arg) + (interactive "P") + (when arg (jao-weather--get-info-now)) + (message " %s" (mapconcat + (lambda (n) + (jao-weather--forecast-string n + '((:weekday-abbrev . "%s ") + (:max . "%s°/") + (:min . "%s°") + (:condition . ", %s") + (:night-condition . ", %s")) + "")) + '(1 2 3 4) " | "))) + +(defun jao-weather-temperature () + (string-to-number (jao-weather--today-string '((:temperature)) ""))) + + +(defun jao-weather-temperature* (&optional sep) + (concat (jao-weather--today-string '((:temperature . "%s°")) "") + (or sep " ") + (jao-weather--forecast-string 1 + '((:max . "%s°/") (:min . "%s°") + (:night-condition . " %s")) + ""))) + +;; Provide +(provide 'jao-weather) diff --git a/org/jao-org-gnus.el b/org/jao-org-gnus.el new file mode 100644 index 0000000..8891e20 --- /dev/null +++ b/org/jao-org-gnus.el @@ -0,0 +1,72 @@ +;; Support for saving Gnus messages by Message-ID +(defun mde-org-gnus-save-by-mid () + (when (memq major-mode '(gnus-summary-mode gnus-article-mode)) + (when (eq major-mode 'gnus-article-mode) + (gnus-article-show-summary)) + (let* ((group gnus-newsgroup-name) + (method (gnus-find-method-for-group group))) + (when (eq 'nnml (car method)) + (let* ((article (gnus-summary-article-number)) + (header (gnus-summary-article-header article)) + (from (mail-header-from header)) + (message-id + (save-match-data + (let ((mid (mail-header-id header))) + (if (string-match "<\\(.*\\)>" mid) + (match-string 1 mid) + (error "Malformed message ID header %s" mid))))) + (date (mail-header-date header)) + (subject (gnus-summary-subject-string))) + (org-store-link-props :type "mid" :from from :subject subject + :message-id message-id :group group + :link (org-make-link "mid:" message-id)) + (apply 'org-store-link-props + :description (org-email-link-description) + org-store-link-plist) + t))))) + +(defvar mde-mid-resolve-methods '() + "List of methods to try when resolving message ID's. For Gnus, +it is a cons of 'gnus and the select (type and name).") +(setq mde-mid-resolve-methods + '((gnus nnml ""))) + +(defvar mde-org-gnus-open-level 1 + "Level at which Gnus is started when opening a link") +(defun mde-org-gnus-open-message-link (msgid) + "Open a message link with Gnus" + (require 'gnus) + (require 'org-table) + (catch 'method-found + (message "[MID linker] Resolving %s" msgid) + (dolist (method mde-mid-resolve-methods) + (cond + ((and (eq (car method) 'gnus) + (eq (cadr method) 'nnml)) + (funcall (cdr (assq 'gnus org-link-frame-setup)) + mde-org-gnus-open-level) + (when gnus-other-frame-object + (select-frame gnus-other-frame-object)) + (let* ((msg-info (nnml-find-group-number + (concat "<" msgid ">") + (cdr method))) + (group (and msg-info (car msg-info))) + (message (and msg-info (cdr msg-info))) + (qname (and group + (if (gnus-methods-equal-p + (cdr method) + gnus-select-method) + group + (gnus-group-full-name group (cdr method)))))) + (when msg-info + (gnus-summary-read-group qname nil t) + (gnus-summary-goto-article message nil t)) + (throw 'method-found t))) + (t (error "Unknown link type")))))) + +(eval-after-load 'org-gnus + '(progn + (add-to-list 'org-store-link-functions 'mde-org-gnus-save-by-mid) + (org-add-link-type "mid" 'mde-org-gnus-open-message-link))) + +(provide 'jao-org-gnus) diff --git a/org/jao-org-links.el b/org/jao-org-links.el new file mode 100644 index 0000000..ca57f69 --- /dev/null +++ b/org/jao-org-links.el @@ -0,0 +1,29 @@ +(require 'org) + +;; doc links +(defvar jao-org--sink-dir "./") +(org-add-link-type "doc" 'jao-org-follow-doc 'identity) +(defun jao-org-follow-doc (link) + (let ((dest-path (concat "./doc/" + (and (boundp 'docs-dir) + (concat (symbol-name docs-dir) "/")) + link))) + (when (not (file-exists-p dest-path)) + (let* ((sink-file (expand-file-name link jao-org--sink-dir)) + (real-file (if (file-exists-p sink-file) sink-file + (read-file-name "Import file: " + jao-org--sink-dir link link)))) + (shell-command (format "mv %s %s" real-file dest-path)))) + (browse-url (format "file://%s" (expand-file-name dest-path))))) + +(defsubst jao-org--title->file (title) + (concat (mapconcat 'downcase (split-string title nil t) "-") ".pdf")) + +(defun jao-org-insert-doc (title) + (interactive "sDocument title: ") + (insert (format "[[doc:%s][%s]]" (jao-org--title->file title) title))) + +(defun jao-org-links-setup (sink-dir) + (setq jao-org--sink-dir (file-name-as-directory sink-dir))) + +(provide 'jao-org-links)
\ No newline at end of file diff --git a/org/jao-org-popup.el b/org/jao-org-popup.el new file mode 100644 index 0000000..eb5b24d --- /dev/null +++ b/org/jao-org-popup.el @@ -0,0 +1,31 @@ +;;; frame popups +;; http://metajack.im/2008/12/30/gtd-capture-with-emacs-orgmode/ +(defsubst jao-remember--frame-p () + (equal "*Remember*" (frame-parameter nil 'name))) + +(defadvice remember-finalize (after delete-remember-frame activate) + "Advise remember-finalize to close the frame if it is the remember frame" + (when (jao-remember--frame-p) (delete-frame))) + +(defadvice remember-destroy (after delete-remember-frame activate) + "Advise remember-destroy to close the frame if it is the remember frame" + (when (jao-remember--frame-p) (delete-frame))) + +;; make the frame contain a single window. by default org-remember +;; splits the window. +(defun jao-remember--delete-other-windows () + (when (jao-remember--frame-p) (delete-other-windows))) + +(add-hook 'remember-mode-hook 'jao-remember--delete-other-windows) + +(defun make-remember-frame () + "Create a new frame and run org-remember" + (interactive) + (make-frame-on-display (getenv "DISPLAY") + '((name . "*Remember*") + (width . 80) + (height . 10))) + (select-frame-by-name "*Remember*") + (org-remember nil ?x)) + +(provide 'jao-org-popup)
\ No newline at end of file diff --git a/org/jao-org-tags.el b/org/jao-org-tags.el new file mode 100644 index 0000000..b00276d --- /dev/null +++ b/org/jao-org-tags.el @@ -0,0 +1,61 @@ +;; lifted from http://orgmode.org/worg/org-hacks.php + +(require 'org) + +(defvar ba/org-adjust-tags-column nil) + +(defun ba/org-adjust-tags-column-reset-tags () + "In org-mode buffers it will reset tag position according to +`org-tags-column'." + (when (and + (not (string= (buffer-name) "*Remember*")) + (eql major-mode 'org-mode)) + (let ((b-m-p (buffer-modified-p))) + (condition-case nil + (save-excursion + (goto-char (point-min)) + (command-execute 'outline-next-visible-heading) + ;; disable (message) that org-set-tags generates + (flet ((message (&rest ignored) nil)) + (org-set-tags 1 t)) + (set-buffer-modified-p b-m-p)) + (error nil))))) + +(defun ba/org-adjust-tags-column-now () + "Right-adjust `org-tags-column' value, then reset tag position." + (set (make-local-variable 'org-tags-column) + (- (- (window-width) 3))) + (ba/org-adjust-tags-column-reset-tags)) + +(defun ba/org-adjust-tags-column-maybe () + "If `ba/org-adjust-tags-column' is set to non-nil, adjust tags." + (when ba/org-adjust-tags-column + (ba/org-adjust-tags-column-now))) + +(defun ba/org-adjust-tags-column-before-save () + "Tags need to be left-adjusted when saving." + (when ba/org-adjust-tags-column + (setq org-tags-column 1) + (ba/org-adjust-tags-column-reset-tags))) + +(defun ba/org-adjust-tags-column-after-save () + "Revert left-adjusted tag position done by before-save hook." + (ba/org-adjust-tags-column-maybe) + (set-buffer-modified-p nil)) + +;; automatically align tags on right-hand side +(defun jao-org-tags-setup () + (setq ba/org-adjust-tags-column t) + (add-hook 'window-configuration-change-hook + 'ba/org-adjust-tags-column-maybe) + (add-hook 'before-save-hook 'ba/org-adjust-tags-column-before-save) + (add-hook 'after-save-hook 'ba/org-adjust-tags-column-after-save)) + +(defun jao-org-tags-uninstall () + (setq ba/org-adjust-tags-column nil) + (remove-hook 'window-configuration-change-hook + 'ba/org-adjust-tags-column-maybe) + (remove-hook 'before-save-hook 'ba/org-adjust-tags-column-before-save) + (remove-hook 'after-save-hook 'ba/org-adjust-tags-column-after-save)) + +(provide 'jao-org-tags) diff --git a/org/jao-org-utils.el b/org/jao-org-utils.el new file mode 100644 index 0000000..535e8f4 --- /dev/null +++ b/org/jao-org-utils.el @@ -0,0 +1,37 @@ +(require 'org) + +;;; links +(defun jao-org-link-at-point () + (when (thing-at-point-looking-at "\\[\\[\\([^]]+\\)\\]\\[[^]]+\\]\\]") + (match-string-no-properties 1))) + +(defun jao-org-copy-link-at-point () + (interactive) + (message "%s" (or (jao-org-link-at-point) "No link at point"))) + +;;; eldoc +(defun jao-org-eldoc--hook () + (set (make-local-variable 'eldoc-documentation-function) + 'jao-org-link-at-point) + (eldoc-mode)) + +(defun jao-org-utils-eldoc-setup () + (add-hook 'org-mode-hook 'jao-org-eldoc--hook)) + +;;; play fair with saveplace +(defun jao-org--show-if-hidden () + (when (outline-invisible-p) + (save-excursion + (outline-previous-visible-heading 1) + (org-show-subtree)))) + +;;; verifying org refile targets +(defun jao-org--refile-target-verify () + (not (looking-at-p ".*\\[\\[.+$"))) + +(defun jao-org-utils-setup () + (setq org-refile-target-verify-function 'jao-org--refile-target-verify) + (add-hook 'org-mode-hook 'jao-org--show-if-hidden t)) + + +(provide 'jao-org-utils) diff --git a/prog/jao-cabal.el b/prog/jao-cabal.el new file mode 100644 index 0000000..699fa1b --- /dev/null +++ b/prog/jao-cabal.el @@ -0,0 +1,22 @@ +(require 'jao-dominating-file) + +(defun jao-haskell-locate-cabal-file () + (jao-locate-dominating-file ".+\\.cabal")) + +(eval-after-load 'haskell-mode + '(add-hook 'haskell-mode-hook + (lambda () + (set (make-local-variable 'compile-command) "cabal build")))) + +(defun jao-haskell-cabal-build () + (interactive) + (let ((cabal-file (jao-haskell-locate-cabal-file))) + (unless cabal-file + (error "Couldn't find associated cabal file")) + (let ((default-directory (file-name-directory cabal-file))) + (call-interactively 'compile)))) + +;;(eval-after-load 'haskell-mode +;; '(define-key haskell-mode-map [?\C-c ?c] 'jao-haskell-cabal-build)) + +(provide 'jao-cabal) diff --git a/prog/jao-dominating-file.el b/prog/jao-dominating-file.el new file mode 100644 index 0000000..f845abc --- /dev/null +++ b/prog/jao-dominating-file.el @@ -0,0 +1,34 @@ +(defun jao-locate-dominating-files (regexp &optional file) + "Look up the directory hierarchy from FILE for a file matching REGEXP. + Stop at the first parent where a matching file is found and return the list + of files that that match in this directory." + (catch 'found + (let ((dir (file-name-as-directory (or file (buffer-file-name)))) + files) + (while (and dir + (not (string-match locate-dominating-stop-dir-regexp + dir))) + (if (setq files (condition-case nil + (directory-files dir 'full regexp 'nosort) + (error nil))) + (throw 'found files) + (if (equal dir + (setq dir (file-name-directory + (directory-file-name dir)))) + (setq dir nil)))) + nil))) + + +(defun jao-locate-dominating-file (regexp &optional from) + (car (jao-locate-dominating-files regexp from))) + +(defun jao-relative-path (regexp &optional from) + (let* ((from (or from (buffer-file-name))) + (dfile (jao-locate-dominating-file regexp from)) + (ddir (and dfile (file-name-directory dfile))) + (fdir (file-name-directory from))) + (when ddir + (and (string-match (format "%s\\(.+\\)/" (regexp-quote ddir)) fdir) + (match-string-no-properties 1 fdir))))) + +(provide 'jao-dominating-file) diff --git a/prog/jao-java-ant.el b/prog/jao-java-ant.el new file mode 100644 index 0000000..27c6420 --- /dev/null +++ b/prog/jao-java-ant.el @@ -0,0 +1,20 @@ +(require 'jao-dominating-file) + +(eval-after-load 'cc-mode + '(progn + (add-hook 'java-mode-hook + (lambda () + (set (make-local-variable 'compile-command) "ant"))) + (define-key java-mode-map "\C-cc" 'jao-java-ant-build))) + +(defun jao-java-ant-build () + (interactive) + (let ((build-file (jao-locate-dominating-file "build\\.xml"))) + (unless build-file + (error "Couldn't find associated build file")) + (let ((default-directory (file-name-directory build-file))) + (call-interactively 'compile)))) + +(provide 'jao-java-ant) + +;; End of jao-java-ant.el diff --git a/skels/all-skels.el b/skels/all-skels.el new file mode 100644 index 0000000..720b08e --- /dev/null +++ b/skels/all-skels.el @@ -0,0 +1,49 @@ +;;; all-skels.el --- Convenience package loading all skels + +;; Copyright (C) 2008 Jose Ortega + +;; Author: Jose Ortega <jao@google.com> +;; Keywords: languages + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Require this file to load all defined skels + +;;; Code: + +(require 'init-skel) + +(require 'cpp-skel) +(require 'cppunit-skel) +(require 'perl-skel) +(require 'readme-skel) +(require 'make-skel) +(require 'caml-skel) +(require 'latex-skel) +(require 'noweb-skel) +(require 'lisp-skel) +(require 's48-skel) +(require 'haskell-skel) +(require 'scsh-skel) +(require 'lisa-skel) +(require 'texinfo-skel) +(require 'python-skel) +(require 'muse-skel) +(require 'asdf-skel) + +(provide 'all-skels) + +;;; all-skels.el ends here diff --git a/skels/asdf-skel.el b/skels/asdf-skel.el new file mode 100644 index 0000000..939eb8d --- /dev/null +++ b/skels/asdf-skel.el @@ -0,0 +1,52 @@ +;;; asdf-skel.el --- Skels for ASDF system definition files + +;; Copyright (C) 2007 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: lisp + +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-asdf-file + "ASDF file header" + "Description: " + '(setq sys (jao-basename)) + '(lisp-mode) + ";; -*- lisp -*- " sys " definition" + \n \n + "(defpackage " sys "-system" \n " (:use :common-lisp :asdf))" + \n \n + "(in-package " sys "-system)" + \n \n + "(defsystem " sys + > \n ":description \"" str "\"" + > \n ":version \"0.1\"" + > \n ":author \"" (user-full-name) " <" user-mail-address ">\"" + > \n ":maintainer \"" (user-full-name) " <" user-mail-address ">\"" + > \n ":licence \"GPL\"" + > \n ":depends-on ()" + > \n ":components ((:file \"packages\")))" + \n \n) + +(add-to-list 'auto-insert-alist '("\\.asd\\'" . jao-skel-asdf-file)) + + +(provide 'asdf-skel) +;;; asdf-skel.el ends here diff --git a/skels/caml-skel.el b/skels/caml-skel.el new file mode 100644 index 0000000..65a5db2 --- /dev/null +++ b/skels/caml-skel.el @@ -0,0 +1,42 @@ +;; Copyright (C) 2004, 2005, 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Caml skeletons + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-caml-file + "OCaml file header" + "Brief description: " + "(* " (file-name-nondirectory (buffer-file-name)) ": " str " *)" + > \n \n + (jao-copyright-line "(* " " *)") + > ?\n + (jao-insert-copyright-file) + "(* $" "Id$ *)" \n \n _) + +(jao-provide-skel "\\.ml[i]?" 'jao-skel-caml-file) + +(provide 'caml-skel) + diff --git a/skels/common-skel.el b/skels/common-skel.el new file mode 100644 index 0000000..97ee301 --- /dev/null +++ b/skels/common-skel.el @@ -0,0 +1,151 @@ +;; common definitions and functions + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Aux functions used in other skeletons + +;;; Code: + +(require 'skeleton) + +(defvar jao-company-name nil + "Company name used in copyright notice") + +(defvar jao-copyright-file ".copyright" + "Basename of the raw (uncommented) copyright file") + +(defvar jao-skels-default-scm nil + "Default SCM system") + +(defun jao-prefix (pref) (or pref (concat comment-start " "))) +(defun jao-suffix (suff) (or suff (concat " " comment-end))) + +(defun jao-copyright-line (prefix &optional suffix omit-cpy) + "Create a brief copyright notice with given PREFIX and SUFFIX" + (concat (jao-prefix prefix) + (if omit-cpy "" "Copyright ") + "(c) " (format-time-string "%Y") " " + (or jao-company-name (user-full-name)) + (jao-suffix suffix) "\n")) + +(defun jao-date-line (prefix &optional suffix) + "Create a start date line" + (concat (jao-prefix prefix) + "Start date: " (format-time-string "%a %b %d, %Y %H:%M") + (jao-suffix suffix) "\n")) + +(defun jao-author-line (prefix &optional suffix) + "Create an author date line" + (concat (jao-prefix prefix) + "Author: " (user-full-name) " <" user-mail-address "> " + (jao-suffix suffix) "\n")) + +(defun jao-cvs-line (prefix &optional suffix) + "Create a CVS ID line" + (concat (jao-prefix prefix) "$" "Id$" (jao-suffix suffix) "\n")) + +(defun jao-svn-line (prefix &optional suffix) + "Create a SVN ID line" + (concat (jao-prefix prefix) "X-SVN: $" "Id$" (jao-suffix suffix) "\n")) + +(defun jao-arch-line (&optional prefix suffix) + "Create an arch-tag line" + (let ((uuid (shell-command-to-string "uuidgen"))) + (concat (jao-prefix prefix) "arch-tag: " uuid (jao-suffix suffix) "\n"))) + +(defun jao-insert-arch-line () + (interactive) + (insert (jao-arch-line))) + +(defun jao-scm-line (prefix &optional suffix) + "Create an scm line" + (let* ((formats '(("arch" . jao-arch-line) + ("svn" . jao-svn-line) + ("cvs" . jao-cvs-line) + ("none" . (lambda (p f) "")))) + (names (mapcar 'car formats)) + (prompt (concat "SCM (" (mapconcat 'identity names ", ") "): ")) + (sel (or jao-skels-default-scm + (completing-read prompt formats nil 1))) + (fun (cdr (assoc sel formats)))) + (when fun (concat (funcall fun prefix suffix))))) + +(defun jao-c&co-line (&optional prefix suffix) + (concat (jao-scm-line prefix suffix) "\n" + (jao-co-line prefix suffix))) + +(defun jao-co-line (&optional prefix suffix) + (concat (jao-copyright-line prefix suffix) "\n" + (jao-author-line prefix suffix) + (jao-date-line prefix suffix))) + +;; aux functions --------------------------------------------------------- +(defun jao-basename () + "Get buffer file name without dir nor extension" + (file-name-sans-extension (file-name-nondirectory (buffer-file-name)))) + +(defun jao-basedir () + "Base directory" + (file-name-nondirectory + (substring (file-name-directory (buffer-file-name)) 0 -1))) + +(defun jao-dir-level (l) + (let ((elems (split-string + (file-name-sans-extension (buffer-file-name)) "/"))) + (mapconcat 'identity (nthcdr (- (length elems) (+ 1 l)) elems) "/"))) + +(defun jao-extension () + "Find the extension of the currently visited file" + (let ((elems (split-string (file-name-nondirectory (buffer-file-name)) + "\\."))) + (nth (- (length elems) 1) elems))) + +(defun jao-other-file-name (ext1 ext2) + "Find the complimentary file name of header/source file" + (let ((extension (jao-extension)) + (basename (jao-basename))) + (if (string= extension ext1) (concat basename "." ext2) + (concat basename "." ext1)))) + +(defun jao-insert-commented-file (file-name) + (let* ((start (point)) + (end (+ start (cadr (insert-file-contents file-name))))) + (goto-char end) + (comment-region start (point)))) + +(defun jao-insert-copyright-file () + (let ((dir (locate-dominating-file (buffer-file-name) jao-copyright-file))) + (when dir + (let ((file (expand-file-name jao-copyright-file dir))) + (when (file-exists-p file) + (jao-insert-commented-file file)))))) + +(defun jao-provide-skel (regexp skel) + (let ((ex (assoc regexp auto-insert-alist))) + (if ex (setf (cdr ex) skel) + (add-to-list 'auto-insert-alist (cons regexp skel))))) + +(defsubst jao-skel-provide (lst) + (mapc (lambda (x) (apply #'jao-provide-skel x)) lst)) + +(provide 'common-skel) diff --git a/skels/cpp-skel.el b/skels/cpp-skel.el new file mode 100644 index 0000000..806f1df --- /dev/null +++ b/skels/cpp-skel.el @@ -0,0 +1,255 @@ +;;; cpp-skel.el + +;; Copyright (C) 2004, 2005, 2008, 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; C++ skeletons. + +;;; Code: + +(require 'common-skel) +(require 'thingatpt) + +;;; Variables +(defvar jao-skel-cpp-root-namespace nil + "The root C++ namespace") + +(defvar jao-skel-cpp-brief-header-p nil + "If non-nil, generate brief header comments") + +(defvar jao-skel-cpp-make-guard-function #'jao-skel-cpp-make-guard-name + "Function generating #include guards") + +(defvar jao-skel-cpp-use-namespaces t + "Whether to generate namespaces") + +(defvar jao-skel-cpp-single-line-namespaces t + "Whether to put consecutive namespace decls in a single line") + +(defvar jao-skel-cpp-header-extension "hpp") + +;;; Auxiliar functions +(defun jao-skel-cpp--find-other (ext) + (file-name-nondirectory + (or (ff-other-file-name) + (concat (file-name-sans-extension (buffer-name)) "." ext)))) + +(defun jao-skel-cpp-make-guard-name (ns) + "Create a standard include guard name" + (upcase (mapconcat #'identity + `(,@ns ,(jao-basename) ,(jao-extension) + ,(user-login-name) + ,(format-time-string "%y%m%d%H%M")) + "_"))) + +;; namespaces +(defsubst jao-skel-cpp--read-ns (curr) + (read-string (format "Add namespace (current: %s): " (or curr "[none]")))) + +(defsubst jao-skel-cpp--ns2str (ns) (mapconcat 'identity ns "::")) + +(defun jao-skel-cpp--get-ns-list (&optional acc) + (do* ((result acc (cons next result)) + (next (jao-skel-cpp--read-ns (jao-skel-cpp--ns2str acc)) + (jao-skel-cpp--read-ns (jao-skel-cpp--ns2str (reverse result))))) + ((string= next "") (reverse result)))) + +(defun jao-skel-cpp--insert-open-ns-list (ns) + (dolist (n ns) + (insert (format "namespace %s {%s" + n + (if jao-skel-cpp-single-line-namespaces " " "\n"))) + (indent-according-to-mode)) + (when jao-skel-cpp-single-line-namespaces + (newline) + (indent-according-to-mode))) + +(defun jao-skel-cpp--insert-close-ns-list (ns) + (if jao-skel-cpp-single-line-namespaces + (insert (format "%s // namespace %s\n" + (make-string (length ns) ?}) + (jao-skel-cpp--ns2str ns))) + (dolist (n (reverse ns)) + (insert (format "} // namespace %s\n" n))))) + +(defun jao-skel-cpp--copy-ns-lines () + (let ((lines)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "namespace\\s-\\w+\\s-{\\|}+\\s-//\\s-namespace" + nil t) + (push (thing-at-point 'line) lines) + (next-line))) + lines)) + +(defun jao-skel-cpp--copy-namespace () + (let* ((name (ff-other-file-name)) + (buff (and name (find-file-noselect name))) + (nlines)) + (when buff + (let ((lines (save-current-buffer + (set-buffer buff) + (jao-skel-cpp--copy-ns-lines)))) + (dolist (line lines) + (push line nlines) + (when (string-match "}" line) + (push "\n\n\n\n" nlines))))) + (mapconcat #'identity nlines "\n"))) + +(defsubst jao-skel-cpp--get-new-namespace () + (when jao-skel-cpp-use-namespaces + (jao-skel-cpp--get-ns-list + (and jao-skel-cpp-root-namespace (list jao-skel-cpp-root-namespace))))) + +;; skeletons +(define-skeleton jao-skel-cpp-header-long + "Initial file header blurb" + "Brief file description: " + "/**" + > \n + "* @file " (file-name-nondirectory (buffer-file-name)) + > \n + "* @brief " str + > \n + "* @author " (user-full-name) " <"user-mail-address">" + > \n + "* @date " (format-time-string "%a %b %d, %Y %H:%M") + > \n + "*" + > \n + (jao-copyright-line "* " "") + "*" + > ?\n + (jao-insert-copyright-file) + > \n \n _) + +(define-skeleton jao-skel-cpp-header-brief + "Brief initial header blurb" + nil + (jao-copyright-line "/* " " */") + \n) + +(define-skeleton jao-skel-cpp-header-comment + "Insert a standard comment block" + nil + '(if jao-skel-cpp-brief-header-p + (jao-skel-cpp-header-brief) + (jao-skel-cpp-header-long))) + +;; source C/C++ file ------------------------------------------------------ +(define-skeleton jao-skel-cpp-source-header + "Insert a standard C++ source header" + nil + '(jao-skel-cpp-header-comment) + ? \n + "#include \"" (jao-skel-cpp--find-other jao-skel-cpp-header-extension) "\"" + > \n \n _ + (jao-skel-cpp--copy-namespace) + \n) + +(define-skeleton jao-skel-c-source-header + "Insert a standard C source header" + nil + '(jao-skel-cpp-header-comment) + "#include \"" (jao-skel-cpp--find-other "h") "\"" + > _ \n \n \n \n + (jao-scm-line "/* " " */") + > \n) + + +;; header C/C++ files ------------------------------------------------------ +;; header guard + +;; class definition +(define-skeleton jao-skel-cpp-class-def + "Insert a class definition" + nil + '(setq v1 (jao-basename)) + > \n + "/**" + > \n + "*" + > \n + "*" + > \n + "*/" + > \n + "class " v1 + > \n + "{" + > \n + "public:" + > \n + "~" v1 "();" + > \n + v1 "();" + > \n + v1 "(const " v1 "& other);" + > \n \n + "private:" + > \n + "};" + > \n) + +(define-skeleton jao-skel-cpp-header + "Insert a standard C++ header (hpp files)" + nil + '(setq v1 (jao-skel-cpp--get-new-namespace)) + '(setq v2 (funcall jao-skel-cpp-make-guard-function v1)) + '(jao-skel-cpp-header-comment) + > \n + "#ifndef " v2 + > \n + "#define " v2 + > \n \n + '(when v1 (jao-skel-cpp--insert-open-ns-list v1)) + _ '(jao-skel-cpp-class-def) + > \n \n + '(when v1 (jao-skel-cpp--insert-close-ns-list v1)) + > \n \n + "#endif // " v2 + > \n) + +(define-skeleton jao-skel-c-header + "Insert a standard C header (.h files)" + nil + '(jao-skel-cpp-header-comment) + > \n + '(setq v1 (funcall jao-skel-cpp-make-guard-function nil)) + "#ifndef " v1 + > \n + "#define " v1 + > _ \n \n \n \n + "#endif /* " v1 " */" + > \n \n + (jao-scm-line "/* " " */") + > \n) + +(jao-skel-provide + '(("\\.cpp$" jao-skel-cpp-source-header) + ("\\.hpp$" jao-skel-cpp-header) + ("\\.c$" jao-skel-c-source-header) + ("\\.h$" jao-skel-c-header))) + +(provide 'cpp-skel) + +;;; cpp-skel.el ends here diff --git a/skels/cppunit-skel.el b/skels/cppunit-skel.el new file mode 100644 index 0000000..729f392 --- /dev/null +++ b/skels/cppunit-skel.el @@ -0,0 +1,91 @@ +;;; cppunit-skel.el + +;; Copyright (C) 2004, 2005 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Skeletons creating cppunit classes. + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-cppunit-main + "Insert CPPUNIT main function" + nil + "#include <cppunit/extensions/TestFactoryRegistry.h>" > \n + "#include <cppunit/ui/text/TestRunner.h>" > \n \n + "int" > \n + "main(int argc, char* argv[])" > \n + "{" > \n + "CppUnit::TextUi::TestRunner runner;" > \n + "CppUnit::TestFactoryRegistry& registry =" > \n + "CppUnit::TestFactoryRegistry::getRegistry();" > \n \n + "runner.addTest(registry.makeTest());" > \n \n + "return !runner.run(\"\", false);" > \n + "}" > \n) + +(define-skeleton jao-cppunit-class + "Create a CPPUNIT class definition preamble" + nil + > + "CPPUNIT_TEST_SUITE(" (jao-basename) ");" + > \n + "CPPUNIT_TEST(test);" + > \n + "CPPUNIT_TEST_SUITE_END();" + > \n \n + "private:" + > \n \n + "void test();" + > \n \n + "private:" + > \n \n + "void set_up();" + > \n + "void tear_down();" + > \n) + +(define-skeleton jao-cppunit-classdef + "Create a CPPUNIT class implementation preamble" + nil + > + "CPPUNIT_TEST_SUITE_REGISTRATION(" (jao-basename) ");" + > \n \n + "void" + > \n + (jao-basename) "::set_up()" + > \n + "{" + > \n + "}" + > \n \n + "void" + > \n + (jao-basename) "::tear_down()" + > \n + "{" + > \n + "}" + > \n) + +(provide 'cppunit-skel) + diff --git a/skels/dot.emacs.el b/skels/dot.emacs.el new file mode 100644 index 0000000..a82e500 --- /dev/null +++ b/skels/dot.emacs.el @@ -0,0 +1,11 @@ +;; boilerplate skels configuration: + +;;; add skels directory to your load path +(add-to-list 'load-path "~/lib/emacs/skels") +(load "init-skel") + +;;; set configuration variables +(setq jao-company-name "Free Software Foundation, Inc.") +(setq jao-cpp-root-namespace "") +(setq jao-copyright-file ".copyright") + diff --git a/skels/fsf-copyright b/skels/fsf-copyright new file mode 100644 index 0000000..af83705 --- /dev/null +++ b/skels/fsf-copyright @@ -0,0 +1,12 @@ +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 <http://www.gnu.org/licenses/>. diff --git a/skels/fuel-skel.el b/skels/fuel-skel.el new file mode 100644 index 0000000..786f4ec --- /dev/null +++ b/skels/fuel-skel.el @@ -0,0 +1,45 @@ +;;; fuel-skel.el --- skeleton for fuel elisp files + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: lisp + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-fuel-file + "Fuel file header" + "Brief description: " + ";;; " (file-name-nondirectory (buffer-file-name)) " -- " str "" + \n \n + (jao-copyright-line ";; ") + ";; See http://factorcode.org/license.txt for BSD license." + \n \n (jao-author-line ";; ") ";; Keywords: languages, fuel, factor" + \n (jao-date-line ";; ") + \n ";;; Comentary: " \n \n ";; " _ \n + \n ";;; Code: " \n \n \n \n + " " \n "(provide '" (jao-basename) ")" \n + ";;; " (file-name-nondirectory (buffer-file-name)) " ends here" + \n + \n) + +(jao-provide-skel "misc/fuel/.+\\.el\\'" 'jao-skel-fuel-file) + + +(provide 'fuel-skel) +;;; fuel-skel.el ends here diff --git a/skels/geiser-skel.el b/skels/geiser-skel.el new file mode 100644 index 0000000..3c9181a --- /dev/null +++ b/skels/geiser-skel.el @@ -0,0 +1,50 @@ +;; geiser-skel.el -- geiser skeletons + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Fri Sep 11, 2009 00:31 + +(require 'common-skel) + +(defconst jao-skel-geiser--bsd + ";; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. +") + +(defsubst jao-skel-geiser--end-line () + (format ";;; %s ends here\n\n" (file-name-nondirectory (buffer-file-name)))) + +(define-skeleton jao-skel-geiser--common + "Geiser elisp header" + "Brief description: " + ";;; " (file-name-nondirectory (buffer-file-name)) " -- " str "" + \n \n + (jao-copyright-line ";; ") \n + jao-skel-geiser--bsd + \n (jao-date-line ";; ") \n) + +(define-skeleton jao-skel-geiser-elisp + "Geiser elisp header" + nil + '(jao-skel-geiser--common) + " " \n _ \n \n " " \n "(provide '" (jao-basename) ")" \n + (jao-skel-geiser--end-line)) + +(jao-provide-skel "geiser/elisp/.+\\.el\\'" 'jao-skel-geiser-elisp) + +(define-skeleton jao-skel-geiser-scheme + "Geiser scheme header" + nil + '(jao-skel-geiser--common) _ + \n (jao-skel-geiser--end-line)) + +(jao-provide-skel "geiser/scheme/.+\\.\\(scm\\|ss\\|sls\\)\\'" + 'jao-skel-geiser-scheme) + + + +(provide 'geiser-skel) +;;; geiser-skel.el ends here diff --git a/skels/haskell-skel.el b/skels/haskell-skel.el new file mode 100644 index 0000000..e105f31 --- /dev/null +++ b/skels/haskell-skel.el @@ -0,0 +1,69 @@ +;;; haskell-skel.el --- skeleton for haskell source files +;; Copyright (C) 2003, 2004, 2005, 2009, 2010 Jose A Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@member.fsf.org> +;; Keywords: languages + +;; 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: + +;; + +;;; Code: + +(require 'common-skel) +(require 'jao-dominating-file) + +;;; Auxiliar +(defun jao-skel--read-haskell-module () + (let* ((ddir (jao-relative-path "\\.cabal\\'")) + (mbase (and ddir (concat (replace-in-string ddir "/" ".") "."))) + (m (read-string "Module prefix (empty for no module): " + (concat (or mbase "") (jao-basename))))) + (or m ""))) + +(defconst jao-skel--haskell-line (make-string 78 ?-)) + +;;; Skeletons +(define-skeleton jao-skel-haskell-file + "Haskell hs file header" + "Brief description: " + '(setq v (jao-skel--read-haskell-module)) + jao-skel--haskell-line \n + "-- |" \n + "-- Module: " v \n + (jao-copyright-line "-- Copyright: " "" t) + "-- License: BSD3-style (see LICENSE)" \n + "--" \n + "-- Maintainer: " user-mail-address \n + "-- Stability: unstable" \n + "-- Portability: portable" \n + "-- Created: " (format-time-string "%a %b %d, %Y %H:%M") \n + "--" \n + "--" \n + "-- " str \n + "--" \n + jao-skel--haskell-line + \n \n \n + "module " v " where " \n \n \n) + +(jao-provide-skel "\\.hs\\'" 'jao-skel-haskell-file) +;; (jao-provide-skel "\\.lhs\\'" 'jao-skel-lit-haskell-file) + +(provide 'haskell-skel) + +;;; haskell-skel.el ends here diff --git a/skels/init-skel.el b/skels/init-skel.el new file mode 100644 index 0000000..7612f92 --- /dev/null +++ b/skels/init-skel.el @@ -0,0 +1,39 @@ +;; skeleton configuration + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Initialisation file for jao skeletons + +;;; Code: + +(require 'autoinsert) +(setq auto-insert t) +(add-hook 'find-file-hooks 'auto-insert) +(setq auto-insert-directory "~/.autoinsert/") +(setq auto-insert-query t) + +(require 'common-skel) + +(provide 'init-skel) + +;;;; init-skel.el ends here diff --git a/skels/latex-skel.el b/skels/latex-skel.el new file mode 100644 index 0000000..330be22 --- /dev/null +++ b/skels/latex-skel.el @@ -0,0 +1,52 @@ +;; latex skeletons + +;; Copyright (C) 2004, 2005, 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; LaTeX skeletons + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-latex + "Latex standard header" + nil + "%%" + \n + "%% Author: " (user-full-name) " <"user-mail-address">" + \n + "%% Start date: " (format-time-string "%a %b %d, %Y %H:%M") + \n + "%% $" "Id$" + \n + "%%" + ?\n + (jao-copyright-line "% ") + \n + "%%" + \n \n) + +(jao-provide-skel "\\.tex$\\|\\.sty$\\|\\.cls$" 'jao-skel-latex) + +(provide 'latex-skel) + diff --git a/skels/lisa-skel.el b/skels/lisa-skel.el new file mode 100644 index 0000000..6cf3083 --- /dev/null +++ b/skels/lisa-skel.el @@ -0,0 +1,157 @@ +;;; lisa variants of c skeletons + +;; Copyright (C) 2004, 2005, 2006 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Lisa variants for c skeletons + +;;; Code: + +(require 'common-skel) + +(defun jao-lisa-filename () + (let* ((fname (expand-file-name (buffer-file-name))) + (parts (split-string fname "/")) + (dirs (member "src" parts))) + (mapconcat 'identity dirs "/"))) + + +(defun jao-lisa-guard () + (upcase (concat (jao-basename) + "_" (jao-extension) "_" + (format-time-string "%y%m%d%H%M")))) + +(defun jao-lisa-header (&optional desc group prf) + (concat "/**" + "\n * @file " (jao-lisa-filename) + "\n * @author " (user-full-name) " <"user-mail-address">" + "\n * @date " (format-time-string "%a %b %d, %Y %H:%M") + "\n * @brief " (or desc (read-string "Description: ")) + (if group (concat "\n * @ingroup " group) "") + (if prf (concat "\n * @uutrx " prf) "") + "\n **/\n\n" + (jao-arch-line "// " ""))) + +(define-skeleton jao-skel-lisa-h + "Standard lisa c header" + nil + '(setq guard (jao-lisa-guard)) + (jao-lisa-header) + \n \n + "#ifndef " guard \n + "#define " guard \n + \n \n "#include \"" _ "\"" \n \n \n + " " \n "// Types" \n \n \n + " " \n "// Constants" \n \n \n + " " \n "// Functions" \n \n \n + \n \n + "#endif // " guard + \n \n) + +(define-skeleton jao-skel-lisa-c + "Standard lisa c body" + nil + (jao-lisa-header (concat (jao-other-file-name "h" "c") " implementation")) + \n \n + "#include \"" + (jao-basename) + ".h\"" > + > \n \n \n + " " \n "// Private" \n \n \n + _ + " " \n "// Public" \n \n \n + ) + +(define-skeleton jao-skel-lisa-test + "Cantata++ test file" + nil + '(setq v1 (read-string "File under test (sans extension): ")) + '(setq v0 (read-string "Doxygen group under test: ")) + '(setq v2 (concat "UnitTest" v0)) + (jao-lisa-header (concat "Unit tests for " v1) + v2 + (read-string "Prefix of functions being tested (e.g. 'rtos_?+'): ")) + \n \n + "#include \"test/test.h\"" > \n + "#include \"" v1 ".h\"" > \n \n \n + "// Test name" > \n + "char const *test_name = \"" (concat v1 "_test") "\";" > \n \n + "// Prototypes for test functions" > \n + "/**" \n + "* @defgroup " v2 " Unit tests" > \n + "* @ingroup " v0 > \n + "**/" > \n + "//@{" > \n + "//@}" > \n + \n \n \n + "void" > \n + "run_tests (void)" > \n + "{" > \n + "}" > \n \n + "// Test functions" > \n \n \n) + +(defun jao-add-cantata-test () + "Call this function inside a test buffer to add a new test fun" + (interactive) + (let* ((fn (read-string "Function under test: ")) + (tfn (concat "test_" fn))) + (goto-char (point-min)) + (if (not (search-forward-regexp "^// Prototypes for test functions$" nil t)) + (error "No beginning of test fun declarations found")) + (if (not (search-forward-regexp "//@\\}$" nil t)) + (error "Missing doxygen group marks in prototype function decls")) + (beginning-of-line) + (open-line 1) + (insert "/**\n * Unit tests for @ref " fn "\n */\n") + (insert "static void " tfn " (void);\n") + (if (not (search-forward-regexp "run_tests (void)$" nil t)) + (error "No run_tests() definition found")) + (if (not (search-forward-regexp "^}" nil t)) + (error "End of run_tests() not found")) + (beginning-of-line) + (insert "\n") + (previous-line 1) + (insert tfn " ();") + (indent-according-to-mode) + (goto-char (point-max)) + (jao-insert-cantata-test-fun tfn))) + +(defun jao-insert-cantata-test-fun (fn) + (beginning-of-line) + (insert "void\n" fn " (void)\n{\n") + (insert "START_TEST (\"" fn + "\", \"" (read-string "Test case description: ") "\");") + (indent-according-to-mode) + (insert "\n\n\nEND_TEST ();") + (indent-according-to-mode) + (insert "\n}\n")) + + +(defun jao-skel-lisa-activate () + (interactive) + (jao-provide-skel "\\.c$" 'jao-skel-lisa-c) + (jao-provide-skel "\\.h$" 'jao-skel-lisa-h) + (jao-provide-skel "tests/.*\\.c$" 'jao-skel-lisa-test)) + + +(provide 'lisa-skel) + diff --git a/skels/lisp-skel.el b/skels/lisp-skel.el new file mode 100644 index 0000000..e5bb91a --- /dev/null +++ b/skels/lisp-skel.el @@ -0,0 +1,50 @@ +;;; lisp-skel.el --- skeleton for lisp-like languages + +;; Copyright (C) 2003, 2004, 2005, 2008, 2009 Jose A Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: lisp + +;; 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: + +;; Skeleton for lisp like languages + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-lisp-file + "Lisp file header" + "Brief description: " + ";; " (file-name-nondirectory (buffer-file-name)) " -- " str "" + ?\n + (jao-c&co-line ";; ") + ?\n + (jao-insert-copyright-file) + \n ";;; Comentary: " \n \n ";; " _ \n + \n ";;; Code: " \n \n \n \n + '(when (eq major-mode 'emacs-lisp-mode) + (insert (format " \n(provide '%s)\n" (jao-basename)))) + ";;; " (file-name-nondirectory (buffer-file-name)) " ends here" + \n + \n) + +(jao-provide-skel "\\.\\(scm\\|ss\\|lisp\\|cl\\|el\\)\\'" 'jao-skel-lisp-file) + +(provide 'lisp-skel) +;;; lisp-skel.el ends here diff --git a/skels/make-skel.el b/skels/make-skel.el new file mode 100644 index 0000000..5607dbe --- /dev/null +++ b/skels/make-skel.el @@ -0,0 +1,53 @@ +;; makefile skeletons + +;; Copyright (C) 2004, 2005, 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Makefile skeletons + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-makefile + "Makefile standard header" + nil + "#" + \n + "# $" "Id$" + \n + "# " + \n + "# Author: " (user-full-name) " <"user-mail-address">" + \n + "# Start date: " (format-time-string "%a %b %d, %Y %H:%M") + \n + "#" + ?\n + (jao-copyright-line "# ") + \n + (jao-insert-copyright-file)) + +(jao-provide-skel "\\.mk$\\|Makefile\\(\\.am\\)?\\|configure\\.in" 'jao-skel-makefile) + +(provide 'make-skel) + diff --git a/skels/muse-skel.el b/skels/muse-skel.el new file mode 100644 index 0000000..86686d9 --- /dev/null +++ b/skels/muse-skel.el @@ -0,0 +1,41 @@ +;;; muse-skel.el --- muse pages + +;; Copyright (C) 2006 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-muse-file + "Muse file skeleton" + "Documents (sub)dir: " + _ \n \n \n \n \n \n \n + "----" \n + ";;; Local Variables:" \n + ";;; wiki-docs: " str \n + ";;; End:" \n \n + '(hack-local-variables)) + +(add-to-list 'auto-insert-alist + '("\\.muse\\'" . jao-skel-muse-file)) + +(provide 'muse-skel) +;;; muse-skel.el ends here diff --git a/skels/noweb-skel.el b/skels/noweb-skel.el new file mode 100644 index 0000000..0e37702 --- /dev/null +++ b/skels/noweb-skel.el @@ -0,0 +1,48 @@ +;;; noweb-skel.el --- skeleton for noweb files + +;; Copyright (C) 2003, 2004, 2005 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Skeleton for noweb files + +;;; Code: + +(require 'common-skel) +(require 'latex-skel) + +(define-skeleton jao-skel-noweb + "Noweb standard header" + "Code mode (without -mode suffix): " + "% -*- mode: Noweb; noweb-code-mode: " str "-mode -*-" + '(setq noweb-code-mode (intern (concat str "-mode"))) + \n + '(jao-skel-latex) + \n _ \n \n + "%%% end of file" + \n) + +(add-to-list 'auto-insert-alist '("\\.nw$" . jao-skel-noweb)) + +(provide 'noweb-skel) + + +;;; noweb-skel.el ends here diff --git a/skels/perl-skel.el b/skels/perl-skel.el new file mode 100644 index 0000000..a5b5bb4 --- /dev/null +++ b/skels/perl-skel.el @@ -0,0 +1,78 @@ +;;; perl-skel.el + +;; Copyright (C) 2004, 2005, 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Perl skeletons + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-perl-script + "Standard perl script header" + "Brief file description: " + "#! /usr/bin/perl -w" + > \n + "#" + > \n + "# $Id" "$" + > \n + "# " (file-name-nondirectory (buffer-file-name)) ": " str + > \n + "#" + > ?\n + (jao-copyright-line "# ") + > ?\n + (jao-insert-copyright-file) + > \n + "use strict;" + > \n \n + > \n _) + +(define-skeleton jao-skel-perl-module + "Standard perl module header" + "Brief module description: " + "#" + > \n + "# " (file-name-nondirectory (buffer-file-name)) ": "str + > \n + "#" + > ?\n + (jao-copyright-line "# ") + > ?\n + (jao-insert-copyright-file) + "# " + > \n \n + "package " + (read-string (concat "Module name (" (jao-basename) "): ") + nil nil (jao-basename)) + ";" + > \n \n _ \n \n + "1;" + > \n) + +(jao-provide-skel "\\.pl$" 'jao-skel-perl-script) +(jao-provide-skel "\\.pm$" 'jao-skel-perl-module) + +(provide 'perl-skel) + diff --git a/skels/pika-skel.el b/skels/pika-skel.el new file mode 100644 index 0000000..654792d --- /dev/null +++ b/skels/pika-skel.el @@ -0,0 +1,88 @@ +;;; pika variants of c skeletons + +;; Copyright (C) 2004, 2005 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Pika variants for c skeletons + +;;; Code: + +(require 'common-skel) + +(defun jao-pika-guard () + (upcase (concat "include__" (jao-basedir) "__" (jao-basename) "_h"))) + +(define-skeleton jao-pika-header + "" + "Brief file description: " + "/* " (file-name-nondirectory (buffer-file-name)) ": " str + \n "*" > \n + "****************************************************************" + > \n (jao-copyright-line "* ") + > \n "*" > \n + "* See the file \"COPYING\" for further information about" + > n + "* the copyright and warranty status of this work." + > n + "*/" \n " " \n _) + +(define-skeleton jao-skel-pika-h + "Standard pika c header" + nil + (jao-pika-header) + '(setq guard (jao-pika-guard)) + "#ifndef " guard \n + "#define " guard \n + " " + \n \n "#include \"" _ "\""\n \n + " " + \n \n \n + " " + \n + "#endif /* " guard " */" + \n \n " " \n + (jao-arch-line "/* " "*/") + \n) + +(define-skeleton jao-skel-pika-c + "Standard pika c body" + nil + (jao-pika-header) + \n "#include \"" (jao-dir-level 2) ".h\"" \n + \n + " " + \n \n _ \n \n " " \n + (jao-arch-line "/* " "*/") + \n) + +(defun jao-skel-pika-activate () + (interactive) + (let ((c (assoc "\\.c$" auto-insert-alist)) + (h (assoc "\\.h$" auto-insert-alist))) + (if c (setf (cdr c) 'jao-skel-pika-c) + (add-to-list 'auto-insert-alist '("\\.c$" . jao-skel-pika-c))) + (if h (setf (cdr h) 'jao-skel-pika-h) + (add-to-list 'auto-insert-alist '("\\.h$" . jao-skel-pika-h))))) + + +(provide 'pika-skel) + diff --git a/skels/python-skel.el b/skels/python-skel.el new file mode 100644 index 0000000..536f825 --- /dev/null +++ b/skels/python-skel.el @@ -0,0 +1,53 @@ +;;; python-skel.el + +;; Copyright (C) 2004, 2005, 2009 Aleix Conchillo Flaque + +;; Author: Aleix Conchillo Flaque <aleix@member.fsf.org> +;; Keywords: tools + +;; 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: + +;; Python skeletons + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-python-module + "Standard python module header" + "Brief file description: " + "#! /usr/bin/env python" + > \n + "#" + > \n + "# $Id" "$" + > \n \n + "# " (file-name-nondirectory (buffer-file-name)) ": " str + > \n + "#" + > ?\n + (jao-copyright-line "# ") + > ?\n + (jao-insert-copyright-file) + > \n + > \n _) + +(jao-provide-skel "\\.py$" 'jao-skel-python-module) + +(provide 'python-skel) + diff --git a/skels/readme-skel.el b/skels/readme-skel.el new file mode 100644 index 0000000..9c22cce --- /dev/null +++ b/skels/readme-skel.el @@ -0,0 +1,44 @@ +;; Copyright (C) 2004, 2005 Jose Antonio Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: tools + +;; 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: + +;; Simple skeleton for README files. + +;;; Code: + +(require 'common-skel) + +(define-skeleton jao-skel-readme-file + "README file header" + "Brief description: " + \n str + \n "-----------------------------------------------------" \n + _ \n \n \n + "-----------------------------------------------------" \n + (jao-copyright-line "" "") + \n \n + "$Id" "$" + \n) + +(add-to-list 'auto-insert-alist '("README" . jao-skel-readme-file)) + +(provide 'readme-skel) + diff --git a/skels/s48-skel.el b/skels/s48-skel.el new file mode 100644 index 0000000..30e749f --- /dev/null +++ b/skels/s48-skel.el @@ -0,0 +1,61 @@ +;;; s48-skel.el --- skeleton for s48 + +;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009 Jose A Ortega Ruiz + +;; Author: Jose A Ortega Ruiz <jao@gnu.org> +;; Keywords: lisp + +;; 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: + +;; Skeleton for s48/slime48 like languages + +;;; Code: + +(require 'common-skel) +(require 'lisp-skel) + +(define-skeleton jao-skel-s48-file + "Slime/Scheme48 file header" + "Package: " + ";; -*- mode: scheme48; scheme48-package: " str " -*-" + ?\n + (jao-co-line ";; ") + ?\n + (jao-insert-copyright-file) + \n ";;; Comentary: " \n \n ";; " _ \n + \n ";;; Code: " \n \n \n \n + ";;; " (file-name-nondirectory (buffer-file-name)) " ends here" + '(scheme48-mode) + \n + \n) + +(define-skeleton jao-skel-s48-file-maybe + "Choose between a s48 file and a plain scheme one" + nil + '(if (y-or-n-p "Is this a s48 file? ") (jao-skel-s48-file) + (jao-skel-lisp-file)) + '(hack-local-variables)) + + +(jao-provide-skel "\\.scm\\'" 'jao-skel-s48-file-maybe) + + +(provide 's48-skel) + + +;;; lisp-skel.el ends here diff --git a/skels/scsh-skel.el b/skels/scsh-skel.el new file mode 100644 index 0000000..495925f --- /dev/null +++ b/skels/scsh-skel.el @@ -0,0 +1,45 @@ +;;; scsh-skel.el --- skeleton for scsh scripts + +;; Copyright (C) 2003, 2004, 2005, 2006, 2008 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: abbrev + +;; 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. + +(require 'common-skel) + +(define-skeleton jao-skel-scsh + "Scsh script skeleton" + "Brief description: " + "#! " (executable-find "scsh") " \\" \n + "-e " (file-name-nondirectory (buffer-file-name)) " -s" \n + "!#" \n \n + ";;;; " str \n + "(define (" (file-name-nondirectory (buffer-file-name)) " args)" + \n + > _ " )" + > \n \n \n + ";; Local Variables:" \n + ";; mode: scheme" \n + ";; End:" + '(hack-local-variables) + \n \n) + +(provide 'scsh-skel) + + +;;; scsh-skel.el ends here diff --git a/skels/texinfo-skel.el b/skels/texinfo-skel.el new file mode 100644 index 0000000..dc73835 --- /dev/null +++ b/skels/texinfo-skel.el @@ -0,0 +1,131 @@ +;;; texinfo-skel.el --- skeletons for texinfo files + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Keywords: languages + +;; 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: + +;; Skeletons to generate texinfo files templates. + +;;; Code: + +(require 'common-skel) + +(defun jao-dir-entry () + "Read dir file entry" + (let ((cat (read-string "Dir file category: ")) + (ent (read-string "Direntry name: ")) + (desc (read-string "Direntry description: "))) + (concat "@dircategory " cat + "\n@direntry\n" ent + ": (" (jao-basename) "). " desc "." + "\n@end direntry\n"))) + +(define-skeleton jao-skel-main-texinfo + "Main texinfo file skeleton" + "Document title: " + "\\input texinfo" + \n "@ignore" > + \n (jao-scm-line "") + "@end ignore" > + \n > "@c %**start of header" + \n "@setfilename " (jao-basename) ".info" > + \n "@settitle " str > + \n "@syncodeindex pg cp" > + \n "@setchapternewpage odd" > + \n "@footnotestyle separate" > + \n "@c %**end of header" > + \n \n + (jao-dir-entry) + \n + "@set UPDATED " (format-time-string "%B %Y") + \n "@set EDITION 0.1" + \n "@set VERSION 0.1" + \n "@set AUTHOR " (user-full-name) + \n \n "@copying" + \n "This manual is for " str " (version @value{VERSION}, @value{UPDATED})." + \n + \n "Copyright @copyright{} " (format-time-string "%Y") " " jao-company-name + \n + \n "@quotation" + \n "Permission is granted to copy, distribute and/or modify this document" + \n "under the terms of the GNU Free Documentation License, Version 1.1 or" + \n "any later version published by the Free Software Foundation; with no" + \n "Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''" + \n "and with the Back-Cover Texts as in (a) below. A copy of the" + \n "license is included in the section entitled ``GNU Free Documentation" + \n "License.''" + \n + \n "(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify" + \n "this GNU Manual, like GNU software. Copies published by the Free" + \n "Software Foundation raise funds for GNU development.''" + \n "@end quotation" + \n "@end copying" + \n \n "@titlepage" + \n "@title " str + \n "@subtitle Edition @value{EDITION}, for version @value{VERSION}" + \n "@subtitle @value{UPDATED}" + \n "@author by @value{AUTHOR} (@email{jao@@gnu.org})" + \n "@page" + \n "@vskip 0pt plus 1filll" + \n "@insertcopying" + \n "@end titlepage" + \n + \n "@shortcontents" + \n "@contents" + \n + \n "@ifnottex" + \n "@node Top, , (dir), (dir)" + \n \n "@insertcopying" + \n "@end ifnottex" + \n \n + "@menu" > \n "@detailmenu" \n \n > "@end detailmenu" > \n "@end menu" + \n \n \n + "@include intro.texi" > + \n \n \n + "@bye" + \n) + +(define-skeleton jao-skel-child-texinfo + "Template for child texinfo docs" + "Node name: " + "@node " str \n + > "@chapter " str \n + > "@ignore" \n + (jao-scm-line "") + > "@end ignore" \n \n + _ \n \n + "@c This is part of the " (read-string "Main doc title: ") \n + "@c See the main file for copying conditions." + \n \n) + +(define-skeleton jao-skel-texinfo + "Skeleton for texinfo files" + nil + '(if (y-or-n-p "Is this the main texinfo file? ") + (jao-skel-main-texinfo) + (jao-skel-child-texinfo)) + _) + +(add-to-list 'auto-insert-alist '("\\.texi$" . jao-texinfo-skel)) + + +(provide 'texinfo-skel) + + +;;; texinfo-skel.el ends here diff --git a/sys/furl.applescript b/sys/furl.applescript new file mode 100644 index 0000000..6823ff0 --- /dev/null +++ b/sys/furl.applescript @@ -0,0 +1 @@ +tell application "Firefox" to get Çclass curlÈ of window 1 diff --git a/sys/jao-applescript.el b/sys/jao-applescript.el new file mode 100644 index 0000000..233186c --- /dev/null +++ b/sys/jao-applescript.el @@ -0,0 +1,65 @@ +;;; AppleScript and some macish bits +(autoload 'applescript-mode "applescript-mode" + "major mode for editing AppleScript source." t) +(setq auto-mode-alist + (cons '("\\.applescript$" . applescript-mode) auto-mode-alist)) + +(defun do-applescript (script) + (with-temp-buffer + (insert script) + (shell-command-on-region (point-min) (point-max) "osascript" t) + (buffer-string))) + +(defun jao-as-tell-app (app something) + (let ((res (do-applescript (format "tell application \"%s\"\n%s\nend tell" + app something)))) + (or (and (stringp res) (substring res 0 -1)) ""))) + +(defmacro jao-as-get-doc (name application &optional doc) + `(defun ,name () + (interactive) + (let ((url (jao-as-tell-app ,application + ,(format "get the URL of %s 1" + (or doc "document")))) + (name (jao-as-tell-app ,application "get the name of document 1"))) + (cons url name)))) +(jao-as-get-doc jao-as-safari-doc "Safari") +(jao-as-get-doc jao-as-webkit-doc "WebKit") +(jao-as-get-doc jao-as-camino-doc "Camino" "window") + +(defun jao-as-firefox-doc () + (interactive) + (let ((url (shell-command-to-string + (concat "osascript " + (expand-file-name "furl.applescript" + (file-name-directory load-file-name))))) + (name (jao-as-tell-app "Firefox" "get the name of window 1"))) + (cons (substring url 0 -1) name))) + + +;;; quicksilver +(defun jao-qs-buffer () + "Opens the current file in Quicksilver" + (interactive) + (cond ((and buffer-file-name (file-exists-p buffer-file-name)) + (call-process-shell-command (concat "qs \"" buffer-file-name "\""))) + ;; dired handling + ((eq major-mode 'dired-mode) + (dired-do-shell-command "qs * " + current-prefix-arg + (dired-get-marked-files t current-prefix-arg))) + ;; buffer-menu mode + ((and (eq major-mode 'Buffer-menu-mode) + (file-exists-p (buffer-file-name (Buffer-menu-buffer nil)))) + (call-process-shell-command + (concat "qs \"" (buffer-file-name (Buffer-menu-buffer nil)) "\""))) + (t + (error "Not visiting a file or file doesn't exist")))) + + (defun jao-qs-region (start end) + "Opens the contents of the region in Quicksilver as text." + (interactive "r") + (call-process-region start end "qs" nil 0 nil "-")) + + +(provide 'jao-applescript) diff --git a/sys/jao-devon.el b/sys/jao-devon.el new file mode 100644 index 0000000..417cb6d --- /dev/null +++ b/sys/jao-devon.el @@ -0,0 +1,42 @@ +;; DEVONthink interaction + +(require 'jao-applescript) + +(defconst *jao-devon-sep* "####") + +(defun jao-devon-path (dvp) + (car (split-string dvp *jao-devon-sep*))) +(defun jao-devon-url (dvp) + (cadr (split-string dvp *jao-devon-sep*))) +(defun jao-devon-name (dvp) + (car (last (split-string (jao-devon-path dvp) "/")))) + +(defun jao-devon-make-dvp (path url) (concat path *jao-devon-sep* name)) +(defun jao-devon-dvp-p (dvp) + (and (stringp dvp) + (string-match (concat "^/.+" *jao-devon-sep*) dvp))) + +(defconst *jao-devon-sel-as* + (concat "set rs to the selection + set r to item 1 of rs + set rn to the name of r + set rl to the location of r + set ru to the URL of r + rl & rn & \"" *jao-devon-sep* "\" & ru")) + +(defun jao-devon-selection () + (interactive) + (jao-as-tell-app "DEVONThink Pro" *jao-devon-sel-as*)) + +(defun jao-devon-open-as (path) + (concat "set r to get record at \"" path "\"" + "\n open window for record r\n activate")) + +(defun jao-devon-open (dvp) + (if (eq system-type 'darwin) + (let ((path (jao-devon-path dvp))) + (when path + (jao-as-tell-app "DEVONThink Pro" (jao-devon-open-as path) t))) + (browse-url (jao-devon-url dvp)))) + +(provide 'jao-devon) diff --git a/sys/jao-osd.el b/sys/jao-osd.el new file mode 100644 index 0000000..0b2c433 --- /dev/null +++ b/sys/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") +(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/themes/autumn-ec b/themes/autumn-ec new file mode 100755 index 0000000..ca63787 --- /dev/null +++ b/themes/autumn-ec @@ -0,0 +1,40 @@ +#!/bin/bash + +font=${EC_TERM_FACE:-xft:Inconsolata:size=11,[codeset=iso8859-7]xft:Andale Mono:size=12} + +frg="grey55" +bkg="grey1" +bw=4 +bw=${EC_TERM_BORDER:-3} +tr="-tr -sh 8" +tr="+tr" + +exec urxvtcd -cr tomato -sl 0 +rv +ptab +ssr -b $bw -bd "$bkg" \ + -bg "$bkg" -fg "$frg" \ + +sbg $tr -fn "${font}" -name "emacsclient" \ + -xrm "*colorBD: ${frg}" \ + -xrm "*colorUL: ${frg}" \ + -xrm "*color0: ${frg}" \ + -xrm "*color8: grey20" \ + -xrm "*color1: tan3" \ + -xrm "*color9: sienna3" \ + -xrm "*color2: peachpuff4" \ + -xrm "*color10: navajowhite4" \ + -xrm "*color3: grey40" \ + -xrm "*color11: darkseagreen4" \ + -xrm "*color4: #9D9064" \ + -xrm "*color12: #BAA68F" \ + -xrm "*color5: cornsilk3" \ + -xrm "*color13: sienna4" \ + -xrm "*color6: grey40" \ + -xrm "*color14: tan4" \ + -xrm "*color7: ${frg}" \ + -xrm "*color15: grey50" \ + -e emacsclient -t $* + + + +# fname=${EC_XTERM_FN:-Inconsolata} +# fsize=${EC_XTERM_FS:-11} +# exec xterm -cr tomato -sl 0 +rv -b 4 -bg "$bkg" -bd "$bkg" -fg "$frg" \ +# -bdc -ulc -u8 -fa "$fname" -fs $fsize -name "emacsclient" \ diff --git a/themes/dark-ec b/themes/dark-ec new file mode 100755 index 0000000..caed4f4 --- /dev/null +++ b/themes/dark-ec @@ -0,0 +1,42 @@ +#!/bin/bash + +# font=${EC_TERM_FACE:-xft:Andale Mono:size=11} +font=${EC_TERM_FACE:-xft:Inconsolata:size=11,[codeset=iso8859-7]xft:Andale Mono:size=12} +# font=${EC_TERM_FACE:-xft:Terminus:size=12,[codeset=iso8859-7]xft:Andale Mono:size=12} +# font=${EC_TERM_FACE:-xft:DejaVu Sans Mono:size=11} + +frg="grey50" +bkg="black" +bw=${EC_TERM_BORDER:-2} +tr=${EC_TRANS_SPEC} + +exec urxvtcd -cr tomato -sl 0 +ptab +rv +ssr -b $bw -bd "$bkg" \ + -bg "$bkg" -fg "$frg" \ + +sbg $tr -fn "${font}" -name "emacsclient" \ + -xrm "*colorBD: ${frg}" \ + -xrm "*colorUL: ${frg}" \ + -xrm "*color0: ${bkg}" \ + -xrm "*color8: grey20" \ + -xrm "*color1: lightgoldenrod3" \ + -xrm "*color9: sienna3" \ + -xrm "*color2: darkslategray" \ + -xrm "*color10: #44836e" \ + -xrm "*color3: grey40" \ + -xrm "*color11: #648f81" \ + -xrm "*color4: lightcyan4" \ + -xrm "*color12: darkseagreen4" \ + -xrm "*color5: paleturquoise4" \ + -xrm "*color13: aquamarine4" \ + -xrm "*color6: grey7" \ + -xrm "*color14: azure4" \ + -xrm "*color7: ${frg}" \ + -xrm "*color15: grey50" \ + -e emacsclient -t $* + + +# -xrm "*color6: #3F4D5C" \ + +# fname=${EC_XTERM_FN:-Inconsolata} +# fsize=${EC_XTERM_FS:-11} +# exec xterm -cr tomato -sl 0 +rv -b 4 -bg "$bkg" -bd "$bkg" -fg "$frg" \ +# -bdc -ulc -u8 -fa "$fname" -fs $fsize -name "emacsclient" \ diff --git a/themes/jao-dark-theme.el b/themes/jao-dark-theme.el new file mode 100644 index 0000000..7976337 --- /dev/null +++ b/themes/jao-dark-theme.el @@ -0,0 +1,63 @@ +(jao-define-custom-theme jao-dark-theme + (:palette (fg unspecified "grey55") + (bg unspecified "grey2") + (box "yellow" "grey30") + (button ((c 11) nul)) + (hilite ((c nil 8))) + (strike-through ((c 8))) + (italic ((c 13))) + (link ((c 5) ul)) + (visited-link ((c 3) ul)) + (tab-sel ((c 9 8) nbf)) + (tab-unsel ((c 15 6) bx)) + (comment ((c 3))) +;; (keyword ((c 12) nbf)) + (keyword ((c 11) nbf)) + (type ((c 11) nbf)) +;; (function ((c 10) nbf)) + (function ((c 10) nbf)) + (variable-name ((c nil))) + (constant ((c 3))) + (string ((c 14))) + (warning ((c 1))) + (error ((c 9))) + (dimm ((c 3))) + (gnus-mail ((c 15 nil))) + (gnus-news ((c 15 nil))) + (outline ((c 7))) + (f00 ((c 5))) + (f01 ((c 11))) + (f02 ((c 10))) + (f10 ((p f00))) + (f11 ((p f01))) + (f12 ((p f02)))) + (:faces (bold (c nil nil) nul) + (gnus-button (c nil nil) nul) + (gnus-summary-selected (c nil nil) ul nbf) + (mm-uu-extract (c nil 6)) + (mode-line (c 7 8) nbf nul) + (mode-line-inactive (c 8 6) nbf nul) + (org-hide (c 0 nil)) + (rcirc-other-nick (c 14)) + (vertical-border (c 8 nil) :inherit nil) + (w3m-image (c 1)) + (w3m-tab-background (c 0 0)) + (w3m-tab-line (c 0 0)) + (widget-button (c nil nil) nul)) + (:x-faces (gnus-button (c nil nil) nul) + (gnus-summary-selected (c "grey40" nil) ul) + (mode-line (c 14 8) bf nul bx) + (mode-line-inactive (c 3 8) nbf nul bx) + (org-hide (c 0 nil)) + (fringe (p dimm)) + (rcirc-other-nick (c 6)) + (vertical-border (c 8 nil) :inherit nil) + (w3m-image (c 9)) + (w3m-tab-background (c 0 0)) + (widget-button (c nil nil) nul)) + (:x-colors "black" "lightgoldenrod3" "darkslategray" "grey40" "lightcyan4" + "paleturquoise4" "#3F4D5C" "grey55" + "grey20" "lightgoldenrod4" "#44836e" "#648f81" "darkseagreen4" + "aquamarine4" "azure4" "grey60")) + +(provide 'jao-dark-theme) diff --git a/themes/jao-light-theme.el b/themes/jao-light-theme.el new file mode 100644 index 0000000..3b826b0 --- /dev/null +++ b/themes/jao-light-theme.el @@ -0,0 +1,74 @@ +(jao-define-custom-theme jao-light-theme + (:palette (fg "black" "black") + (bg "white" "#efebe7") + (box "color-86" "antiquewhite3") + (button ((c 13 nil) nbf nul) (bx)) + (hilite ((c nil 5))) + (strike-through ((c 1)) (st)) + (italic ((c 4) nbf it) (dfg dbg it)) + (link ((c 8) ul nbf)) + (visited-link (link)) + (tab-sel ((~ mode-line))) + (tab-unsel ((~ mode-line-inactive))) + (comment ((c 11) it)) ;; italic + (keyword ((c 14) nul bf)) + (type ((c 4) nbf nul) ((c "grey30") bf)) + (function ((c 0 nil) bf)) + (variable-name ((c 0))) + (constant ((c 8)) ((c "grey40"))) + (string ((c 10)) ((c "dark olive green"))) + (warning ((c 9))) + (error ((c 1))) + (dimm ((c 12))) + (gnus-mail ((c 0))) + (gnus-news ((c 0))) + (outline ((c 0))) + (f00 ((c 14))) + (f01 ((c 10))) + (f02 ((c 8))) + (f10 ((p f00))) + (f11 ((p f01))) + (f12 ((p f02)))) + (:faces (bold (c 80) bf) + (company-tooltip-common (c 1 6) nbf) + (company-tooltip-common-selection (~ company-tooltip-selection) + (c nil 6) bf) + (company-tooltip-selection (~ company-tooltip) bf nul) + (compilation-info (c nil nil) bf) + (diary (c 14) bf) + (gnus-summary-selected (c nil 79)) + (jao-gnus-face-tree (c nil 78)) + (header-line (c nil 79) nul) + (italic it) + (mode-line (c 0 5) nbf nul) + (mode-line-inactive (c 12 5) nbf nul) + (org-hide (c 7 nil)) + (vertical-border (c 11 nil) :inherit nil) + (w3m-bold (c nil nil) bf) + (w3m-image (c 3)) + (w3m-tab-background (c 12 5))) + (:x-faces (button (c 10 nil) nbf) + (gnus-button (c nil nil) nbf) + (company-tooltip-common (c 1 6) nbf) + (company-tooltip-common-selection (~ company-tooltip-selection) + (c nil 6) bf) + (company-tooltip-selection (~ company-tooltip) bf nul) + (compilation-info (c nil nil) bf) + (fringe (c 9 nil)) + (gnus-summary-selected (c nil "white")) + (header-line (~ mode-line-inactive) (c 14)) + (mode-line (c 0 7) :box (:line-width -1 :color "grey60")) + (mode-line-inactive (~ mode-line) (c 12)) + (org-hide (c 7 nil)) + (vertical-border (c 12 nil)) + (w3m-image (c 3)) + (w3m-tab-selected (c nil "white") nbf) + (w3m-tab-selected-retrieving (~ w3m-tab-selected) (c 1)) + (w3m-tab-background (c 7 7) nul)) + (:x-colors "black" "sienna3" "#597B59" "#D38108" "#3B3152" + "#E0DACC" "lightyellow3" + "#EFEBE7" "grey20" "orangered4" "darkslategray" "#59513A" + "lemonchiffon4" "#386858" "#223142" "#EFEBE7")) + +(provide 'jao-light-theme) + diff --git a/themes/jao-themes.el b/themes/jao-themes.el new file mode 100644 index 0000000..bcedc36 --- /dev/null +++ b/themes/jao-themes.el @@ -0,0 +1,682 @@ +;;; palette +(defvar jao-themes--face-family "Inconsolata") +(defvar jao-themes--fg "black") +(defvar jao-themes--bg "white") +(defvar jao-themes--box "grey75") +(defvar jao-themes--hilite nil) +(defvar jao-themes--italic '(it)) +(defvar jao-themes--button '(ul)) +(defvar jao-themes--strike-through '(:strike-through t)) +(defvar jao-themes--outline '((c "darkslategrey"))) +(defvar jao-themes--link '((c "darkgoldenrod4"))) +(defvar jao-themes--visited-link '((c "darkolivegreen4") nul)) +(defvar jao-themes--gnus-mail '(dfg)) +(defvar jao-themes--gnus-news '(dfg)) +(defvar jao-themes--tab-sel '((c nil "grey90") bx)) +(defvar jao-themes--tab-unsel '((c "grey30" "grey85") nbf bx)) +(defvar jao-themes--comment '((c "grey30"))) +(defvar jao-themes--warning '((c "indianred3") nbf)) +(defvar jao-themes--error '((c "indianred3") bf)) +(defvar jao-themes--constant '((c "darkolivegreen") nbf)) +(defvar jao-themes--function '((c "darkolivegreen") nbf)) +(defvar jao-themes--keyword '((c "darkslategrey") nbf)) +(defvar jao-themes--string '((c "skyblue4"))) +(defvar jao-themes--type '((c "darkslategrey"))) +(defvar jao-themes--variable-name '((c "DodgerBlue4"))) +(defvar jao-themes--dimm '((c "grey30") nbf)) +(defvar jao-themes--f00 '((c "dodgerblue4"))) +(defvar jao-themes--f01 '((c "cadetblue4"))) +(defvar jao-themes--f02 '((c "darkslategrey"))) +(defvar jao-themes--f10 '((c "dodgerblue4"))) +(defvar jao-themes--f11 '((c "cadetblue4"))) +(defvar jao-themes--f12 '((c "darkslategrey"))) + +(defsubst jao-themes--palette-face (face) + (intern (format "jao-themes--%s" face))) + +(defun jao-themes--normalize-body (body) + (dolist (p '(:inverse-video :underline :inherit) body) + (unless (member p body) + (setq body (append body (list p nil)))))) + +(defun jao-themes--parse-face-body (f) + (cond ((null f) nil) + ((listp f) + (jao-themes--normalize-body + (apply 'append (mapcar 'jao-themes--parse-face-sym f)))))) + +(defvar jao-themes--cidxs + '("black" "red" "green" "yellow" "blue" "magenta" "cyan" "white" + "brightblack" "brightred" "brightgreen" "brightyellow" "brightblue" + "brightmagenta" "brightcyan" "brightwhite")) + +(defvar jao-themes--x-colors nil) + +(defun jao-themes--color (clr) + (cond ((stringp clr) clr) + ((numberp clr) (or (nth clr jao-themes--cidxs) + (format "color-%s" clr))) + (t 'unspecified))) + +(defun jao-themes--parse-face-sym (s) + (cond ((listp s) + (case (car s) + (c `(:foreground ,(jao-themes--color (cadr s)) + :background ,(jao-themes--color (caddr s)))) + (p (let ((var (jao-themes--palette-face (cadr s)))) + (when (boundp var) + (let ((val (symbol-value var))) + (if (listp val) + (jao-themes--parse-face-body val) + val))))) + (~ (cdr (assq (cadr s) *jao--parsed-faces*))) + (t (list s)))) + ((atom s) + (case s + (~ '(:inherit)) + (dbg `(:background ,jao-themes--bg)) + (dfg `(:foreground ,jao-themes--fg)) + (link (jao-themes--parse-face-body jao-themes--link)) + (vlink (jao-themes--parse-face-body jao-themes--visited-link)) + (bf '(:bold t :weight bold)) + (nbf '(:bold t :weight normal)) + (it '(:italic t :slant italic)) + (nit '(:italic nil :slant normal)) + (niv '(:inverse-video nil)) + (ul '(:underline t)) + (nul '(:underline nil)) + (st '(:strike-through t)) + (bx `(:box (:line-width -1 :color ,jao-themes--box))) + (t (list s)))))) + +(defun jao-themes--make-faces (fs &optional cidxs) + (let ((*jao--parsed-faces* nil) + (jao-themes--cidxs (or cidxs jao-themes--cidxs)) + (result nil)) + (dolist (f (sort (jao-themes--dfs fs) 'jao--cmp-faces) (reverse result)) + (let ((body (jao-themes--parse-face-body (cdr f)))) + (push (cons (car f) body) *jao--parsed-faces*) + (push (list (car f) body) result))))) + +(defun jao--cmp-faces (a b) + (let ((ai (cadr (assq '~ a))) + (bi (cadr (assq '~ b)))) + (cond ((and ai (not bi)) nil) + ((and bi (not ai)) t) + ((eq (car a) bi) t) + ((eq (car b) ai) nil) + (t (string< (symbol-name (car a)) + (symbol-name (car b))))))) + +(defun jao-themes--dfs (fs) + (let ((dfs + (append + `((bbdb-company) + (bbdb-field-name bf) + (bbdb-field-value nil) + (bbdb-name ul) + (bmk-mgr-bookmark-face nil) + (bmk-mgr-folder-face bf) + (bmk-mgr-sel-bookmark-face link) + (bmk-mgr-sel-folder-face bf) + (bold bf) + (bold-italic bf) + (border (c nil nil)) + (buffer-menu-buffer bf) + (button (p button))) + `((calendar-holiday-marker (p f00)) + (cursor (p error))) + `((diredp-compressed-file-suffix (~ diredp-file-suffix)) + (diredp-date-time (p f01)) + (diredp-deletion (p error)) + (diredp-deletion-file-name (~ diredp-deletion)) + (diredp-dir-heading bf dfg dbg) + (diredp-dir-priv dfg dbg bf) + (diredp-display-msg (p f00)) + (diredp-exec-priv dfg dbg bf) + (diredp-executable-tag (p error)) + (diredp-file-name dfg dbg) + (diredp-file-suffix (~ diredp-file-name)) + (diredp-flag-mark (p f00) bf) + (diredp-flag-mark-line (p hilite)) + (diredp-ignored-file-name (p dimm)) + (diredp-link-priv (~ diredp-symlink)) + (diredp-no-priv (~ diredp-read-priv)) + (diredp-other-priv dfg dbg) + (diredp-rare-priv dfg dfg) + (diredp-read-priv dfg dbg bf) + (diredp-symlink (p warning)) + (diredp-write-priv dfg dbg bf)) + `((change-log-acknowledgement (p f02)) + (change-log-conditionals (p f02)) + (change-log-date (p f01)) + (change-log-email (p f00)) + (change-log-file (p f10)) + (change-log-function (p function)) + (change-log-list (p f11)) + (change-log-name (p keyword)) + (comint-highlight-input (p f01) nbf) + (comint-highlight-prompt (p f00)) + (company-tooltip (~ highlight)) + (company-tooltip-selection (~ company-tooltip) ul) + (company-tooltip-common (~ company-tooltip) bf) + (company-tooltip-common-selection + (~ company-tooltip-selection) bf) + (company-preview (~ highlight)) + (company-preview-common (~ company-preview) bf) + (compilation-column-number (p f00) nul) + (compilation-error nbf (p error) nul) + (compilation-info nbf (p f02) nul) + (compilation-line-number (p f01) nul) + (compilation-warning nbf (p warning) nul) + (completions-common-part nbf :width normal) + (completions-first-difference bf dfg dbg) + (cursor dfg dbg) + (custom-button (~ button)) + (custom-button-mouse (~ button)) + (custom-button-pressed (~ button)) + (custom-button-pressed-unraised (~ button)) + (custom-button-unraised (~ button)) + (custom-changed (p warning)) + (custom-comment (p string)) + (custom-comment-tag (p keyword)) + (custom-documentation (p string)) + (custom-face-tag nbf) + (custom-group-tag bf (p f00) :height 11) + (custom-group-tag-1 bf :family ,jao-themes--face-family + (p f00) :height 11) + (custom-invalid (p error)) + (custom-link link) + (custom-modified (p f10)) + (custom-rogue (p error)) + (custom-saved ul) + (custom-set (p f11)) + (custom-state (p f12)) + (custom-themed (p f00)) + (custom-variable-button (~ button)) + (custom-variable-tag (p variable-name) bf) + (cvs-handled (p dimm))) + `((darcsum-change-line-face (p warning)) + (darcsum-filename-face (p f00)) + (darcsum-header-face (p f01)) + (darcsum-marked-face (p f00) bf) + (darcsum-need-action-face (p warning)) + (darcsum-need-action-marked-face bf (p warning)) + (diary (p f02)) + (diff-added (p warning)) + (diff-changed (p f02)) + (diff-context (p dimm)) + (diff-file-header dfg dbg nbf) + (diff-function (p function)) + (diff-header nbf dfg dbg) + (diff-hunk-header (~ diff-file-header)) + (diff-index bf dfg dbg) + (diff-indicator-added (~ diff-added)) + (diff-indicator-changed (~ diff-changed)) + (diff-indicator-removed (~ diff-removed)) + (diff-nonexistent bf (p error)) + (diff-refine-change (~ diff-changed) ul) + (diff-removed (p error)) + (dired-directory (p f02)) + (dired-flagged bf) + (dired-header (p f01)) + (dired-ignored (p dimm)) + (dired-mark (p f00) bf) + (dired-marked bf (p f00)) + (dired-symlink (p f11)) + (dired-warn-writable (p warning)) + (dired-warning (p warning))) + `((ediff-current-diff-A (~ diff-added)) + (ediff-current-diff-Ancestor (c nil ,jao-themes--box)) + (ediff-current-diff-B (~ ediff-current-diff-A)) + (ediff-current-diff-C (~ ediff-current-diff-A)) + (ediff-even-diff-A (~ diff-added) bf) + (ediff-even-diff-Ancestor (c nil ,jao-themes--box)) + (ediff-even-diff-B (~ ediff-even-diff-A)) + (ediff-even-diff-C (~ ediff-even-diff-A)) + (ediff-fine-diff-A (~ ediff-current-diff-A) nbf ul) + (ediff-fine-diff-Ancestor (c nil ,jao-themes--box)) + (ediff-fine-diff-B (~ ediff-fine-diff-A)) + (ediff-fine-diff-C (~ ediff-fine-diff-A)) + (ediff-odd-diff-A (~ ediff-even-diff-A)) + (ediff-odd-diff-Ancestor (~ ediff-odd-diff-A) nbf) + (ediff-odd-diff-B (~ ediff-odd-diff-A)) + (ediff-odd-diff-C (~ ediff-odd-diff-A)) + (emms-browser-album-face (p f00) :height 1.0) + (emms-browser-artist-face (p f01) :height 1.0) + (emms-browser-composer-face (p f02) :height 1.0) + (emms-browser-track-face (p f10) :height 1.0) + (emms-browser-year/genre-face (p f11) :height 1.0) + (emms-metaplaylist-mode-current-face (p f00) bf) + (emms-metaplaylist-mode-face (p f00)) + (emms-playlist-selected-face (p f00) bf) + (emms-playlist-track-face (p f00) nbf) + (emms-stream-name-face (p f00)) + (emms-stream-url-face link) + (epa-field-body) + (epa-field-name bf) + (epa-mark bf (p f00)) + (epa-string (p f01)) + (epa-validity-disabled) + (epa-validity-high bf) + (epa-validity-low) + (epa-validity-medium) + (escape-glyph (p dimm)) + (eshell-ls-archive (p f12)) + (eshell-ls-backup (p dimm)) + (eshell-ls-clutter (p dimm)) + (eshell-ls-directory (p f02)) + (eshell-ls-executable (p warning)) + (eshell-ls-missing (p dimm)) + (eshell-ls-product (p f01)) + (eshell-ls-readonly (p f01) bf) + (eshell-ls-special bf (p f10)) + (eshell-ls-symlink bf (p f11)) + (eshell-ls-unreadable (p dimm)) + (eshell-prompt (p f00))) + `((factor-font-lock-comment (~ font-lock-comment-face)) + (factor-font-lock-constructor (~ font-lock-function-name-face)) + (factor-font-lock-declaration (~ font-lock-type-face)) + (factor-font-lock-getter-word (~ font-lock-function-name-face)) + (factor-font-lock-parsing-word (~ font-lock-keyword-face)) + (factor-font-lock-setter-word (~ font-lock-function-name-face)) + (factor-font-lock-stack-effect (~ font-lock-comment-face)) + (factor-font-lock-string (~ font-lock-string-face)) + (factor-font-lock-symbol (~ font-lock-keyword-face)) + (factor-font-lock-symbol-definition (~ font-lock-builtin-face)) + (factor-font-lock-type-definition (~ font-lock-type-face)) + (factor-font-lock-type-name (~ font-lock-type-face)) + (factor-font-lock-vocabulary-name (~ font-lock-constant-face)) + (factor-font-lock-word (~ font-lock-function-name-face)) + (ffap) + (file-name-shadow (p dimm)) + (fixed-pitch :family ,jao-themes--face-family) + (flyspell-duplicate nbf (p warning)) + (flyspell-incorrect nbf (p error)) + (font-lock-builtin-face (p keyword)) + (font-lock-comment-delimiter-face (p comment)) + (font-lock-comment-face (p comment)) + (font-lock-constant-face (p constant)) + (font-lock-doc-face (p comment)) + (font-lock-function-name-face (p function)) + (font-lock-keyword-face (p keyword)) + (font-lock-negation-char-face nil) + (font-lock-preprocessor-face (p constant)) + (font-lock-regexp-grouping-backslash bf) + (font-lock-regexp-grouping-construct bf) + (font-lock-string-face (p string)) + (font-lock-type-face (p type)) + (font-lock-variable-name-face (p variable-name)) + (font-lock-warning-face (p warning)) + (fringe nil) + (fuel-font-lock-debug-error (p error) nul) + (fuel-font-lock-debug-info (p f01) nul) + (fuel-font-lock-stack-region (p hilite)) + (fuel-font-lock-xref-link link nul) + (fuel-font-lock-xref-vocab italic nul) + (fuel-font-lock-markup-link link) + (fuel-font-lock-markup-title (~ outline-1)) + (fuel-font-lock-markup-emphasis (~ italic)) + (fuel-font-lock-markup-heading (~ outline-1)) + (fuel-font-lock-markup-strong (~ bold))) + `((geiser-font-lock-autodoc-current-arg (~ highlight)) + (geiser-font-lock-autodoc-identifier + (~ font-lock-function-name-face)) + (geiser-font-lock-doc-button (~ button)) + (geiser-font-lock-doc-link link) + (geiser-font-lock-doc-title bf) + (geiser-font-lock-xref-header bf) + (geiser-font-lock-xref-link link nul) + (gnus-button (~ button)) + (gnus-cite-attribution nil) + (gnus-cite-1 (p f10)) + (gnus-cite-2 (p f11)) + (gnus-cite-3 (p f12)) + (gnus-cite-4 (p dimm)) + (gnus-cite-5 (p dimm)) + (gnus-cite-6 (p dimm)) + (gnus-cite-7 (p dimm)) + (gnus-cite-8 (p dimm)) + (gnus-cite-9 (p dimm)) + (gnus-cite-10 (p dimm)) + (gnus-cite-11 (p dimm)) + (gnus-emphasis-bold bf) + (gnus-emphasis-bold-italic bf) + (gnus-emphasis-highlight-words (p hilite)) + (gnus-emphasis-italic nil) + (gnus-emphasis-strikethru st) + (gnus-emphasis-underline ul) + (gnus-emphasis-underline-bold bf ul) + (gnus-emphasis-underline-bold-italic bf ul) + (gnus-emphasis-underline-italic ul) + (gnus-group-mail-1 (p gnus-mail) bf) + (gnus-group-mail-1-empty (p gnus-mail) nbf) + (gnus-group-mail-2 (~ gnus-group-mail-1)) + (gnus-group-mail-2-empty (~ gnus-group-mail-1-empty)) + (gnus-group-mail-3 (~ gnus-group-mail-1)) + (gnus-group-mail-3-empty (~ gnus-group-mail-1-empty)) + (gnus-group-mail-4 (~ gnus-group-mail-1)) + (gnus-group-mail-4-empty (~ gnus-group-mail-1-empty)) + (gnus-group-mail-5 (p f00) bf) + (gnus-group-mail-5-empty (p f00)) + (gnus-group-mail-6 (p dimm) bf) + (gnus-group-mail-6-empty (p dimm)) + (gnus-group-mail-low bf (p dimm)) + (gnus-group-mail-low-empty (p dimm)) + (gnus-group-news-low bf (p dimm)) + (gnus-group-news-low-empty (p dimm)) + (gnus-group-news-1 (p gnus-news) bf) + (gnus-group-news-1-empty (p gnus-news) nbf) + (gnus-group-news-2 (~ gnus-group-news-1)) + (gnus-group-news-2-empty (~ gnus-group-news-1-empty)) + (gnus-group-news-3 (~ gnus-group-news-1)) + (gnus-group-news-3-empty (~ gnus-group-news-1-empty)) + (gnus-group-news-4 (~ gnus-group-news-1)) + (gnus-group-news-4-empty (~ gnus-group-news-1-empty)) + (gnus-group-news-5 (p f00) bf) + (gnus-group-news-5-empty (p f00)) + (gnus-group-news-6 (p dimm) bf) + (gnus-group-news-6-empty (p dimm)) + (gnus-header-content (p f02)) + (gnus-header-from (p f01)) + (gnus-header-name nbf (p f02)) + (gnus-header-newsgroups (p dimm)) + (gnus-header-subject (p f00) nbf) + (gnus-mouse-face nil) + (gnus-server-agent nbf) + (gnus-server-closed (p warning)) + (gnus-server-denied bf (p error)) + (gnus-server-offline (p dimm)) + (gnus-server-opened bf) + (gnus-signature nit (p f10)) + (gnus-splash dfg dbg) + (gnus-summary-high-undownloaded bf nit dfg dbg) + (gnus-summary-cancelled (p strike-through)) + (gnus-summary-high-unread bf nit) + (gnus-summary-normal-ancient (p dimm)) + (gnus-summary-normal-read (p dimm)) + (gnus-summary-high-ticked bf nit dfg dbg) + (gnus-summary-low-ancient (p dimm)) + (gnus-summary-low-read (p dimm) st) + (gnus-summary-low-ticked (p dimm)) + (gnus-summary-low-unread (p dimm)) + (gnus-summary-low-undownloaded (p dimm)) + (gnus-summary-normal-ancient (p dimm)) + (gnus-summary-normal-read (p dimm)) + (gnus-summary-normal-ticked (p f10) nbf) + (gnus-summary-normal-undownloaded bf dfg dbg) + (gnus-summary-normal-unread dfg dbg) + (gnus-summary-selected (p hilite)) + (gnus-x-face) + (gui-button-face (~ button)) + (gui-element (~ gui-button-face))) + `((header-line (~ mode-line)) + (help-argument-name) + (highlight (p hilite))) + `((ido-first-match (p warning)) + (ido-incomplete-regexp (p error)) + (ido-indicator (p error) nbf) + (ido-only-match (p f00)) + (ido-subdir (p f01)) + (info-header-node bf dfg) + (info-header-xref dfg) + (info-menu-header bf) + (info-menu-star bf dfg) + (info-node (p f00)) + (info-title-1 (~ outline-1) bf) + (info-title-2 (~ outline-2) bf) + (info-title-3 (~ outline-3) bf) + (info-title-4 (~ outline-4) bf) + (info-xref link) + (info-xref-visited vlink) + (isearch bf (p hilite)) + (isearch-fail (p error)) + (italic (p italic))) + `((jabber-activity-face dbg dfg nbf) + (jabber-activity-personal-face (p warning) nbf) + (jabber-chat-error (p error)) + (jabber-chat-prompt-foreign (p f00) nbf) + (jabber-chat-prompt-local (p f01) nbf) + (jabber-chat-prompt-system (p f02) nbf) + (jabber-rare-time-face (p dimm)) + (jabber-roster-user-away (p dimm)) + (jabber-roster-user-chatty (p warning) nbf) + (jabber-roster-user-offline (p dimm)) + (jabber-roster-user-online (p f01) nbf) + (jabber-roster-user-xa (p dimm)) + (jabber-title-large (~ default) bf) + (jabber-title-medium bf) + (jabber-title-roster bf (p warning)) + (jao-emms-font-lock-album (p f01)) + (jao-emms-font-lock-artist (p f02)) + (jao-emms-font-lock-title (p f01)) + (jao-emms-font-lock-track dfg dbg) + (jao-frm-from-face (p f00)) + (jao-frm-mailbox-face bf) + (jao-frm-subject-face (p f01)) + (jao-frm-mailno-face bf) + (jao-gnus-face-tree (p dimm)) + (jde-java-font-lock-constant-face (~ font-lock-constant-face)) + (jde-java-font-lock-doc-tag-face (p f02)) + (jde-java-font-lock-package-face (p f02)) + (jde-java-font-lock-link-face (p link)) + (jde-java-font-lock-number-face (~ font-lock-constant-face)) + (jde-java-font-lock-public-face (~ font-lock-keyword-face)) + (jde-java-font-lock-private-face (~ font-lock-keyword-face)) + (jde-java-font-lock-protected-face (~ font-lock-keyword-face)) + (jde-java-font-lock-modifier-face (~ font-lock-keyword-face))) + `((lazy-highlight (p hilite)) + (link link nul) + (link-visited vlink nul)) + `((magit-diff-add (~ diff-added)) + (magit-diff-del (~ diff-removed)) + (magit-diff-file-header (~ diff-file-header)) + (magit-diff-hunk-header (~ diff-hunk-header)) + (magit-diff-none (p dimm)) + (magit-item-highlight (p hilite)) + (magit-item-mark (p warning)) + (magit-log-head-label (p keyword) bf) + (magit-log-tag-label (p keyword)) + (match (p hilite)) + (menu nil) + (message-cited-text (p f01) nbf) + (message-header-cc (p f00) nbf) + (message-header-name (p f01) nbf) + (message-header-newsgroups (p dimm) nbf) + (message-header-other (p f00) nbf) + (message-header-subject (p f00) nbf) + (message-header-to (p f00) nbf) + (message-header-xheader (p f00) nbf) + (message-mml (p warning) nbf) + (message-separator (p warning) nbf) + (mm-uu-extract (p hilite)) + (minibuffer-prompt (p f00)) + (mode-line-buffer-id nbf (c nil nil)) + (mode-line-emphasis (p warning)) + (mode-line-highlight (~ mode-line)) + (modeline-mousable (~ mode-line-active)) + (modeline-mousable-minor-mode (~ modeline-mousable)) + (mouse dfg dbg ul) + (muse-link link) + (muse-verbatim (p f02))) + `((next-error (p hilite)) + (nobreak-space dbg dfg ul)) + `((org-agenda-date-weekend (p dimm)) + (org-agenda-done (p dimm)) + (org-agenda-restriction-lock (~ default)) + (org-agenda-structure (p f00)) + (org-archived (p dimm)) + (org-code (p f02)) + (org-column dfg dbg :height 1.0) + (org-date (p f02) nul) + (org-done (p dimm) nbf niv) + (org-drawer (p f02)) + (org-ellipsis (p dimm)) + (org-formula (p f02)) + (org-headline-done (p dimm)) + (org-hide (c ,jao-themes--bg)) + (org-latex-and-export-specials (~ default)) + (org-level-1 (~ outline-1)) + (org-level-2 (~ outline-2)) + (org-level-3 (~ outline-3)) + (org-level-4 (~ outline-4)) + (org-level-5 (~ outline-5)) + (org-level-6 (~ outline-6)) + (org-level-7 (~ outline-7)) + (org-level-8 (~ outline-8)) + (org-link link) + (org-property-value nil) + (org-scheduled (p f01)) + (org-scheduled-previously (p warning) nbf) + (org-scheduled-today (p f00)) + (org-sexp-date (p f01)) + (org-special-keyword (p keyword)) + (org-table (p f01)) + (org-tag (p dimm) nbf) + (org-target ul) + (org-time-grid dfg dbg) + (org-todo bf niv (p warning)) + (org-upcoming-deadline (p f02)) + (org-verbatim (p hilite)) + (org-warning bf (p warning)) + (outline-1 bf (p outline)) + (outline-2 bf (p outline)) + (outline-3 nbf (p outline)) + (outline-4 nbf (p outline)) + (outline-5 nbf (p outline)) + (outline-6 nbf (p outline)) + (outline-7 nbf (p outline)) + (outline-8 nbf (p outline))) + `((query-replace bf (p hilite))) + `((rcirc-bright-nick (p hilite)) + (rcirc-my-nick (p error)) + (rcirc-nick-in-message (p error)) + (rcirc-nick-in-message-full-line nbf) + (rcirc-other-nick (p keyword)) + (rcirc-prompt bf) + (rcirc-server (p dimm)) + (rcirc-timestamp (p dimm)) + (rcirc-track-nick (~ rcirc-my-nick) niv) + (rcirc-url nbf link) + (reb-match-0 (p hilite)) + (reb-match-1 (~ secondary-selection)) + (reb-match-2 (~ secondary-selection) bf) + (reb-match-3 (~ secondary-selection) ul) + (region (p hilite))) + `((secondary-selection (p hilite)) + (sh-quoted-exec (p f00)) + (show-paren-match (p hilite)) + (show-paren-mismatch (p error)) + (slime-repl-prompt-face (p f00)) + (slime-repl-input-face (p f00) bf) + (slime-repl-inputed-output-face (p f02)) + (slime-repl-output-face (p string)) + (speedbar-directory-face (~ diredp-dir-heading)) + (speedbar-file-face (~ diredp-file-name)) + (speedbar-highlight-face (p hilite)) + (speedbar-selected-face ul) + (speedbar-separator-face (p f00)) + (scroll-bar nil) + (shadow nil)) + `((tool-bar nil) + (tooltip :family ,jao-themes--face-family (c nil "lightyellow")) + (trailing-whitespace (p error))) + `((underline nul)) + `((variable-pitch :family ,jao-themes--face-family :height 11) + (vertical-border (c ,jao-themes--box nil) :inherit default)) + `((w3m-anchor link) + (w3m-arrived-anchor vlink) + (w3m-bold bf dbg dfg) + (w3m-current-anchor nbf ul) + (w3m-form dfg dbg ul) + (w3m-form-button (~ button)) + (w3m-form-button-mouse (~ custom-button-mouse)) + (w3m-form-button-pressed (~ custom-button-pressed)) + (w3m-header-line-location-content + :box (:line-width 3 :color ,jao-themes--bg) dfg dbg) + (w3m-header-line-location-title + :box (:line-width 3 :color ,jao-themes--bg) dfg dbg) + (w3m-history-current-url (c nil nil) ul) + (w3m-image (p f10)) + (w3m-image-anchor (c nil nil)) + (w3m-insert (p f12)) + (w3m-italic (~ italic)) + (w3m-linknum-match (p warning)) + (w3m-linknum-minibuffer-prompt (~ minibuffer-prompt)) + (w3m-session-select (p f10)) + (w3m-session-selected bf nul (p f10)) + (w3m-strike-through st) + (w3m-tab-background nul (c nil nil)) + (w3m-tab-mouse nil) + (w3m-tab-selected (p tab-sel)) + (w3m-tab-selected-background nil) + (w3m-tab-selected-retrieving (p tab-sel) it) + (w3m-tab-unselected (p tab-unsel)) + (w3m-tab-unselected-retrieving (p tab-unsel) it) + (w3m-tab-unselected-unseen (p tab-unsel)) + (w3m-underline ul) + (widget-button (~ button)) + (widget-button-pressed nbf (~ custom-button-pressed)) + (widget-button-face (~ button)) + (widget-button-pressed-face (~ button)) + (widget-documentation (p dimm)) + (widget-field (p hilite) bx) + (widget-inactive (p dimm)) + (Widget-single-line-field (~ widget-field)) + (woman-bold (p f00) bf) + (woman-italic (p f01) nul nit) + (woman-italic-no-ul (p f01) nul nit))))) + (dolist (df dfs fs) + (when (not (assq (car df) fs)) + (push df fs))))) + +(defsubst jao-themes--let-palette (palette xp) + (mapcar (lambda (f) + `(,(jao-themes--palette-face (car f)) + ',(or (and xp (caddr f)) (cadr f)))) + palette)) + +(defun jao-themes--extract-faces (t-faces x-faces) + (let ((result)) + (dolist (f t-faces (reverse result)) + (let ((xfb (cdr (assq (car f) x-faces)))) + (push `(,(car f) ((((type x darwin)) ,@xfb) + (t ,@(cdr f)))) result))))) + +(defun jao-themes--set-fbg (kind) + (let* ((kvs (cdr (assoc kind window-system-default-frame-alist))) + (f-alist (assq-delete-all 'background-color kvs)) + (f-alist (assq-delete-all 'foreground-color f-alist))) + (when jao-themes--fg + (push (cons 'foreground-color jao-themes--fg) f-alist)) + (when jao-themes--bg + (push (cons 'background-color jao-themes--bg) f-alist)) + (setq window-system-default-frame-alist + (cons + (cons kind f-alist) + (assq-delete-all kind window-system-default-frame-alist))))) + +(defmacro jao-define-custom-theme (name &rest args) + (let ((t-faces (make-symbol "t-faces")) + (xfaces (make-symbol "xfaces")) + (tx-faces (make-symbol "tx-faces")) + (palette (cdr (assoc :palette args))) + (faces (cdr (assoc :faces args))) + (x-faces (cdr (assoc :x-faces args))) + (x-colors (cdr (assoc :x-colors args)))) + `(let* ,(jao-themes--let-palette palette nil) + (jao-themes--set-fbg nil) + (let ((,t-faces (jao-themes--make-faces ',faces))) + (let* ,(jao-themes--let-palette palette t) + (jao-themes--set-fbg 'x) + (let* ((,xfaces (jao-themes--make-faces ',x-faces ',x-colors)) + (,tx-faces (jao-themes--extract-faces ,t-faces ,xfaces))) + (deftheme ,name) + (put ',name 'theme-immediate t) + (apply 'custom-theme-set-faces (cons ',name ,tx-faces)) + (provide-theme ',name))))))) + +(put 'jao-define-custom-theme 'lisp-indent-function 1) + + +(provide 'jao-themes) diff --git a/themes/light-ec b/themes/light-ec new file mode 100755 index 0000000..bde38f9 --- /dev/null +++ b/themes/light-ec @@ -0,0 +1,40 @@ +#!/bin/bash + +font=${EC_TERM_FACE:-xft:Inconsolata:size=11,[codeset=iso8859-7]xft:Andale Mono:size=12,[codeset=japanese-jisx0208]xft:Andale Mono:size=12} +ifont=${EC_TERM_FACE_ITALIC:-xft:Inconsolata-11:slant=italic} +#font="xft:DejaVu Sans Mono-9" +#ifont="xft:DejaVu Sans Mono-9:italic" + +frg="black" +bkg="#EFEBE7" + +bw=${EC_TERM_BORDER:-2} +tr=${EC_TRANS_SPEC} + +exec urxvtcd $tr -cr tomato +ptab -bg "$bkg" -bd "$bkg" -fg "$frg" \ + -sl 0 +rv +ssr -b $bw +sbg -fn "${font}" -fi "${ifont}" \ + -xrm "*colorBD: grey20" \ + -xrm "*colorUL: grey20" \ + -xrm "*color0: ${frg}" \ + -xrm "*color8: grey20" \ + -xrm "*color1: sienna3" \ + -xrm "*color9: orangered4" \ + -xrm "*color2: #597B59" \ + -xrm "*color10: #254242" \ + -xrm "*color3: #D38108" \ + -xrm "*color11: #59513A" \ + -xrm "*color4: #3B3152" \ + -xrm "*color12: lemonchiffon4" \ + -xrm "*color5: #E0DACC" \ + -xrm "*color13: #386858" \ + -xrm "*color6: lightyellow3" \ + -xrm "*color14: #1F3D4F" \ + -xrm "*color7: ${bkg}" \ + -xrm "*color15: #EFEBE7" \ + -name "emacsclient" \ + -e emacsclient -t $* + +# fname=${EC_XTERM_FN:-Inconsolata} +# fsize=${EC_XTERM_FS:-11} +# exec xterm -cr tomato -sl 0 +rv -b "$bw" -bg "$bkg" -bd "$bkg" -fg "$frg" \ +# -bdc -ulc -u8 -fa "$fname" -fs $fsize \ |