diff options
| author |  Tom Willemsen | 2011-03-17 11:36:56 +0100 |
|---|---|---|
| committer | Tom Willemsen | 2011-03-17 11:37:07 +0100 |
| commit | 82b8ca280905ea284730f228ae082c42c348e818 (patch) | |
| tree | 0c60d42c717905632c32ad80d83397d59c7d5036 | |
| parent | 04b349e8e00c2720fed4b14b7a1e0616db27ad2f (diff) | |
| download | dotfiles-82b8ca280905ea284730f228ae082c42c348e818.tar.gz dotfiles-82b8ca280905ea284730f228ae082c42c348e818.zip | |
Big emacs cleanup, must be lighter
48 files changed, 2 insertions, 23193 deletions
diff --git a/emacs.d/10-modules.el b/emacs.d/10-modules.el index 6a9b01d..7701bc3 100644 --- a/emacs.d/10-modules.el +++ b/emacs.d/10-modules.el @@ -1,9 +1,5 @@ -(require 'minimap) (require 'naquadah-theme) -;(require 'auto-complete-clang) -(require 'muse-mode) -(require 'muse-html) -(require 'muse-project) +(require 'autopair) (load "autostart.el") diff --git a/emacs.d/10-settings.el b/emacs.d/10-settings.el index 6a43f8a..45c9601 100644 --- a/emacs.d/10-settings.el +++ b/emacs.d/10-settings.el @@ -22,6 +22,7 @@ (global-font-lock-mode t) ; show syntax highlighting, old (show-paren-mode t) ; show matching parens (delete-selection-mode t) ; delete selection upon typing +(autopair-global-mode) ;; Byte-compile elisp files on save (add-hook 'before-save-hook 'delete-trailing-whitespace) diff --git a/emacs.d/20-auto-complete.el b/emacs.d/20-auto-complete.el deleted file mode 100644 index 5d8fb59..0000000 --- a/emacs.d/20-auto-complete.el +++ /dev/null @@ -1,12 +0,0 @@ -(require 'auto-complete-config) -(add-to-list 'ac-dictionary-directories "~/.emacs.d/ac-dict") -(ac-config-default) - -(global-auto-complete-mode -1) - -(add-hook 'emacs-lisp-mode-hook - (lambda() - (auto-complete-mode t))) -(add-hook 'lisp-interaction-mode-hook - (lambda () - (auto-complete-mode t))) diff --git a/emacs.d/20-autopair.el b/emacs.d/20-autopair.el deleted file mode 100644 index abc330c..0000000 --- a/emacs.d/20-autopair.el +++ /dev/null @@ -1,3 +0,0 @@ -(require 'autopair) - -(autopair-global-mode) diff --git a/emacs.d/20-flymake.el b/emacs.d/20-flymake.el deleted file mode 100644 index 5dad1a9..0000000 --- a/emacs.d/20-flymake.el +++ /dev/null @@ -1,2 +0,0 @@ -(require 'flymake) -(add-hook 'find-file-hook 'flymake-find-file-hook) diff --git a/emacs.d/50-muse-projects.el b/emacs.d/50-muse-projects.el deleted file mode 100644 index 086ab60..0000000 --- a/emacs.d/50-muse-projects.el +++ /dev/null @@ -1,3 +0,0 @@ -(setq muse-project-alist - '(("lxcoding-docs" ("~/prj/lxcoding-docs" :default "index") - (:base "html" :path "~/devel/mnt/lxcoding/www/docs")))) diff --git a/emacs.d/auto-complete-clang b/emacs.d/auto-complete-clang deleted file mode 160000 -Subproject 9db79f4a88e22041c6cc1acfa834bb7ff8bec45 diff --git a/emacs.d/elisp/auto-complete-config.el b/emacs.d/elisp/auto-complete-config.el deleted file mode 100644 index 26ec044..0000000 --- a/emacs.d/elisp/auto-complete-config.el +++ /dev/null @@ -1,480 +0,0 @@ -;;; auto-complete-config.el --- auto-complete additional configuations - -;; Copyright (C) 2009, 2010 Tomohiro Matsuyama - -;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com> -;; Keywords: convenience -;; Version: 1.3 - -;; 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: - -;; - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(require 'auto-complete) - - - -;;;; Additional sources - -;; imenu - -(defvar ac-imenu-index nil) - -(ac-clear-variable-every-10-minutes 'ac-imenu-index) - -(defun ac-imenu-candidates () - (loop with i = 0 - with stack = (progn - (unless (local-variable-p 'ac-imenu-index) - (make-local-variable 'ac-imenu-index)) - (or ac-imenu-index - (setq ac-imenu-index - (ignore-errors - (with-no-warnings - (imenu--make-index-alist)))))) - with result - while (and stack (or (not (integerp ac-limit)) - (< i ac-limit))) - for node = (pop stack) - if (consp node) - do - (let ((car (car node)) - (cdr (cdr node))) - (if (consp cdr) - (mapc (lambda (child) - (push child stack)) - cdr) - (when (and (stringp car) - (string-match (concat "^" (regexp-quote ac-prefix)) car)) - ;; Remove extra characters - (if (string-match "^.*\\(()\\|=\\|<>\\)$" car) - (setq car (substring car 0 (match-beginning 1)))) - (push car result) - (incf i)))) - finally return (nreverse result))) - -(ac-define-source imenu - '((depends imenu) - (candidates . ac-imenu-candidates) - (symbol . "s"))) - -;; gtags - -(defface ac-gtags-candidate-face - '((t (:background "lightgray" :foreground "navy"))) - "Face for gtags candidate" - :group 'auto-complete) - -(defface ac-gtags-selection-face - '((t (:background "navy" :foreground "white"))) - "Face for the gtags selected candidate." - :group 'auto-complete) - -(defun ac-gtags-candidate () - (ignore-errors - (split-string (shell-command-to-string (format "global -ci %s" ac-prefix)) "\n"))) - -(ac-define-source gtags - '((candidates . ac-gtags-candidate) - (candidate-face . ac-gtags-candidate-face) - (selection-face . ac-gtags-selection-face) - (requires . 3) - (symbol . "s"))) - -;; yasnippet - -(defface ac-yasnippet-candidate-face - '((t (:background "sandybrown" :foreground "black"))) - "Face for yasnippet candidate." - :group 'auto-complete) - -(defface ac-yasnippet-selection-face - '((t (:background "coral3" :foreground "white"))) - "Face for the yasnippet selected candidate." - :group 'auto-complete) - -(defun ac-yasnippet-table-hash (table) - (cond - ((fboundp 'yas/snippet-table-hash) - (yas/snippet-table-hash table)) - ((fboundp 'yas/table-hash) - (yas/table-hash table)))) - -(defun ac-yasnippet-table-parent (table) - (cond - ((fboundp 'yas/snippet-table-parent) - (yas/snippet-table-parent table)) - ((fboundp 'yas/table-parent) - (yas/table-parent table)))) - -(defun ac-yasnippet-candidate-1 (table) - (with-no-warnings - (let ((hashtab (ac-yasnippet-table-hash table)) - (parent (ac-yasnippet-table-parent table)) - candidates) - (maphash (lambda (key value) - (push key candidates)) - hashtab) - (setq candidates (all-completions ac-prefix (nreverse candidates))) - (if parent - (setq candidates - (append candidates (ac-yasnippet-candidate-1 parent)))) - candidates))) - -(defun ac-yasnippet-candidates () - (with-no-warnings - (if (fboundp 'yas/get-snippet-tables) - ;; >0.6.0 - (apply 'append (mapcar 'ac-yasnippet-candidate-1 (yas/get-snippet-tables major-mode))) - (let ((table - (if (fboundp 'yas/snippet-table) - ;; <0.6.0 - (yas/snippet-table major-mode) - ;; 0.6.0 - (yas/current-snippet-table)))) - (if table - (ac-yasnippet-candidate-1 table)))))) - -(ac-define-source yasnippet - '((depends yasnippet) - (candidates . ac-yasnippet-candidates) - (action . yas/expand) - (candidate-face . ac-yasnippet-candidate-face) - (selection-face . ac-yasnippet-selection-face) - (symbol . "a"))) - -;; semantic - -(defun ac-semantic-candidates (prefix) - (with-no-warnings - (delete "" ; semantic sometimes returns an empty string - (mapcar 'semantic-tag-name - (ignore-errors - (or (semantic-analyze-possible-completions - (semantic-analyze-current-context)) - (senator-find-tag-for-completion prefix))))))) - -(ac-define-source semantic - '((available . (or (require 'semantic-ia nil t) - (require 'semantic/ia nil t))) - (candidates . (ac-semantic-candidates ac-prefix)) - (prefix . c-dot-ref) - (requires . 0) - (symbol . "m"))) - -(ac-define-source semantic-raw - '((available . (or (require 'semantic-ia nil t) - (require 'semantic/ia nil t))) - (candidates . (ac-semantic-candidates ac-prefix)) - (symbol . "s"))) - -;; eclim - -(defun ac-eclim-candidates () - (with-no-warnings - (loop for c in (eclim/java-complete) - collect (nth 1 c)))) - -(ac-define-source eclim - '((candidates . ac-eclim-candidates) - (prefix . c-dot) - (requires . 0) - (symbol . "f"))) - -;; css - -;; Copied from company-css.el -(defconst ac-css-property-alist - ;; see http://www.w3.org/TR/CSS21/propidx.html - '(("azimuth" angle "left-side" "far-left" "left" "center-left" "center" - "center-right" "right" "far-right" "right-side" "behind" "leftwards" - "rightwards") - ("background" background-color background-image background-repeat - background-attachment background-position) - ("background-attachment" "scroll" "fixed") - ("background-color" color "transparent") - ("background-image" uri "none") - ("background-position" percentage length "left" "center" "right" percentage - length "top" "center" "bottom" "left" "center" "right" "top" "center" - "bottom") - ("background-repeat" "repeat" "repeat-x" "repeat-y" "no-repeat") - ("border" border-width border-style border-color) - ("border-bottom" border) - ("border-bottom-color" border-color) - ("border-bottom-style" border-style) - ("border-bottom-width" border-width) - ("border-collapse" "collapse" "separate") - ("border-color" color "transparent") - ("border-left" border) - ("border-left-color" border-color) - ("border-left-style" border-style) - ("border-left-width" border-width) - ("border-right" border) - ("border-right-color" border-color) - ("border-right-style" border-style) - ("border-right-width" border-width) - ("border-spacing" length length) - ("border-style" border-style) - ("border-top" border) - ("border-top-color" border-color) - ("border-top-style" border-style) - ("border-top-width" border-width) - ("border-width" border-width) - ("bottom" length percentage "auto") - ("caption-side" "top" "bottom") - ("clear" "none" "left" "right" "both") - ("clip" shape "auto") - ("color" color) - ("content" "normal" "none" string uri counter "attr()" "open-quote" - "close-quote" "no-open-quote" "no-close-quote") - ("counter-increment" identifier integer "none") - ("counter-reset" identifier integer "none") - ("cue" cue-before cue-after) - ("cue-after" uri "none") - ("cue-before" uri "none") - ("cursor" uri "*" "auto" "crosshair" "default" "pointer" "move" "e-resize" - "ne-resize" "nw-resize" "n-resize" "se-resize" "sw-resize" "s-resize" - "w-resize" "text" "wait" "help" "progress") - ("direction" "ltr" "rtl") - ("display" "inline" "block" "list-item" "run-in" "inline-block" "table" - "inline-table" "table-row-group" "table-header-group" "table-footer-group" - "table-row" "table-column-group" "table-column" "table-cell" - "table-caption" "none") - ("elevation" angle "below" "level" "above" "higher" "lower") - ("empty-cells" "show" "hide") - ("float" "left" "right" "none") - ("font" font-style font-variant font-weight font-size "/" line-height - font-family "caption" "icon" "menu" "message-box" "small-caption" - "status-bar") - ("font-family" family-name generic-family) - ("font-size" absolute-size relative-size length percentage) - ("font-style" "normal" "italic" "oblique") - ("font-variant" "normal" "small-caps") - ("font-weight" "normal" "bold" "bolder" "lighter" "100" "200" "300" "400" - "500" "600" "700" "800" "900") - ("height" length percentage "auto") - ("left" length percentage "auto") - ("letter-spacing" "normal" length) - ("line-height" "normal" number length percentage) - ("list-style" list-style-type list-style-position list-style-image) - ("list-style-image" uri "none") - ("list-style-position" "inside" "outside") - ("list-style-type" "disc" "circle" "square" "decimal" "decimal-leading-zero" - "lower-roman" "upper-roman" "lower-greek" "lower-latin" "upper-latin" - "armenian" "georgian" "lower-alpha" "upper-alpha" "none") - ("margin" margin-width) - ("margin-bottom" margin-width) - ("margin-left" margin-width) - ("margin-right" margin-width) - ("margin-top" margin-width) - ("max-height" length percentage "none") - ("max-width" length percentage "none") - ("min-height" length percentage) - ("min-width" length percentage) - ("orphans" integer) - ("outline" outline-color outline-style outline-width) - ("outline-color" color "invert") - ("outline-style" border-style) - ("outline-width" border-width) - ("overflow" "visible" "hidden" "scroll" "auto") - ("padding" padding-width) - ("padding-bottom" padding-width) - ("padding-left" padding-width) - ("padding-right" padding-width) - ("padding-top" padding-width) - ("page-break-after" "auto" "always" "avoid" "left" "right") - ("page-break-before" "auto" "always" "avoid" "left" "right") - ("page-break-inside" "avoid" "auto") - ("pause" time percentage) - ("pause-after" time percentage) - ("pause-before" time percentage) - ("pitch" frequency "x-low" "low" "medium" "high" "x-high") - ("pitch-range" number) - ("play-during" uri "mix" "repeat" "auto" "none") - ("position" "static" "relative" "absolute" "fixed") - ("quotes" string string "none") - ("richness" number) - ("right" length percentage "auto") - ("speak" "normal" "none" "spell-out") - ("speak-header" "once" "always") - ("speak-numeral" "digits" "continuous") - ("speak-punctuation" "code" "none") - ("speech-rate" number "x-slow" "slow" "medium" "fast" "x-fast" "faster" - "slower") - ("stress" number) - ("table-layout" "auto" "fixed") - ("text-align" "left" "right" "center" "justify") - ("text-decoration" "none" "underline" "overline" "line-through" "blink") - ("text-indent" length percentage) - ("text-transform" "capitalize" "uppercase" "lowercase" "none") - ("top" length percentage "auto") - ("unicode-bidi" "normal" "embed" "bidi-override") - ("vertical-align" "baseline" "sub" "super" "top" "text-top" "middle" - "bottom" "text-bottom" percentage length) - ("visibility" "visible" "hidden" "collapse") - ("voice-family" specific-voice generic-voice "*" specific-voice - generic-voice) - ("volume" number percentage "silent" "x-soft" "soft" "medium" "loud" - "x-loud") - ("white-space" "normal" "pre" "nowrap" "pre-wrap" "pre-line") - ("widows" integer) - ("width" length percentage "auto") - ("word-spacing" "normal" length) - ("z-index" "auto" integer)) - "A list of CSS properties and their possible values.") - -(defconst ac-css-value-classes - '((absolute-size "xx-small" "x-small" "small" "medium" "large" "x-large" - "xx-large") - (border-style "none" "hidden" "dotted" "dashed" "solid" "double" "groove" - "ridge" "inset" "outset") - (color "aqua" "black" "blue" "fuchsia" "gray" "green" "lime" "maroon" "navy" - "olive" "orange" "purple" "red" "silver" "teal" "white" "yellow" - "rgb") - (counter "counter") - (family-name "Courier" "Helvetica" "Times") - (generic-family "serif" "sans-serif" "cursive" "fantasy" "monospace") - (generic-voice "male" "female" "child") - (margin-width "auto") ;; length percentage - (relative-size "larger" "smaller") - (shape "rect") - (uri "url")) - "A list of CSS property value classes and their contents.") - -(defconst ac-css-pseudo-classes - '("active" "after" "before" "first" "first-child" "first-letter" "first-line" - "focus" "hover" "lang" "left" "link" "right" "visited") - "Identifiers for CSS pseudo-elements and pseudo-classes.") - -(defvar ac-css-property nil - "Current editing property.") - -(defun ac-css-prefix () - (when (save-excursion (re-search-backward "\\_<\\(.+?\\)\\_>\\s *:.*\\=" nil t)) - (setq ac-css-property (match-string 1)) - (or (ac-prefix-symbol) (point)))) - -(defun ac-css-property-candidates () - (or (loop with list = (assoc-default ac-css-property ac-css-property-alist) - with value - while (setq value (pop list)) - if (symbolp value) - do (setq list - (append list - (or (assoc-default value ac-css-value-classes) - (assoc-default (symbol-name value) ac-css-property-alist)))) - else collect value) - ac-css-pseudo-classes)) - -(defvar ac-source-css-property - '((candidates . ac-css-property-candidates) - (prefix . ac-css-prefix) - (requires . 0))) - - - -;;;; Not maintained sources - -;; ropemacs - -(defvar ac-ropemacs-loaded nil) -(defun ac-ropemacs-require () - (with-no-warnings - (unless ac-ropemacs-loaded - (pymacs-load "ropemacs" "rope-") - (if (boundp 'ropemacs-enable-autoimport) - (setq ropemacs-enable-autoimport t)) - (setq ac-ropemacs-loaded t)))) - -(defun ac-ropemacs-setup () - (ac-ropemacs-require) - ;(setq ac-sources (append (list 'ac-source-ropemacs) ac-sources)) - (setq ac-omni-completion-sources '(("\\." ac-source-ropemacs)))) - -(defun ac-ropemacs-initialize () - (autoload 'pymacs-apply "pymacs") - (autoload 'pymacs-call "pymacs") - (autoload 'pymacs-eval "pymacs" nil t) - (autoload 'pymacs-exec "pymacs" nil t) - (autoload 'pymacs-load "pymacs" nil t) - (add-hook 'python-mode-hook 'ac-ropemacs-setup) - t) - -(defvar ac-ropemacs-completions-cache nil) -(defvar ac-source-ropemacs - '((init - . (lambda () - (setq ac-ropemacs-completions-cache - (mapcar - (lambda (completion) - (concat ac-prefix completion)) - (ignore-errors - (rope-completions)))))) - (candidates . ac-ropemacs-completions-cache))) - -;; rcodetools - -(defvar ac-source-rcodetools - '((init . (lambda () - (require 'rcodetools) - (condition-case x - (save-excursion - (rct-exec-and-eval rct-complete-command-name "--completion-emacs-icicles")) - (error) (setq rct-method-completion-table nil)))) - (candidates . (lambda () - (all-completions - ac-prefix - (mapcar - (lambda (completion) - (replace-regexp-in-string "\t.*$" "" (car completion))) - rct-method-completion-table)))))) - - - -;;;; Default settings - -(defun ac-common-setup () - (add-to-list 'ac-sources 'ac-source-filename)) - -(defun ac-emacs-lisp-mode-setup () - (setq ac-sources (append '(ac-source-features ac-source-functions ac-source-yasnippet ac-source-variables ac-source-symbols) ac-sources))) - -(defun ac-cc-mode-setup () - (setq ac-sources (append '(ac-source-yasnippet ac-source-gtags) ac-sources))) - -(defun ac-ruby-mode-setup () - (make-local-variable 'ac-ignores) - (add-to-list 'ac-ignores "end")) - -(defun ac-css-mode-setup () - (setq ac-sources (append '(ac-source-css-property) ac-sources))) - -(defun ac-config-default () - (setq-default ac-sources '(ac-source-abbrev ac-source-dictionary ac-source-words-in-same-mode-buffers)) - (add-hook 'emacs-lisp-mode-hook 'ac-emacs-lisp-mode-setup) - (add-hook 'c-mode-common-hook 'ac-cc-mode-setup) - (add-hook 'ruby-mode-hook 'ac-ruby-mode-setup) - (add-hook 'css-mode-hook 'ac-css-mode-setup) - (add-hook 'auto-complete-mode-hook 'ac-common-setup) - (global-auto-complete-mode t)) - -(provide 'auto-complete-config) -;;; auto-complete-config.el ends here diff --git a/emacs.d/elisp/auto-complete.el b/emacs.d/elisp/auto-complete.el deleted file mode 100644 index 2472dc7..0000000 --- a/emacs.d/elisp/auto-complete.el +++ /dev/null @@ -1,1897 +0,0 @@ -;;; auto-complete.el --- Auto Completion for GNU Emacs - -;; Copyright (C) 2008, 2009, 2010 Tomohiro Matsuyama - -;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com> -;; URL: http://cx4a.org/software/auto-complete -;; Keywords: completion, convenience -;; Version: 1.3 - -;; 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: -;; -;; This extension provides a way to complete with popup menu like: -;; -;; def-!- -;; +-----------------+ -;; |defun::::::::::::| -;; |defvar | -;; |defmacro | -;; | ... | -;; +-----------------+ -;; -;; You can complete by typing and selecting menu. -;; -;; Entire documents are located in doc/ directory. -;; Take a look for information. -;; -;; Enjoy! - -;;; Code: - - - -(eval-when-compile - (require 'cl)) - -(require 'popup) - -;;;; Global stuff - -(defun ac-error (&optional var) - "Report an error and disable `auto-complete-mode'." - (ignore-errors - (message "auto-complete error: %s" var) - (auto-complete-mode -1) - var)) - - - -;;;; Customization - -(defgroup auto-complete nil - "Auto completion." - :group 'completion - :prefix "ac-") - -(defcustom ac-delay 0.1 - "Delay to completions will be available." - :type 'float - :group 'auto-complete) - -(defcustom ac-auto-show-menu 0.8 - "Non-nil means completion menu will be automatically shown." - :type '(choice (const :tag "Yes" t) - (const :tag "Never" nil) - (float :tag "Timer")) - :group 'auto-complete) - -(defcustom ac-show-menu-immediately-on-auto-complete t - "Non-nil means menu will be showed immediately on `auto-complete'." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-expand-on-auto-complete t - "Non-nil means expand whole common part on first time `auto-complete'." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-disable-faces '(font-lock-comment-face font-lock-string-face font-lock-doc-face) - "Non-nil means disable automatic completion on specified faces." - :type '(repeat symbol) - :group 'auto-complete) - -(defcustom ac-stop-flymake-on-completing t - "Non-nil means disble flymake temporarily on completing." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-use-fuzzy t - "Non-nil means use fuzzy matching." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-fuzzy-cursor-color "red" - "Cursor color in fuzzy mode." - :type 'string - :group 'auto-complete) - -(defcustom ac-use-comphist t - "Non-nil means use intelligent completion history." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-comphist-threshold 0.7 - "Percentage of ignoring low scored candidates." - :type 'float - :group 'auto-complete) - -(defcustom ac-comphist-file - (expand-file-name (concat (if (boundp 'user-emacs-directory) - user-emacs-directory - "~/.emacs.d/") - "/ac-comphist.dat")) - "Completion history file name." - :type 'string - :group 'auto-complete) - -(defcustom ac-use-quick-help t - "Non-nil means use quick help." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-quick-help-delay 1.5 - "Delay to show quick help." - :type 'float - :group 'auto-complete) - -(defcustom ac-menu-height 10 - "Max height of candidate menu." - :type 'integer - :group 'auto-complete) -(defvaralias 'ac-candidate-menu-height 'ac-menu-height) - -(defcustom ac-quick-help-height 20 - "Max height of quick help." - :type 'integer - :group 'auto-complete) - -(defcustom ac-quick-help-prefer-x t - "Prefer X tooltip than overlay popup for displaying quick help." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-candidate-limit nil - "Limit number of candidates. Non-integer means no limit." - :type 'integer - :group 'auto-complete) -(defvaralias 'ac-candidate-max 'ac-candidate-limit) - -(defcustom ac-modes - '(emacs-lisp-mode - lisp-interaction-mode - c-mode cc-mode c++-mode - java-mode clojure-mode scala-mode - scheme-mode - ocaml-mode tuareg-mode - perl-mode cperl-mode python-mode ruby-mode - ecmascript-mode javascript-mode js-mode js2-mode php-mode css-mode - makefile-mode sh-mode fortran-mode f90-mode ada-mode - xml-mode sgml-mode) - "Major modes `auto-complete-mode' can run on." - :type '(repeat symbol) - :group 'auto-complete) - -(defcustom ac-compatible-packages-regexp - "^ac-" - "Regexp to indicate what packages can work with auto-complete." - :type 'string - :group 'auto-complete) - -(defcustom ac-trigger-commands - '(self-insert-command) - "Trigger commands that specify whether `auto-complete' should start or not." - :type '(repeat symbol) - :group 'auto-complete) - -(defcustom ac-trigger-commands-on-completing - '(delete-backward-char - backward-delete-char - backward-delete-char-untabify) - "Trigger commands that specify whether `auto-complete' should continue or not." - :type '(repeat symbol) - :group 'auto-complete) - -(defcustom ac-trigger-key nil - "Non-nil means `auto-complete' will start by typing this key. -If you specify this TAB, for example, `auto-complete' will start by typing TAB, -and if there is no completions, an original command will be fallbacked." - :type 'string - :group 'auto-complete - :set (lambda (symbol value) - (set-default symbol value) - (when (and value - (fboundp 'ac-set-trigger-key)) - (ac-set-trigger-key value)))) - -(defcustom ac-auto-start 2 - "Non-nil means completion will be started automatically. -Positive integer means if a length of a word you entered is larger than the value, -completion will be started automatically. -If you specify `nil', never be started automatically." - :type '(choice (const :tag "Yes" t) - (const :tag "Never" nil) - (integer :tag "Require")) - :group 'auto-complete) - -(defcustom ac-ignores nil - "List of string to ignore completion." - :type '(repeat string) - :group 'auto-complete) - -(defcustom ac-ignore-case 'smart - "Non-nil means auto-complete ignores case. -If this value is `smart', auto-complete ignores case only when -a prefix doen't contain any upper case letters." - :type '(choice (const :tag "Yes" t) - (const :tag "Smart" smart) - (const :tag "No" nil)) - :group 'auto-complete) - -(defcustom ac-dwim t - "Non-nil means `auto-complete' works based on Do What I Mean." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-use-menu-map nil - "Non-nil means a special keymap `ac-menu-map' on completing menu will be used." - :type 'boolean - :group 'auto-complete) - -(defcustom ac-use-overriding-local-map nil - "Non-nil means `overriding-local-map' will be used to hack for overriding key events on auto-copletion." - :type 'boolean - :group 'auto-complete) - -(defface ac-completion-face - '((t (:foreground "darkgray" :underline t))) - "Face for inline completion" - :group 'auto-complete) - -(defface ac-candidate-face - '((t (:background "lightgray" :foreground "black"))) - "Face for candidate." - :group 'auto-complete) - -(defface ac-selection-face - '((t (:background "steelblue" :foreground "white"))) - "Face for selected candidate." - :group 'auto-complete) - -(defvar auto-complete-mode-hook nil - "Hook for `auto-complete-mode'.") - - - -;;;; Internal variables - -(defvar auto-complete-mode nil - "Dummy variable to suppress compiler warnings.") - -(defvar ac-cursor-color nil - "Old cursor color.") - -(defvar ac-inline nil - "Inline completion instance.") - -(defvar ac-menu nil - "Menu instance.") - -(defvar ac-show-menu nil - "Flag to show menu on timer tick.") - -(defvar ac-last-completion nil - "Cons of prefix marker and selected item of last completion.") - -(defvar ac-quick-help nil - "Quick help instance") - -(defvar ac-completing nil - "Non-nil means `auto-complete-mode' is now working on completion.") - -(defvar ac-buffer nil - "Buffer where auto-complete is started.") - -(defvar ac-point nil - "Start point of prefix.") - -(defvar ac-last-point nil - "Last point of updating pattern.") - -(defvar ac-prefix nil - "Prefix string.") -(defvaralias 'ac-target 'ac-prefix) - -(defvar ac-selected-candidate nil - "Last selected candidate.") - -(defvar ac-common-part nil - "Common part string of meaningful candidates. -If there is no common part, this will be nil.") - -(defvar ac-whole-common-part nil - "Common part string of whole candidates. -If there is no common part, this will be nil.") - -(defvar ac-prefix-overlay nil - "Overlay for prefix string.") - -(defvar ac-timer nil - "Completion idle timer.") - -(defvar ac-show-menu-timer nil - "Show menu idle timer.") - -(defvar ac-quick-help-timer nil - "Quick help idle timer.") - -(defvar ac-triggered nil - "Flag to update.") - -(defvar ac-limit nil - "Limit number of candidates for each sources.") - -(defvar ac-candidates nil - "Current candidates.") - -(defvar ac-candidates-cache nil - "Candidates cache for individual sources.") - -(defvar ac-fuzzy-enable nil - "Non-nil means fuzzy matching is enabled.") - -(defvar ac-dwim-enable nil - "Non-nil means DWIM completion will be allowed.") - -(defvar ac-mode-map (make-sparse-keymap) - "Auto-complete mode map. It is also used for trigger key command. See also `ac-trigger-key'.") - -(defvar ac-completing-map - (let ((map (make-sparse-keymap))) - (define-key map "\t" 'ac-expand) - (define-key map "\r" 'ac-complete) - (define-key map (kbd "M-TAB") 'auto-complete) - (define-key map "\C-s" 'ac-isearch) - - (define-key map "\M-n" 'ac-next) - (define-key map "\M-p" 'ac-previous) - (define-key map [down] 'ac-next) - (define-key map [up] 'ac-previous) - - (define-key map [f1] 'ac-help) - (define-key map [M-f1] 'ac-persist-help) - (define-key map (kbd "C-?") 'ac-help) - (define-key map (kbd "C-M-?") 'ac-persist-help) - - (define-key map [C-down] 'ac-quick-help-scroll-down) - (define-key map [C-up] 'ac-quick-help-scroll-up) - (define-key map "\C-\M-n" 'ac-quick-help-scroll-down) - (define-key map "\C-\M-p" 'ac-quick-help-scroll-up) - - (dotimes (i 9) - (let ((symbol (intern (format "ac-complete-%d" (1+ i))))) - (fset symbol - `(lambda () - (interactive) - (when (and (ac-menu-live-p) (popup-select ac-menu ,i)) - (ac-complete)))) - (define-key map (read-kbd-macro (format "M-%s" (1+ i))) symbol))) - - map) - "Keymap for completion.") -(defvaralias 'ac-complete-mode-map 'ac-completing-map) - -(defvar ac-menu-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-n" 'ac-next) - (define-key map "\C-p" 'ac-previous) - (set-keymap-parent map ac-completing-map) - map) - "Keymap for completion on completing menu.") - -(defvar ac-current-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ac-completing-map) - map)) - -(defvar ac-match-function 'all-completions - "Default match function.") - -(defvar ac-prefix-definitions - '((symbol . ac-prefix-symbol) - (file . ac-prefix-file) - (valid-file . ac-prefix-valid-file) - (c-dot . ac-prefix-c-dot) - (c-dot-ref . ac-prefix-c-dot-ref)) - "Prefix definitions for common use.") - -(defvar ac-sources '(ac-source-words-in-same-mode-buffers) - "Sources for completion.") -(make-variable-buffer-local 'ac-sources) - -(defvar ac-compiled-sources nil - "Compiled source of `ac-sources'.") - -(defvar ac-current-sources nil - "Current working sources. This is sublist of `ac-compiled-sources'.") - -(defvar ac-omni-completion-sources nil - "Do not use this anymore.") - -(defvar ac-current-prefix-def nil) - -(defvar ac-ignoring-prefix-def nil) - - - -;;;; Intelligent completion history - -(defvar ac-comphist nil - "Database of completion history.") - -(defsubst ac-comphist-make-tab () - (make-hash-table :test 'equal)) - -(defsubst ac-comphist-tab (db) - (nth 0 db)) - -(defsubst ac-comphist-cache (db) - (nth 1 db)) - -(defun ac-comphist-make (&optional tab) - (list (or tab (ac-comphist-make-tab)) (make-hash-table :test 'equal :weakness t))) - -(defun ac-comphist-get (db string &optional create) - (let* ((tab (ac-comphist-tab db)) - (index (gethash string tab))) - (when (and create (null index)) - (setq index (make-vector (length string) 0)) - (puthash string index tab)) - index)) - -(defun ac-comphist-add (db string prefix) - (setq prefix (min prefix (1- (length string)))) - (when (<= 0 prefix) - (setq string (substring-no-properties string)) - (let ((stat (ac-comphist-get db string t))) - (incf (aref stat prefix)) - (remhash string (ac-comphist-cache db))))) - -(defun ac-comphist-score (db string prefix) - (setq prefix (min prefix (1- (length string)))) - (if (<= 0 prefix) - (let ((cache (gethash string (ac-comphist-cache db)))) - (or (and cache (aref cache prefix)) - (let ((stat (ac-comphist-get db string)) - (score 0.0)) - (when stat - (loop for p from 0 below (length string) - ;; sigmoid function - with a = 5 - with d = (/ 6.0 a) - for x = (- d (abs (- prefix p))) - for r = (/ 1.0 (1+ (exp (* (- a) x)))) - do - (incf score (* (aref stat p) r)))) - ;; Weight by distance - (incf score (max 0.0 (- 0.3 (/ (- (length string) prefix) 100.0)))) - (unless cache - (setq cache (make-vector (length string) nil)) - (puthash string cache (ac-comphist-cache db))) - (aset cache prefix score) - score))) - 0.0)) - -(defun ac-comphist-sort (db collection prefix &optional threshold) - (let (result - (n 0) - (total 0) - (cur 0)) - (setq result (mapcar (lambda (a) - (when (and cur threshold) - (if (>= cur (* total threshold)) - (setq cur nil) - (incf n) - (incf cur (cdr a)))) - (car a)) - (sort (mapcar (lambda (string) - (let ((score (ac-comphist-score db string prefix))) - (incf total score) - (cons string score))) - collection) - (lambda (a b) (< (cdr b) (cdr a)))))) - (if threshold - (cons n result) - result))) - -(defun ac-comphist-serialize (db) - (let (alist) - (maphash (lambda (k v) - (push (cons k v) alist)) - (ac-comphist-tab db)) - (list alist))) - -(defun ac-comphist-deserialize (sexp) - (condition-case nil - (ac-comphist-make (let ((tab (ac-comphist-make-tab))) - (mapc (lambda (cons) - (puthash (car cons) (cdr cons) tab)) - (nth 0 sexp)) - tab)) - (error (message "Invalid comphist db.") nil))) - -(defun ac-comphist-init () - (ac-comphist-load) - (add-hook 'kill-emacs-hook 'ac-comphist-save)) - -(defun ac-comphist-load () - (interactive) - (let ((db (if (file-exists-p ac-comphist-file) - (ignore-errors - (with-temp-buffer - (insert-file-contents ac-comphist-file) - (goto-char (point-min)) - (ac-comphist-deserialize (read (current-buffer)))))))) - (setq ac-comphist (or db (ac-comphist-make))))) - -(defun ac-comphist-save () - (interactive) - (require 'pp) - (ignore-errors - (with-temp-buffer - (pp (ac-comphist-serialize ac-comphist) (current-buffer)) - (write-region (point-min) (point-max) ac-comphist-file)))) - - - -;;;; Auto completion internals - -(defun ac-menu-at-wrapper-line-p () - "Return non-nil if current line is long and wrapped to next visual line." - (and (not truncate-lines) - (eq (line-beginning-position) - (save-excursion - (vertical-motion 1) - (line-beginning-position))))) - -(defun ac-prefix-symbol () - "Default prefix definition function." - (require 'thingatpt) - (car-safe (bounds-of-thing-at-point 'symbol))) -(defalias 'ac-prefix-default 'ac-prefix-symbol) - -(defun ac-prefix-file () - "File prefix." - (let ((point (re-search-backward "[\"<>' \t\r\n]" nil t))) - (if point (1+ point)))) - -(defun ac-prefix-valid-file () - "Existed (or to be existed) file prefix." - (let* ((line-beg (line-beginning-position)) - (end (point)) - (start (or (let ((point (re-search-backward "[\"<>'= \t\r\n]" line-beg t))) - (if point (1+ point))) - line-beg)) - (file (buffer-substring start end))) - (if (and file (or (string-match "^/" file) - (and (setq file (and (string-match "^[^/]*/" file) - (match-string 0 file))) - (file-directory-p file)))) - start))) - -(defun ac-prefix-c-dot () - "C-like languages dot(.) prefix." - (if (re-search-backward "\\.\\(\\(?:[a-zA-Z0-9][_a-zA-Z0-9]*\\)?\\)\\=" nil t) - (match-beginning 1))) - -(defun ac-prefix-c-dot-ref () - "C-like languages dot(.) and reference(->) prefix." - (if (re-search-backward "\\(?:\\.\\|->\\)\\(\\(?:[a-zA-Z0-9][_a-zA-Z0-9]*\\)?\\)\\=" nil t) - (match-beginning 1))) - -(defun ac-define-prefix (name prefix) - "Define new prefix definition. -You can not use it in source definition like (prefix . `NAME')." - (push (cons name prefix) ac-prefix-definitions)) - -(defun ac-match-substring (prefix candidates) - (loop with regexp = (regexp-quote prefix) - for candidate in candidates - if (string-match regexp candidate) - collect candidate)) - -(defsubst ac-source-entity (source) - (if (symbolp source) - (symbol-value source) - source)) - -(defun ac-source-available-p (source) - (if (and (symbolp source) - (get source 'available)) - (eq (get source 'available) t) - (let* ((src (ac-source-entity source)) - (avail-pair (assq 'available src)) - (avail-cond (cdr avail-pair)) - (available (and (if avail-pair - (cond - ((symbolp avail-cond) - (funcall avail-cond)) - ((listp avail-cond) - (eval avail-cond))) - t) - (loop for feature in (assoc-default 'depends src) - unless (require feature nil t) return nil - finally return t)))) - (if (symbolp source) - (put source 'available (if available t 'no))) - available))) - -(defun ac-compile-sources (sources) - "Compiled `SOURCES' into expanded sources style." - (loop for source in sources - if (ac-source-available-p source) - do - (setq source (ac-source-entity source)) - (flet ((add-attribute (name value &optional append) (add-to-list 'source (cons name value) append))) - ;; prefix - (let* ((prefix (assoc 'prefix source)) - (real (assoc-default (cdr prefix) ac-prefix-definitions))) - (cond - (real - (add-attribute 'prefix real)) - ((null prefix) - (add-attribute 'prefix 'ac-prefix-default)))) - ;; match - (let ((match (assq 'match source))) - (cond - ((eq (cdr match) 'substring) - (setcdr match 'ac-match-substring))))) - and collect source)) - -(defun ac-compiled-sources () - (or ac-compiled-sources - (setq ac-compiled-sources - (ac-compile-sources ac-sources)))) - -(defsubst ac-menu-live-p () - (popup-live-p ac-menu)) - -(defun ac-menu-create (point width height) - (setq ac-menu - (popup-create point width height - :around t - :face 'ac-candidate-face - :selection-face 'ac-selection-face - :symbol t - :scroll-bar t - :margin-left 1))) - -(defun ac-menu-delete () - (when ac-menu - (popup-delete ac-menu) - (setq ac-menu))) - -(defsubst ac-inline-marker () - (nth 0 ac-inline)) - -(defsubst ac-inline-overlay () - (nth 1 ac-inline)) - -(defsubst ac-inline-live-p () - (and ac-inline (ac-inline-overlay) t)) - -(defun ac-inline-show (point string) - (unless ac-inline - (setq ac-inline (list (make-marker) nil))) - (save-excursion - (let ((overlay (ac-inline-overlay)) - (width 0) - (string-width (string-width string)) - (length 0) - (original-string string)) - ;; Calculate string space to show completion - (goto-char point) - (let (c) - (while (and (not (eolp)) - (< width string-width) - (setq c (char-after)) - (not (eq c ?\t))) ; special case for tab - (incf width (char-width c)) - (incf length) - (forward-char))) - - ;; Show completion - (goto-char point) - (cond - ((= width 0) - (set-marker (ac-inline-marker) point) - (let ((buffer-undo-list t)) - (insert " ")) - (setq width 1 - length 1)) - ((<= width string-width) - ;; No space to show - ;; Do nothing - ) - ((> width string-width) - ;; Need to fill space - (setq string (concat string (make-string (- width string-width) ? ))))) - (setq string (propertize string 'face 'ac-completion-face)) - (if overlay - (progn - (move-overlay overlay point (+ point length)) - (overlay-put overlay 'invisible nil)) - (setq overlay (make-overlay point (+ point length))) - (setf (nth 1 ac-inline) overlay) - (overlay-put overlay 'priority 9999) - ;; Help prefix-overlay in some cases - (overlay-put overlay 'keymap ac-current-map)) - (overlay-put overlay 'display (substring string 0 1)) - ;; TODO no width but char - (overlay-put overlay 'after-string (substring string 1)) - (overlay-put overlay 'string original-string)))) - -(defun ac-inline-delete () - (when (ac-inline-live-p) - (ac-inline-hide) - (delete-overlay (ac-inline-overlay)) - (setq ac-inline nil))) - -(defun ac-inline-hide () - (when (ac-inline-live-p) - (let ((overlay (ac-inline-overlay)) - (marker (ac-inline-marker)) - (buffer-undo-list t)) - (when overlay - (when (marker-position marker) - (save-excursion - (goto-char marker) - (delete-char 1) - (set-marker marker nil))) - (move-overlay overlay (point-min) (point-min)) - (overlay-put overlay 'invisible t) - (overlay-put overlay 'display nil) - (overlay-put overlay 'after-string nil))))) - -(defun ac-inline-update () - (if (and ac-completing ac-prefix (stringp ac-common-part)) - (let ((common-part-length (length ac-common-part)) - (prefix-length (length ac-prefix))) - (if (> common-part-length prefix-length) - (progn - (ac-inline-hide) - (ac-inline-show (point) (substring ac-common-part prefix-length))) - (ac-inline-delete))) - (ac-inline-delete))) - -(defun ac-put-prefix-overlay () - (unless ac-prefix-overlay - (let (newline) - ;; Insert newline to make sure that cursor always on the overlay - (when (and (eq ac-point (point-max)) - (eq ac-point (point))) - (popup-save-buffer-state - (insert "\n")) - (setq newline t)) - (setq ac-prefix-overlay (make-overlay ac-point (1+ (point)) nil t t)) - (overlay-put ac-prefix-overlay 'priority 9999) - (overlay-put ac-prefix-overlay 'keymap (make-sparse-keymap)) - (overlay-put ac-prefix-overlay 'newline newline)))) - -(defun ac-remove-prefix-overlay () - (when ac-prefix-overlay - (when (overlay-get ac-prefix-overlay 'newline) - ;; Remove inserted newline - (popup-save-buffer-state - (goto-char (point-max)) - (if (eq (char-before) ?\n) - (delete-char -1)))) - (delete-overlay ac-prefix-overlay))) - -(defun ac-activate-completing-map () - (if (and ac-show-menu ac-use-menu-map) - (set-keymap-parent ac-current-map ac-menu-map)) - (when (and ac-use-overriding-local-map - (null overriding-terminal-local-map)) - (setq overriding-terminal-local-map ac-current-map)) - (when ac-prefix-overlay - (set-keymap-parent (overlay-get ac-prefix-overlay 'keymap) ac-current-map))) - -(defun ac-deactivate-completing-map () - (set-keymap-parent ac-current-map ac-completing-map) - (when (and ac-use-overriding-local-map - (eq overriding-terminal-local-map ac-current-map)) - (setq overriding-terminal-local-map nil)) - (when ac-prefix-overlay - (set-keymap-parent (overlay-get ac-prefix-overlay 'keymap) nil))) - -(defsubst ac-selected-candidate () - (if ac-menu - (popup-selected-item ac-menu))) - -(defun ac-prefix (requires ignore-list) - (loop with current = (point) - with point - with prefix-def - with sources - for source in (ac-compiled-sources) - for prefix = (assoc-default 'prefix source) - for req = (or (assoc-default 'requires source) requires 1) - - if (null prefix-def) - do - (unless (member prefix ignore-list) - (save-excursion - (setq point (cond - ((symbolp prefix) - (funcall prefix)) - ((stringp prefix) - (and (re-search-backward (concat prefix "\\=") nil t) - (or (match-beginning 1) (match-beginning 0)))) - ((stringp (car-safe prefix)) - (let ((regexp (nth 0 prefix)) - (end (nth 1 prefix)) - (group (nth 2 prefix))) - (and (re-search-backward (concat regexp "\\=") nil t) - (funcall (if end 'match-end 'match-beginning) - (or group 0))))) - (t - (eval prefix)))) - (if (and point - (integerp req) - (< (- current point) req)) - (setq point nil)) - (if point - (setq prefix-def prefix)))) - - if (equal prefix prefix-def) do (push source sources) - - finally return - (and point (list prefix-def point (nreverse sources))))) - -(defun ac-init () - "Initialize current sources to start completion." - (setq ac-candidates-cache nil) - (loop for source in ac-current-sources - for function = (assoc-default 'init source) - if function do - (save-excursion - (cond - ((functionp function) - (funcall function)) - (t - (eval function)))))) - -(defun ac-candidates-1 (source) - (let* ((do-cache (assq 'cache source)) - (function (assoc-default 'candidates source)) - (action (assoc-default 'action source)) - (document (assoc-default 'document source)) - (symbol (assoc-default 'symbol source)) - (ac-limit (or (assoc-default 'limit source) ac-limit)) - (face (or (assoc-default 'face source) (assoc-default 'candidate-face source))) - (selection-face (assoc-default 'selection-face source)) - (cache (and do-cache (assq source ac-candidates-cache))) - (candidates (cdr cache))) - (unless cache - (setq candidates (save-excursion - (cond - ((functionp function) - (funcall function)) - (t - (eval function))))) - ;; Convert (name value) format candidates into name with text properties. - (setq candidates (mapcar (lambda (candidate) - (if (consp candidate) - (propertize (car candidate) 'value (cdr candidate)) - candidate)) - candidates)) - (when do-cache - (push (cons source candidates) ac-candidates-cache))) - (setq candidates (funcall (or (assoc-default 'match source) - ac-match-function) - ac-prefix candidates)) - ;; Remove extra items regarding to ac-limit - (if (and (integerp ac-limit) (> ac-limit 1) (> (length candidates) ac-limit)) - (setcdr (nthcdr (1- ac-limit) candidates) nil)) - ;; Put candidate properties - (setq candidates (mapcar (lambda (candidate) - (popup-item-propertize candidate - 'action action - 'symbol symbol - 'document document - 'popup-face face - 'selection-face selection-face)) - candidates)) - candidates)) - -(defun ac-candidates () - "Produce candidates for current sources." - (loop with completion-ignore-case = (or (eq ac-ignore-case t) - (and (eq ac-ignore-case 'smart) - (let ((case-fold-search nil)) (not (string-match "[[:upper:]]" ac-prefix))))) - with case-fold-search = completion-ignore-case - with prefix-len = (length ac-prefix) - for source in ac-current-sources - append (ac-candidates-1 source) into candidates - finally return - (progn - (delete-dups candidates) - (if (and ac-use-comphist ac-comphist) - (if ac-show-menu - (let* ((pair (ac-comphist-sort ac-comphist candidates prefix-len ac-comphist-threshold)) - (n (car pair)) - (result (cdr pair)) - (cons (if (> n 0) (nthcdr (1- n) result))) - (cdr (cdr cons))) - (if cons (setcdr cons nil)) - (setq ac-common-part (try-completion ac-prefix result)) - (setq ac-whole-common-part (try-completion ac-prefix candidates)) - (if cons (setcdr cons cdr)) - result) - (setq candidates (ac-comphist-sort ac-comphist candidates prefix-len)) - (setq ac-common-part (if candidates (popup-x-to-string (car candidates)))) - (setq ac-whole-common-part (try-completion ac-prefix candidates)) - candidates) - (setq ac-common-part (try-completion ac-prefix candidates)) - (setq ac-whole-common-part ac-common-part) - candidates)))) - -(defun ac-update-candidates (cursor scroll-top) - "Update candidates of menu to `ac-candidates' and redraw it." - (setf (popup-cursor ac-menu) cursor - (popup-scroll-top ac-menu) scroll-top) - (setq ac-dwim-enable (= (length ac-candidates) 1)) - (if ac-candidates - (progn - (setq ac-completing t) - (ac-activate-completing-map)) - (setq ac-completing nil) - (ac-deactivate-completing-map)) - (ac-inline-update) - (popup-set-list ac-menu ac-candidates) - (if (and (not ac-fuzzy-enable) - (<= (length ac-candidates) 1)) - (popup-hide ac-menu) - (if ac-show-menu - (popup-draw ac-menu)))) - -(defun ac-reposition () - "Force to redraw candidate menu with current `ac-candidates'." - (let ((cursor (popup-cursor ac-menu)) - (scroll-top (popup-scroll-top ac-menu))) - (ac-menu-delete) - (ac-menu-create ac-point (popup-preferred-width ac-candidates) (popup-height ac-menu)) - (ac-update-candidates cursor scroll-top))) - -(defun ac-cleanup () - "Cleanup auto completion." - (if ac-cursor-color - (set-cursor-color ac-cursor-color)) - (when (and ac-use-comphist ac-comphist) - (when (and (null ac-selected-candidate) - (member ac-prefix ac-candidates)) - ;; Assume candidate is selected by just typing - (setq ac-selected-candidate ac-prefix) - (setq ac-last-point ac-point)) - (when ac-selected-candidate - (ac-comphist-add ac-comphist - ac-selected-candidate - (if ac-last-point - (- ac-last-point ac-point) - (length ac-prefix))))) - (ac-deactivate-completing-map) - (ac-remove-prefix-overlay) - (ac-remove-quick-help) - (ac-inline-delete) - (ac-menu-delete) - (ac-cancel-timer) - (ac-cancel-show-menu-timer) - (ac-cancel-quick-help-timer) - (setq ac-cursor-color nil - ac-inline nil - ac-show-menu nil - ac-menu nil - ac-completing nil - ac-point nil - ac-last-point nil - ac-prefix nil - ac-prefix-overlay nil - ac-selected-candidate nil - ac-common-part nil - ac-whole-common-part nil - ac-triggered nil - ac-limit nil - ac-candidates nil - ac-candidates-cache nil - ac-fuzzy-enable nil - ac-dwim-enable nil - ac-compiled-sources nil - ac-current-sources nil - ac-current-prefix-def nil - ac-ignoring-prefix-def nil)) - -(defsubst ac-abort () - "Abort completion." - (ac-cleanup)) - -(defun ac-expand-string (string &optional remove-undo-boundary) - "Expand `STRING' into the buffer and update `ac-prefix' to `STRING'. -This function records deletion and insertion sequences by `undo-boundary'. -If `remove-undo-boundary' is non-nil, this function also removes `undo-boundary' -that have been made before in this function." - (when (not (equal string (buffer-substring ac-point (point)))) - (undo-boundary) - ;; We can't use primitive-undo since it undoes by - ;; groups, divided by boundaries. - ;; We don't want boundary between deletion and insertion. - ;; So do it manually. - ;; Delete region silently for undo: - (if remove-undo-boundary - (progn - (let (buffer-undo-list) - (save-excursion - (delete-region ac-point (point)))) - (setq buffer-undo-list - (nthcdr 2 buffer-undo-list))) - (delete-region ac-point (point))) - (insert string) - ;; Sometimes, possible when omni-completion used, (insert) added - ;; to buffer-undo-list strange record about position changes. - ;; Delete it here: - (when (and remove-undo-boundary - (integerp (cadr buffer-undo-list))) - (setcdr buffer-undo-list (nthcdr 2 buffer-undo-list))) - (undo-boundary) - (setq ac-selected-candidate string) - (setq ac-prefix string))) - -(defun ac-set-trigger-key (key) - "Set `ac-trigger-key' to `KEY'. It is recommemded to use this function instead of calling `setq'." - ;; Remove old mapping - (when ac-trigger-key - (define-key ac-mode-map (read-kbd-macro ac-trigger-key) nil)) - - ;; Make new mapping - (setq ac-trigger-key key) - (when key - (define-key ac-mode-map (read-kbd-macro key) 'ac-trigger-key-command))) - -(defun ac-set-timer () - (unless ac-timer - (setq ac-timer (run-with-idle-timer ac-delay ac-delay 'ac-update-greedy)))) - -(defun ac-cancel-timer () - (when (timerp ac-timer) - (cancel-timer ac-timer) - (setq ac-timer nil))) - -(defun ac-update (&optional force) - (when (and auto-complete-mode - ac-prefix - (or ac-triggered - force) - (not isearch-mode)) - (ac-put-prefix-overlay) - (setq ac-candidates (ac-candidates)) - (let ((preferred-width (popup-preferred-width ac-candidates))) - ;; Reposition if needed - (when (or (null ac-menu) - (>= (popup-width ac-menu) preferred-width) - (<= (popup-width ac-menu) (- preferred-width 10)) - (and (> (popup-direction ac-menu) 0) - (ac-menu-at-wrapper-line-p))) - (ac-inline-hide) ; Hide overlay to calculate correct column - (ac-menu-delete) - (ac-menu-create ac-point preferred-width ac-menu-height))) - (ac-update-candidates 0 0) - t)) - -(defun ac-update-greedy (&optional force) - (let (result) - (while (when (and (setq result (ac-update force)) - (null ac-candidates)) - (add-to-list 'ac-ignoring-prefix-def ac-current-prefix-def) - (ac-start :force-init t) - ac-current-prefix-def)) - result)) - -(defun ac-set-show-menu-timer () - (when (and (or (integerp ac-auto-show-menu) (floatp ac-auto-show-menu)) - (null ac-show-menu-timer)) - (setq ac-show-menu-timer (run-with-idle-timer ac-auto-show-menu ac-auto-show-menu 'ac-show-menu)))) - -(defun ac-cancel-show-menu-timer () - (when (timerp ac-show-menu-timer) - (cancel-timer ac-show-menu-timer) - (setq ac-show-menu-timer nil))) - -(defun ac-show-menu () - (when (not (eq ac-show-menu t)) - (setq ac-show-menu t) - (ac-inline-hide) - (ac-remove-quick-help) - (ac-update t))) - -(defun ac-help (&optional persist) - (interactive "P") - (when ac-menu - (popup-menu-show-help ac-menu persist))) - -(defun ac-persist-help () - (interactive) - (ac-help t)) - -(defun ac-last-help (&optional persist) - (interactive "P") - (when ac-last-completion - (popup-item-show-help (cdr ac-last-completion) persist))) - -(defun ac-last-persist-help () - (interactive) - (ac-last-help t)) - -(defun ac-set-quick-help-timer () - (when (and ac-use-quick-help - (null ac-quick-help-timer)) - (setq ac-quick-help-timer (run-with-idle-timer ac-quick-help-delay ac-quick-help-delay 'ac-quick-help)))) - -(defun ac-cancel-quick-help-timer () - (when (timerp ac-quick-help-timer) - (cancel-timer ac-quick-help-timer) - (setq ac-quick-help-timer nil))) - -(defun ac-pos-tip-show-quick-help (menu &optional item &rest args) - (let* ((point (plist-get args :point)) - (around nil) - (parent-offset (popup-offset menu)) - (doc (popup-menu-documentation menu item))) - (when (stringp doc) - (if (popup-hidden-p menu) - (setq around t) - (setq point nil)) - (with-no-warnings - (pos-tip-show doc - 'popup-tip-face - (or point - (and menu - (popup-child-point menu parent-offset)) - (point)) - nil 0 - popup-tip-max-width - nil nil - (and (not around) 0)) - (unless (plist-get args :nowait) - (clear-this-command-keys) - (unwind-protect - (push (read-event (plist-get args :prompt)) unread-command-events) - (pos-tip-hide)) - t))))) - -(defun ac-quick-help (&optional force) - (interactive) - (when (and (or force (null this-command)) - (ac-menu-live-p) - (null ac-quick-help)) - (setq ac-quick-help - (funcall (if (and ac-quick-help-prefer-x - (eq window-system 'x) - (featurep 'pos-tip)) - 'ac-pos-tip-show-quick-help - 'popup-menu-show-quick-help) - ac-menu nil - :point ac-point - :height ac-quick-help-height - :nowait t)))) - -(defun ac-remove-quick-help () - (when ac-quick-help - (popup-delete ac-quick-help) - (setq ac-quick-help nil))) - -(defun ac-last-quick-help () - (interactive) - (when (and ac-last-completion - (eq (marker-buffer (car ac-last-completion)) - (current-buffer))) - (let ((doc (popup-item-documentation (cdr ac-last-completion))) - (point (marker-position (car ac-last-completion)))) - (when (stringp doc) - (if (and ac-quick-help-prefer-x - (eq window-system 'x) - (featurep 'pos-tip)) - (with-no-warnings (pos-tip-show doc nil point nil 0)) - (popup-tip doc - :point point - :around t - :scroll-bar t - :margin t)))))) - -(defmacro ac-define-quick-help-command (name arglist &rest body) - (declare (indent 2)) - `(progn - (defun ,name ,arglist ,@body) - (put ',name 'ac-quick-help-command t))) - -(ac-define-quick-help-command ac-quick-help-scroll-down () - (interactive) - (when ac-quick-help - (popup-scroll-down ac-quick-help))) - -(ac-define-quick-help-command ac-quick-help-scroll-up () - (interactive) - (when ac-quick-help - (popup-scroll-up ac-quick-help))) - - - -;;;; Auto completion isearch - -(defun ac-isearch-callback (list) - (setq ac-dwim-enable (eq (length list) 1))) - -(defun ac-isearch () - (interactive) - (when (ac-menu-live-p) - (ac-cancel-show-menu-timer) - (ac-cancel-quick-help-timer) - (ac-show-menu) - (popup-isearch ac-menu :callback 'ac-isearch-callback))) - - - -;;;; Auto completion commands - -(defun auto-complete (&optional sources) - "Start auto-completion at current point." - (interactive) - (let ((menu-live (ac-menu-live-p)) - (inline-live (ac-inline-live-p))) - (ac-abort) - (let ((ac-sources (or sources ac-sources))) - (if (or ac-show-menu-immediately-on-auto-complete - inline-live) - (setq ac-show-menu t)) - (ac-start)) - (when (ac-update-greedy t) - ;; TODO Not to cause inline completion to be disrupted. - (if (ac-inline-live-p) - (ac-inline-hide)) - ;; Not to expand when it is first time to complete - (when (and (or (and (not ac-expand-on-auto-complete) - (> (length ac-candidates) 1) - (not menu-live)) - (not (let ((ac-common-part ac-whole-common-part)) - (ac-expand-common)))) - ac-use-fuzzy - (null ac-candidates)) - (ac-fuzzy-complete))))) - -(defun ac-fuzzy-complete () - "Start fuzzy completion at current point." - (interactive) - (when (require 'fuzzy nil) - (unless (ac-menu-live-p) - (ac-start)) - (let ((ac-match-function 'fuzzy-all-completions)) - (unless ac-cursor-color - (setq ac-cursor-color (frame-parameter (selected-frame) 'cursor-color))) - (if ac-fuzzy-cursor-color - (set-cursor-color ac-fuzzy-cursor-color)) - (setq ac-show-menu t) - (setq ac-fuzzy-enable t) - (setq ac-triggered nil) - (ac-update t))) - t) - -(defun ac-next () - "Select next candidate." - (interactive) - (when (ac-menu-live-p) - (popup-next ac-menu) - (setq ac-show-menu t) - (if (eq this-command 'ac-next) - (setq ac-dwim-enable t)))) - -(defun ac-previous () - "Select previous candidate." - (interactive) - (when (ac-menu-live-p) - (popup-previous ac-menu) - (setq ac-show-menu t) - (if (eq this-command 'ac-previous) - (setq ac-dwim-enable t)))) - -(defun ac-expand () - "Try expand, and if expanded twice, select next candidate." - (interactive) - (unless (ac-expand-common) - (let ((string (ac-selected-candidate))) - (when string - (when (equal ac-prefix string) - (ac-next) - (setq string (ac-selected-candidate))) - (ac-expand-string string (eq last-command this-command)) - ;; Do reposition if menu at long line - (if (and (> (popup-direction ac-menu) 0) - (ac-menu-at-wrapper-line-p)) - (ac-reposition)) - (setq ac-show-menu t) - string)))) - -(defun ac-expand-common () - "Try to expand meaningful common part." - (interactive) - (if (and ac-dwim ac-dwim-enable) - (ac-complete) - (when (and (ac-inline-live-p) - ac-common-part) - (ac-inline-hide) - (ac-expand-string ac-common-part (eq last-command this-command)) - (setq ac-common-part nil) - t))) - -(defun ac-complete () - "Try complete." - (interactive) - (let* ((candidate (ac-selected-candidate)) - (action (popup-item-property candidate 'action)) - (fallback nil)) - (when candidate - (unless (ac-expand-string candidate) - (setq fallback t)) - ;; Remember to show help later - (when (and ac-point candidate) - (unless ac-last-completion - (setq ac-last-completion (cons (make-marker) nil))) - (set-marker (car ac-last-completion) ac-point ac-buffer) - (setcdr ac-last-completion candidate))) - (ac-abort) - (cond - (action - (funcall action)) - (fallback - (ac-fallback-command))) - candidate)) - -(defun* ac-start (&key - requires - force-init) - "Start completion." - (interactive) - (if (not auto-complete-mode) - (message "auto-complete-mode is not enabled") - (let* ((info (ac-prefix requires ac-ignoring-prefix-def)) - (prefix-def (nth 0 info)) - (point (nth 1 info)) - (sources (nth 2 info)) - prefix - (init (or force-init (not (eq ac-point point))))) - (if (or (null point) - (member (setq prefix (buffer-substring-no-properties point (point))) - ac-ignores)) - (prog1 nil - (ac-abort)) - (unless ac-cursor-color - (setq ac-cursor-color (frame-parameter (selected-frame) 'cursor-color))) - (setq ac-show-menu (or ac-show-menu (if (eq ac-auto-show-menu t) t)) - ac-current-sources sources - ac-buffer (current-buffer) - ac-point point - ac-prefix prefix - ac-limit ac-candidate-limit - ac-triggered t - ac-current-prefix-def prefix-def) - (when (or init (null ac-prefix-overlay)) - (ac-init)) - (ac-set-timer) - (ac-set-show-menu-timer) - (ac-set-quick-help-timer) - (ac-put-prefix-overlay))))) - -(defun ac-stop () - "Stop completiong." - (interactive) - (setq ac-selected-candidate nil) - (ac-abort)) - -(defun ac-trigger-key-command (&optional force) - (interactive "P") - (if (or force (ac-trigger-command-p last-command)) - (auto-complete) - (ac-fallback-command 'ac-trigger-key-command))) - - - -;;;; Basic cache facility - -(defvar ac-clear-variables-every-minute-timer nil) -(defvar ac-clear-variables-after-save nil) -(defvar ac-clear-variables-every-minute nil) -(defvar ac-minutes-counter 0) - -(defun ac-clear-variable-after-save (variable &optional pred) - (add-to-list 'ac-clear-variables-after-save (cons variable pred))) - -(defun ac-clear-variables-after-save () - (dolist (pair ac-clear-variables-after-save) - (if (or (null (cdr pair)) - (funcall (cdr pair))) - (set (car pair) nil)))) - -(defun ac-clear-variable-every-minutes (variable minutes) - (add-to-list 'ac-clear-variables-every-minute (cons variable minutes))) - -(defun ac-clear-variable-every-minute (variable) - (ac-clear-variable-every-minutes variable 1)) - -(defun ac-clear-variable-every-10-minutes (variable) - (ac-clear-variable-every-minutes variable 10)) - -(defun ac-clear-variables-every-minute () - (incf ac-minutes-counter) - (dolist (pair ac-clear-variables-every-minute) - (if (eq (% ac-minutes-counter (cdr pair)) 0) - (set (car pair) nil)))) - - - -;;;; Auto complete mode - -(defun ac-cursor-on-diable-face-p (&optional point) - (memq (get-text-property (or point (point)) 'face) ac-disable-faces)) - -(defun ac-trigger-command-p (command) - "Return non-nil if `COMMAND' is a trigger command." - (and (symbolp command) - (or (memq command ac-trigger-commands) - (string-match "self-insert-command" (symbol-name command)) - (string-match "electric" (symbol-name command))))) - -(defun ac-fallback-command (&optional except-command) - (let* ((auto-complete-mode nil) - (keys (this-command-keys-vector)) - (command (if keys (key-binding keys)))) - (when (and (commandp command) - (not (eq command except-command))) - (setq this-command command) - (call-interactively command)))) - -(defun ac-compatible-package-command-p (command) - "Return non-nil if `COMMAND' is compatible with auto-complete." - (and (symbolp command) - (string-match ac-compatible-packages-regexp (symbol-name command)))) - -(defun ac-handle-pre-command () - (condition-case var - (if (or (setq ac-triggered (and (not ac-fuzzy-enable) ; ignore key storkes in fuzzy mode - (or (eq this-command 'auto-complete) ; special case - (ac-trigger-command-p this-command) - (and ac-completing - (memq this-command ac-trigger-commands-on-completing))) - (not (ac-cursor-on-diable-face-p)))) - (ac-compatible-package-command-p this-command)) - (progn - (if (or (not (symbolp this-command)) - (not (get this-command 'ac-quick-help-command))) - (ac-remove-quick-help)) - ;; Not to cause inline completion to be disrupted. - (ac-inline-hide)) - (ac-abort)) - (error (ac-error var)))) - -(defun ac-handle-post-command () - (condition-case var - (when (and ac-triggered - (or ac-auto-start - ac-completing) - (not isearch-mode)) - (setq ac-last-point (point)) - (ac-start :requires (unless ac-completing ac-auto-start)) - (ac-inline-update)) - (error (ac-error var)))) - -(defun ac-setup () - (if ac-trigger-key - (ac-set-trigger-key ac-trigger-key)) - (if ac-use-comphist - (ac-comphist-init)) - (unless ac-clear-variables-every-minute-timer - (setq ac-clear-variables-every-minute-timer (run-with-timer 60 60 'ac-clear-variables-every-minute))) - (if ac-stop-flymake-on-completing - (defadvice flymake-on-timer-event (around ac-flymake-stop-advice activate) - (unless ac-completing - ad-do-it)) - (ad-disable-advice 'flymake-on-timer-event 'around 'ac-flymake-stop-advice))) - -(define-minor-mode auto-complete-mode - "AutoComplete mode" - :lighter " AC" - :keymap ac-mode-map - :group 'auto-complete - (if auto-complete-mode - (progn - (ac-setup) - (add-hook 'pre-command-hook 'ac-handle-pre-command nil t) - (add-hook 'post-command-hook 'ac-handle-post-command nil t) - (add-hook 'after-save-hook 'ac-clear-variables-after-save nil t) - (run-hooks 'auto-complete-mode-hook)) - (remove-hook 'pre-command-hook 'ac-handle-pre-command t) - (remove-hook 'post-command-hook 'ac-handle-post-command t) - (remove-hook 'after-save-hook 'ac-clear-variables-after-save t) - (ac-abort))) - -(defun auto-complete-mode-maybe () - "What buffer `auto-complete-mode' prefers." - (if (and (not (minibufferp (current-buffer))) - (memq major-mode ac-modes)) - (auto-complete-mode 1))) - -(define-global-minor-mode global-auto-complete-mode - auto-complete-mode auto-complete-mode-maybe - :group 'auto-complete) - - - -;;;; Compatibilities with other extensions - -(defun ac-flyspell-workaround () - "Flyspell uses `sit-for' for delaying its process. Unfortunatelly, -it stops auto completion which is trigger with `run-with-idle-timer'. -This workaround avoid flyspell processes when auto completion is being started." - (interactive) - (defadvice flyspell-post-command-hook (around ac-flyspell-workaround activate) - (unless ac-triggered - ad-do-it))) - - - -;;;; Standard sources - -(defmacro ac-define-source (name source) - "Source definition macro. It defines a complete command also." - (declare (indent 1)) - `(progn - (defvar ,(intern (format "ac-source-%s" name)) - ,source) - (defun ,(intern (format "ac-complete-%s" name)) () - (interactive) - (auto-complete '(,(intern (format "ac-source-%s" name))))))) - -;; Words in buffer source -(defvar ac-word-index nil) - -(defun ac-candidate-words-in-buffer (point prefix limit) - (let ((i 0) - candidate - candidates - (regexp (concat "\\_<" (regexp-quote prefix) "\\(\\sw\\|\\s_\\)+\\_>"))) - (save-excursion - ;; Search backward - (goto-char point) - (while (and (or (not (integerp limit)) (< i limit)) - (re-search-backward regexp nil t)) - (setq candidate (match-string-no-properties 0)) - (unless (member candidate candidates) - (push candidate candidates) - (incf i))) - ;; Search backward - (goto-char (+ point (length prefix))) - (while (and (or (not (integerp limit)) (< i limit)) - (re-search-forward regexp nil t)) - (setq candidate (match-string-no-properties 0)) - (unless (member candidate candidates) - (push candidate candidates) - (incf i))) - (nreverse candidates)))) - -(defun ac-incremental-update-word-index () - (unless (local-variable-p 'ac-word-index) - (make-local-variable 'ac-word-index)) - (if (null ac-word-index) - (setq ac-word-index (cons nil nil))) - ;; Mark incomplete - (if (car ac-word-index) - (setcar ac-word-index nil)) - (let ((index (cdr ac-word-index)) - (words (ac-candidate-words-in-buffer ac-point ac-prefix (or (and (integerp ac-limit) ac-limit) 10)))) - (dolist (word words) - (unless (member word index) - (push word index) - (setcdr ac-word-index index))))) - -(defun ac-update-word-index-1 () - (unless (local-variable-p 'ac-word-index) - (make-local-variable 'ac-word-index)) - (when (and (not (car ac-word-index)) - (< (buffer-size) 1048576)) - ;; Complete index - (setq ac-word-index - (cons t - (split-string (buffer-substring-no-properties (point-min) (point-max)) - "\\(?:^\\|\\_>\\).*?\\(?:\\_<\\|$\\)"))))) - -(defun ac-update-word-index () - (dolist (buffer (buffer-list)) - (when (or ac-fuzzy-enable - (not (eq buffer (current-buffer)))) - (with-current-buffer buffer - (ac-update-word-index-1))))) - -(defun ac-word-candidates (&optional buffer-pred) - (loop initially (unless ac-fuzzy-enable (ac-incremental-update-word-index)) - for buffer in (buffer-list) - if (and (or (not (integerp ac-limit)) (< (length candidates) ac-limit)) - (if buffer-pred (funcall buffer-pred buffer) t)) - append (funcall ac-match-function - ac-prefix - (and (local-variable-p 'ac-word-index buffer) - (cdr (buffer-local-value 'ac-word-index buffer)))) - into candidates - finally return candidates)) - -(ac-define-source words-in-buffer - '((candidates . ac-word-candidates))) - -(ac-define-source words-in-all-buffer - '((init . ac-update-word-index) - (candidates . ac-word-candidates))) - -(ac-define-source words-in-same-mode-buffers - '((init . ac-update-word-index) - (candidates . (ac-word-candidates - (lambda (buffer) - (derived-mode-p (buffer-local-value 'major-mode buffer))))))) - -;; Lisp symbols source -(defvar ac-symbols-cache nil) -(ac-clear-variable-every-10-minutes 'ac-symbols-cache) - -(defun ac-symbol-file (symbol type) - (if (fboundp 'find-lisp-object-file-name) - (find-lisp-object-file-name symbol type) - (let ((file-name (with-no-warnings - (describe-simplify-lib-file-name - (symbol-file symbol type))))) - (when (equal file-name "loaddefs.el") - ;; Find the real def site of the preloaded object. - (let ((location (condition-case nil - (if (eq type 'defun) - (find-function-search-for-symbol symbol nil - "loaddefs.el") - (find-variable-noselect symbol file-name)) - (error nil)))) - (when location - (with-current-buffer (car location) - (when (cdr location) - (goto-char (cdr location))) - (when (re-search-backward - "^;;; Generated autoloads from \\(.*\\)" nil t) - (setq file-name (match-string 1))))))) - (if (and (null file-name) - (or (eq type 'defun) - (integerp (get symbol 'variable-documentation)))) - ;; It's a object not defined in Elisp but in C. - (if (get-buffer " *DOC*") - (if (eq type 'defun) - (help-C-file-name (symbol-function symbol) 'subr) - (help-C-file-name symbol 'var)) - 'C-source) - file-name)))) - -(defun ac-symbol-documentation (symbol) - (if (stringp symbol) - (setq symbol (intern-soft symbol))) - (ignore-errors - (with-temp-buffer - (let ((standard-output (current-buffer))) - (prin1 symbol) - (princ " is ") - (cond - ((fboundp symbol) - (let ((help-xref-following t)) - (describe-function-1 symbol)) - (buffer-string)) - ((boundp symbol) - (let ((file-name (ac-symbol-file symbol 'defvar))) - (princ "a variable") - (when file-name - (princ " defined in `") - (princ (if (eq file-name 'C-source) - "C source code" - (file-name-nondirectory file-name)))) - (princ "'.\n\n") - (princ (or (documentation-property symbol 'variable-documentation t) - "Not documented.")) - (buffer-string))) - ((facep symbol) - (let ((file-name (ac-symbol-file symbol 'defface))) - (princ "a face") - (when file-name - (princ " defined in `") - (princ (if (eq file-name 'C-source) - "C source code" - (file-name-nondirectory file-name)))) - (princ "'.\n\n") - (princ (or (documentation-property symbol 'face-documentation t) - "Not documented.")) - (buffer-string))) - (t - (let ((doc (documentation-property symbol 'group-documentation t))) - (when doc - (princ "a group.\n\n") - (princ doc) - (buffer-string))))))))) - -(defun ac-symbol-candidates () - (or ac-symbols-cache - (setq ac-symbols-cache - (loop for x being the symbols - if (or (fboundp x) - (boundp x) - (symbol-plist x)) - collect (symbol-name x))))) - -(ac-define-source symbols - '((candidates . ac-symbol-candidates) - (document . ac-symbol-documentation) - (symbol . "s") - (cache))) - -;; Lisp functions source -(defvar ac-functions-cache nil) -(ac-clear-variable-every-10-minutes 'ac-functions-cache) - -(defun ac-function-candidates () - (or ac-functions-cache - (setq ac-functions-cache - (loop for x being the symbols - if (fboundp x) - collect (symbol-name x))))) - -(ac-define-source functions - '((candidates . ac-function-candidates) - (document . ac-symbol-documentation) - (symbol . "f") - (prefix . "(\\(\\(?:\\sw\\|\\s_\\)+\\)") - (cache))) - -;; Lisp variables source -(defvar ac-variables-cache nil) -(ac-clear-variable-every-10-minutes 'ac-variables-cache) - -(defun ac-variable-candidates () - (or ac-variables-cache - (setq ac-variables-cache - (loop for x being the symbols - if (boundp x) - collect (symbol-name x))))) - -(ac-define-source variables - '((candidates . ac-variable-candidates) - (document . ac-symbol-documentation) - (symbol . "v") - (cache))) - -;; Lisp features source -(defvar ac-emacs-lisp-features nil) -(ac-clear-variable-every-10-minutes 'ac-emacs-lisp-features) - -(defun ac-emacs-lisp-feature-candidates () - (or ac-emacs-lisp-features - (if (fboundp 'find-library-suffixes) - (let ((suffix (concat (regexp-opt (find-library-suffixes) t) "\\'"))) - (setq ac-emacs-lisp-features - (append (mapcar 'prin1-to-string features) - (loop for dir in load-path - if (file-directory-p dir) - append (loop for file in (directory-files dir) - if (string-match suffix file) - collect (substring file 0 (match-beginning 0)))))))))) - -(ac-define-source features - '((depends find-func) - (candidates . ac-emacs-lisp-feature-candidates) - (prefix . "require +'\\(\\(?:\\sw\\|\\s_\\)*\\)") - (requires . 0))) - -(defvaralias 'ac-source-emacs-lisp-features 'ac-source-features) - -;; Abbrev source -(ac-define-source abbrev - '((candidates . (mapcar 'popup-x-to-string (append (vconcat local-abbrev-table global-abbrev-table) nil))) - (action . expand-abbrev) - (symbol . "a") - (cache))) - -;; Files in current directory source -(ac-define-source files-in-current-dir - '((candidates . (directory-files default-directory)) - (cache))) - -;; Filename source -(defvar ac-filename-cache nil) - -(defun ac-filename-candidate () - (unless (file-regular-p ac-prefix) - (ignore-errors - (loop with dir = (file-name-directory ac-prefix) - with files = (or (assoc-default dir ac-filename-cache) - (let ((files (directory-files dir nil "^[^.]"))) - (push (cons dir files) ac-filename-cache) - files)) - for file in files - for path = (concat dir file) - collect (if (file-directory-p path) - (concat path "/") - path))))) - -(ac-define-source filename - '((init . (setq ac-filename-cache nil)) - (candidates . ac-filename-candidate) - (prefix . valid-file) - (requires . 0) - (action . ac-start) - (limit . nil))) - -;; Dictionary source -(defcustom ac-user-dictionary nil - "User dictionary" - :type '(repeat string) - :group 'auto-complete) - -(defcustom ac-user-dictionary-files '("~/.dict") - "User dictionary files." - :type '(repeat string) - :group 'auto-complete) - -(defcustom ac-dictionary-directories nil - "Dictionary directories." - :type '(repeat string) - :group 'auto-complete) - -(defvar ac-dictionary nil) -(defvar ac-dictionary-cache (make-hash-table :test 'equal)) - -(defun ac-clear-dictionary-cache () - (interactive) - (clrhash ac-dictionary-cache)) - -(defun ac-read-file-dictionary (filename) - (let ((cache (gethash filename ac-dictionary-cache 'none))) - (if (and cache (not (eq cache 'none))) - cache - (let (result) - (ignore-errors - (with-temp-buffer - (insert-file-contents filename) - (setq result (split-string (buffer-string) "\n")))) - (puthash filename result ac-dictionary-cache) - result)))) - -(defun ac-buffer-dictionary () - (apply 'append - (mapcar 'ac-read-file-dictionary - (mapcar (lambda (name) - (loop for dir in ac-dictionary-directories - for file = (concat dir "/" name) - if (file-exists-p file) - return file)) - (list (symbol-name major-mode) - (ignore-errors - (file-name-extension (buffer-file-name)))))))) - -(defun ac-dictionary-candidates () - (apply 'append `(,ac-user-dictionary - ,(ac-buffer-dictionary) - ,@(mapcar 'ac-read-file-dictionary - ac-user-dictionary-files)))) - -(ac-define-source dictionary - '((candidates . ac-dictionary-candidates) - (symbol . "d"))) - -(provide 'auto-complete) -;;; auto-complete.el ends here diff --git a/emacs.d/elisp/color-theme-gruber-darker.el b/emacs.d/elisp/color-theme-gruber-darker.el deleted file mode 100644 index 5ee82a2..0000000 --- a/emacs.d/elisp/color-theme-gruber-darker.el +++ /dev/null @@ -1,101 +0,0 @@ -;; color-theme-gruber-dark.el -;; Revision 1 -;; -;; Copyright (C) 2009-2010 Jason R. Blevins -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, -;; copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the -;; Software is furnished to do so, subject to the following -;; conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES -;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT -;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, -;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR -;; OTHER DEALINGS IN THE SOFTWARE. - -(require 'color-theme) - -(defun color-theme-gruber-darker () - "Gruber Darker color theme for Emacs by Jason Blevins. -A darker variant of the Gruber Dark theme for BBEdit -by John Gruber." - (interactive) - (color-theme-install - '(color-theme-gruber-darker - ((foreground-color . "#e4e4ef") - (background-color . "#181818") - (background-mode . dark) - (cursor-color . "#ffdd33") - (mouse-color . "#ffdd33")) - - ;; Standard font lock faces - (default ((t (nil)))) - (font-lock-comment-face ((t (:foreground "#cc8c3c")))) - (font-lock-comment-delimiter-face ((t (:foreground "#cc8c3c")))) - (font-lock-doc-face ((t (:foreground "#73c936")))) - (font-lock-doc-string-face ((t (:foreground "#73c936")))) - (font-lock-string-face ((t (:foreground "#73c936")))) - (font-lock-keyword-face ((t (:foreground "#ffdd33")))) - (font-lock-builtin-face ((t (:foreground "#ffdd33")))) - (font-lock-function-name-face ((t (:foreground "#96a6c8")))) - (font-lock-variable-name-face ((t (:foreground "#f4f4ff")))) - (font-lock-preprocessor-face ((t (:foreground "#95a99f")))) - (font-lock-constant-face ((t (:foreground "#95a99f")))) - (font-lock-type-face ((t (:foreground "#95a99f")))) - (font-lock-warning-face ((t (:foreground "#f43841")))) - (font-lock-reference-face ((t (:foreground "#95a99f")))) - (trailing-whitespace ((t (:foreground "#000" :background "#f43841")))) - (link ((t (:foreground "#96A6C8" :underline t)))) - - ;; Search - (isearch ((t (:foreground "#000" :background "#f5f5f5")))) - (isearch-lazy-highlight-face ((t (:foreground "#f4f4ff" :background "#5f627f")))) - (isearch-fail ((t (:foreground "#000" :background "#f43841")))) - - ;; User interface - (fringe ((t (:background "#111" :foreground "#444")))) - (border ((t (:background "#111" :foreground "#444")))) - (mode-line ((t (:background "#453d41" :foreground "#fff")))) - (mode-line-buffer-id ((t (:background "#453d41" :foreground "#fff")))) - (mode-line-inactive ((t (:background "#453d41" :foreground "#999")))) - (minibuffer-prompt ((t (:foreground "#96A6C8")))) - (region ((t (:background "#484848")))) - (secondary-selection ((t (:background "#484951" :foreground "#F4F4FF")))) - (tooltip ((t (:background "#52494e" :foreground "#fff")))) - - ;; Parenthesis matching - (show-paren-match-face ((t (:background "#52494e" :foreground "#f4f4ff")))) - (show-paren-mismatch-face ((t (:foreground "#f4f4ff" :background "#c73c3f")))) - ;; Line highlighting - (highlight ((t (:background "#282828" :foreground nil)))) - (highlight-current-line-face ((t (:background "#282828" :foreground nil)))) - - ;; Calendar - (holiday-face ((t (:foreground "#f43841")))) - - ;; Info - (info-xref ((t (:foreground "#96a6c8")))) - (info-visited ((t (:foreground "#9e95c7")))) - - ;; AUCTeX - (font-latex-sectioning-5-face ((t (:foreground "#96a6c8" :bold t)))) - (font-latex-bold-face ((t (:foreground "#95a99f" :bold t)))) - (font-latex-italic-face ((t (:foreground "#95a99f" :italic t)))) - (font-latex-math-face ((t (:foreground "#73c936")))) - (font-latex-string-face ((t (:foreground "#73c936")))) - (font-latex-warning-face ((t (:foreground "#f43841")))) - (font-latex-slide-title-face ((t (:foreground "#96a6c8")))) - ))) - -(provide 'color-theme-gruber-darker) diff --git a/emacs.d/elisp/color-theme-vibrant-ink.el b/emacs.d/elisp/color-theme-vibrant-ink.el deleted file mode 100644 index dee8c6a..0000000 --- a/emacs.d/elisp/color-theme-vibrant-ink.el +++ /dev/null @@ -1,18 +0,0 @@ -(require 'color-theme) - -;; vibrant-ink color theme -(defun color-theme-vibrant-ink () - (interactive) - (color-theme-install - '(color-theme-ryrobes - ((background-color . "#000000") - (background-mode . dark) - (border-color . "#000000") - (cursor-color . "#FFFFFF") - (foreground-color . "#FFFFFF") - (mouse-color . "#FFFFFF")) - (font-lock-comment-face ((t (:foreground "#9933CC" :italic t)))) - (font-lock-keyword-face ((t (:foreground "#FF6600")))) - (font-lock-type-face ((t (:foreground "#FFCC00")))) - (font-lock-string-face ((t (:foreground "#66FF00"))))))) -(provide 'color-theme-vibrant-ink) diff --git a/emacs.d/elisp/color-theme-weirdness.el b/emacs.d/elisp/color-theme-weirdness.el deleted file mode 100644 index c75996c..0000000 --- a/emacs.d/elisp/color-theme-weirdness.el +++ /dev/null @@ -1,74 +0,0 @@ -(require 'color-theme) - -;; weirdness color-theme -(defun color-theme-weirdness () - (interactive) - (color-theme-install - '(color-theme-weirdness - ((background-color . "#000000") - (background-mode . dark) - (border-color . "#000000") - (cursor-color . "#FFFFFF") - (foreground-color . "#FFFFFF") - (mouse-color . "#000000")) - (org-level-1 ((t (:foreground "#5BFD5B" :weight normal)))) - (org-level-2 ((t (:foreground "#379A37" :weight normal)))) - (org-level-3 ((t (:foreground "#757575" :weight normal)))) - (org-level-4 ((t (:foreground "#778899" :weight normal)))) - (org-level-5 ((t (:foreground "#9898FF" :weight normal)))) - (org-level-6 ((t (:foreground "#0000B0" :weight normal)))) - (org-level-7 ((t (:foreground "#740091" :weight normal)))) - (org-level-8 ((t (:foreground "#B275C1" :weight normal)))) - (fringe ((t (:background "#000000")))) - (mode-line ((t (:foreground "#B3B3B3" :background "#43527A" :background "#000000" :box nil)))) - (region ((t (:background "#3D3D3D")))) - (minibuffer-prompt ((t (:foreground "#72F3FF" :bold t)))) - (flymake-warnline ((t (:background "#000060")))) - (flymake-errline ((t (:background "#600000")))) - (font-lock-builtin-face ((t (:foreground "#C436C4")))) - (font-lock-comment-face ((t (:foreground "#00AC00" :background "#004000" :bold t :box (:line-width 1 :color "#006000" :style nil))))) - (font-lock-comment-delimiter-face ((t (:inherit 'font-lock-comment-face)))) - (font-lock-function-name-face ((t (:foreground "#0FFF28")))) - (font-lock-keyword-face ((t (:foreground "#4E61BB" :bold t)))) - (font-lock-string-face ((t (:foreground "#E00900")))) - (font-lock-type-face ((t (:foreground "#8522DD")))) - (font-lock-variable-name-face ((t (:foreground "#18EFF2")))) - (font-lock-warning-face ((t (:foreground "#FF0000" :bold t))))))) - -;; weirdnes color-theme 2 -;; thinking of improving it. -(defun color-theme-weirdness2 () - (interactive) - (color-theme-install - '(color-theme-weirdness - ((background-color . "#000000") - (background-mode . dark) - (border-color . "#000000") - (cursor-color . "#FFFFFF") - (foreground-color . "#FFFFFF") - (mouse-color . "#000000")) - (org-level-1 ((t (:foreground "#5BFD5B" :weight normal)))) - (org-level-2 ((t (:foreground "#379A37" :weight normal)))) - (org-level-3 ((t (:foreground "#757575" :weight normal)))) - (org-level-4 ((t (:foreground "#778899" :weight normal)))) - (org-level-5 ((t (:foreground "#9898FF" :weight normal)))) - (org-level-6 ((t (:foreground "#0000B0" :weight normal)))) - (org-level-7 ((t (:foreground "#740091" :weight normal)))) - (org-level-8 ((t (:foreground "#B275C1" :weight normal)))) - (fringe ((t (:background "#000000")))) - (mode-line ((t (:foreground "#B3B3B3" :background "#43527A" :background "#000000" :box nil)))) - (region ((t (:background "#3D3D3D")))) - (minibuffer-prompt ((t (:foreground "#72F3FF" :bold t)))) - (flymake-warnline ((t (:background "#000060")))) - (flymake-errline ((t (:background "#600000")))) - (font-lock-builtin-face ((t (:foreground "#C436C4")))) - (font-lock-comment-face ((t (:foreground "#00AC00" :background "#004000" :bold t :box (:line-width 1 :color "#006000" :style nil))))) - (font-lock-comment-delimiter-face ((t (:inherit 'font-lock-comment-face)))) - (font-lock-function-name-face ((t (:foreground "#8522DD")))) - (font-lock-keyword-face ((t (:foreground "royal blue")))) - (font-lock-string-face ((t (:foreground "#E00900")))) - (font-lock-type-face ((t (:foreground "#FF9800")))) - (font-lock-variable-name-face ((t (:foreground "#18EFF2")))) - (font-lock-warning-face ((t (:foreground "#FF0000" :bold t))))))) - -(provide 'color-theme-weirdness) diff --git a/emacs.d/elisp/color-theme.el b/emacs.d/elisp/color-theme.el deleted file mode 100644 index c92c1a5..0000000 --- a/emacs.d/elisp/color-theme.el +++ /dev/null @@ -1,1668 +0,0 @@ -;;; color-theme.el --- install color themes - -;; Copyright (C) 1999, 2000 Jonadab the Unsightly One <jonadab@bright.net> -;; Copyright (C) 2000, 2001, 2002, 2003 Alex Schroeder <alex@gnu.org> -;; Copyright (C) 2003, 2004, 2005, 2006 Xavier Maillard <zedek@gnu.org> - -;; Version: 6.6.0 -;; Keywords: faces -;; Author: Jonadab the Unsightly One <jonadab@bright.net> -;; Maintainer: Xavier Maillard <zedek@gnu.org> -;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ColorTheme - -;; This file is not (YET) part of GNU Emacs. - -;; This 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 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: - -;; Please read README and BUGS files for any relevant help. -;; Contributors (not themers) should also read HACKING file. - -;;; Thanks - -;; Deepak Goel <deego@glue.umd.edu> -;; S. Pokrovsky <pok@nbsp.nsk.su> for ideas and discussion. -;; Gordon Messmer <gordon@dragonsdawn.net> for ideas and discussion. -;; Sriram Karra <karra@cs.utah.edu> for the color-theme-submit stuff. -;; Olgierd `Kingsajz' Ziolko <kingsajz@rpg.pl> for the spec-filter idea. -;; Brian Palmer for color-theme-library ideas and code -;; All the users that contributed their color themes. - - - -;;; Code: -(eval-when-compile - (require 'easymenu) - (require 'reporter) - (require 'sendmail)) - -(require 'cl); set-difference is a function... - -;; for custom-face-attributes-get or face-custom-attributes-get -(require 'cus-face) -(require 'wid-edit); for widget-apply stuff in cus-face.el - -(defconst color-theme-maintainer-address "zedek@gnu.org" - "Address used by `submit-color-theme'.") - -;; Emacs / XEmacs compatibility and workaround layer - -(cond ((and (facep 'tool-bar) - (not (facep 'toolbar))) - (put 'toolbar 'face-alias 'tool-bar)) - ((and (facep 'toolbar) - (not (facep 'tool-bar))) - (put 'tool-bar 'face-alias 'toolbar))) - -(defvar color-theme-xemacs-p (and (featurep 'xemacs) - (string-match "XEmacs" emacs-version)) - "Non-nil if running XEmacs.") - -;; Add this since it appears to miss in emacs-2x -(or (fboundp 'replace-in-string) - (defun replace-in-string (target old new) - (replace-regexp-in-string old new target))) - -;; face-attr-construct has a problem in Emacs 20.7 and older when -;; dealing with inverse-video faces. Here is a short test to check -;; wether you are affected. - -;; (set-background-color "wheat") -;; (set-foreground-color "black") -;; (setq a (make-face 'a-face)) -;; (face-spec-set a '((t (:background "white" :foreground "black" :inverse-video t)))) -;; (face-attr-construct a) -;; => (:background "black" :inverse-video t) - -;; The expected response is the original specification: -;; => (:background "white" :foreground "black" :inverse-video t) - -;; That's why we depend on cus-face.el functionality. - -(cond ((fboundp 'custom-face-attributes-get) - (defun color-theme-face-attr-construct (face frame) - (if (atom face) - (custom-face-attributes-get face frame) - (if (and (consp face) (eq (car face) 'quote)) - (custom-face-attributes-get (cadr face) frame) - (custom-face-attributes-get (car face) frame))))) - ((fboundp 'face-custom-attributes-get) - (defalias 'color-theme-face-attr-construct - 'face-custom-attributes-get)) - (t - (defun color-theme-face-attr-construct (&rest ignore) - (error "Unable to construct face attributes")))) - -(defun color-theme-alist (plist) - "Transform PLIST into an alist if it is a plist and return it. -If the first element of PLIST is a cons cell, we just return PLIST, -assuming PLIST to be an alist. If the first element of plist is not a -symbol, this is an error: We cannot distinguish a plist from an ordinary -list, but a list that doesn't start with a symbol is certainly no plist -and no alist. - -This is used to make sure `default-frame-alist' really is an alist and not -a plist. In XEmacs, the alist is deprecated; a plist is used instead." - (cond ((consp (car plist)) - plist) - ((not (symbolp (car plist))) - (error "Wrong type argument: plist, %S" plist)) - ((featurep 'xemacs) - (plist-to-alist plist)))); XEmacs only - -;; Customization - -(defgroup color-theme nil - "Color Themes for Emacs. -A color theme consists of frame parameter settings, variable settings, -and face definitions." - :version "20.6" - :group 'faces) - -(defcustom color-theme-legal-frame-parameters "\\(color\\|mode\\)$" - "Regexp that matches frame parameter names. -Only frame parameter names that match this regexp can be changed as part -of a color theme." - :type '(choice (const :tag "Colors only" "\\(color\\|mode\\)$") - (const :tag "Colors, fonts, and size" - "\\(color\\|mode\\|font\\|height\\|width\\)$") - (regexp :tag "Custom regexp")) - :group 'color-theme - :link '(info-link "(elisp)Window Frame Parameters")) - -(defcustom color-theme-legal-variables "\\(color\\|face\\)$" - "Regexp that matches variable names. -Only variables that match this regexp can be changed as part of a color -theme. In addition to matching this name, the variables have to be user -variables (see function `user-variable-p')." - :type 'regexp - :group 'color-theme) - -(defcustom color-theme-illegal-faces "^w3-" - "Regexp that matches face names forbidden in themes. -The default setting \"^w3-\" excludes w3 faces since these -are created dynamically." - :type 'regexp - :group 'color-theme - :link '(info-link "(elisp)Faces for Font Lock") - :link '(info-link "(elisp)Standard Faces")) - -(defcustom color-theme-illegal-default-attributes '(:family :height :width) - "A list of face properties to be ignored when installing faces. -This prevents Emacs from doing terrible things to your display just because -a theme author likes weird fonts." - :type '(repeat symbol) - :group 'color-theme) - -(defcustom color-theme-is-global t - "*Determines wether a color theme is installed on all frames or not. -If non-nil, color themes will be installed for all frames. -If nil, color themes will be installed for the selected frame only. - -A possible use for this variable is dynamic binding. Here is a larger -example to put in your ~/.emacs; it will make the Blue Sea color theme -the default used for the first frame, and it will create two additional -frames with different color themes. - -setup: - \(require 'color-theme) - ;; set default color theme - \(color-theme-blue-sea) - ;; create some frames with different color themes - \(let ((color-theme-is-global nil)) - \(select-frame (make-frame)) - \(color-theme-gnome2) - \(select-frame (make-frame)) - \(color-theme-standard)) - -Please note that using XEmacs and and a nil value for -color-theme-is-global will ignore any variable settings for the color -theme, since XEmacs doesn't have frame-local variable bindings. - -Also note that using Emacs and a non-nil value for color-theme-is-global -will install a new color theme for all frames. Using XEmacs and a -non-nil value for color-theme-is-global will install a new color theme -only on those frames that are not using a local color theme." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-is-cumulative t - "*Determines wether new color themes are installed on top of each other. -If non-nil, installing a color theme will undo all settings made by -previous color themes." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-directory nil - "Directory where we can find additionnal themes (personnal). -Note that there is at least one directory shipped with the official -color-theme distribution where all contributed themes are located. -This official selection can't be changed with that variable. -However, you still can decide to turn it on or off and thus, -not be shown with all themes but yours." - :type '(repeat string) - :group 'color-theme) - -(defcustom color-theme-libraries (directory-files - (concat - (file-name-directory (locate-library "color-theme")) - "/themes") t "^color-theme") - "A list of files, which will be loaded in color-theme-initialize depending -on `color-theme-load-all-themes' value. -This allows a user to prune the default color-themes (which can take a while -to load)." - :type '(repeat string) - :group 'color-theme) - -(defcustom color-theme-load-all-themes t - "When t, load all color-theme theme files -as presented by `color-theme-libraries'. Else -do not load any of this themes." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-mode-hook nil - "Hook for color-theme-mode." - :type 'hook - :group 'color-theme) - -(defvar color-theme-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'color-theme-install-at-point) - (define-key map (kbd "c") 'list-colors-display) - (define-key map (kbd "d") 'color-theme-describe) - (define-key map (kbd "f") 'list-faces-display) - (define-key map (kbd "i") 'color-theme-install-at-point) - (define-key map (kbd "l") 'color-theme-install-at-point-for-current-frame) - (define-key map (kbd "p") 'color-theme-print) - (define-key map (kbd "q") 'bury-buffer) - (define-key map (kbd "?") 'color-theme-describe) - (if color-theme-xemacs-p - (define-key map (kbd "<button2>") 'color-theme-install-at-mouse) - (define-key map (kbd "<mouse-2>") 'color-theme-install-at-mouse)) - map) - "Mode map used for the buffer created by `color-theme-select'.") - -(defvar color-theme-initialized nil - "Internal variable determining whether color-theme-initialize has been invoked yet") - -(defvar color-theme-buffer-name "*Color Theme Selection*" - "Name of the color theme selection buffer.") - -(defvar color-theme-original-frame-alist nil - "nil until one of the color themes has been installed.") - -(defvar color-theme-history nil - "List of color-themes called, in reverse order") - -(defcustom color-theme-history-max-length nil - "Max length of history to maintain. -Two other values are acceptable: t means no limit, and -nil means that no history is maintained." - :type '(choice (const :tag "No history" nil) - (const :tag "Unlimited length" t) - integer) - :group 'color-theme) - -(defvar color-theme-counter 0 - "Counter for every addition to `color-theme-history'. -This counts how many themes were installed, regardless -of `color-theme-history-max-length'.") - -(defvar color-theme-entry-path (cond - ;; Emacs 22.x and later - ((lookup-key global-map [menu-bar tools]) - '("tools")) - ;; XEmacs - ((featurep 'xemacs) - (setq tool-entry '("Tools"))) - ;; Emacs < 22 - (t - '("Tools"))) - "Menu tool entry path.") - -(defun color-theme-add-to-history (name) - "Add color-theme NAME to `color-theme-history'." - (setq color-theme-history - (cons (list name color-theme-is-cumulative) - color-theme-history) - color-theme-counter (+ 1 color-theme-counter)) - ;; Truncate the list if necessary. - (when (and (integerp color-theme-history-max-length) - (>= (length color-theme-history) - color-theme-history-max-length)) - (setcdr (nthcdr (1- color-theme-history-max-length) - color-theme-history) - nil))) - -;; (let ((l '(1 2 3 4 5))) -;; (setcdr (nthcdr 2 l) nil) -;; l) - - - -;; List of color themes used to create the *Color Theme Selection* -;; buffer. - -(defvar color-themes - '((color-theme-aalto-dark "Aalto Dark" "Jari Aalto <jari.aalto@poboxes.com>") - (color-theme-aalto-light "Aalto Light" "Jari Aalto <jari.aalto@poboxes.com>") - (color-theme-aliceblue "Alice Blue" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-andreas "Andreas" "Andreas Busch <Andreas.Busch@politics.ox.ac.uk>") - (color-theme-arjen "Arjen" "Arjen Wiersma <arjen@wiersma.org>") - (color-theme-beige-diff "Beige Diff" "Alex Schroeder <alex@gnu.org>" t) - (color-theme-bharadwaj "Bharadwaj" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-bharadwaj-slate "Bharadwaj Slate" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-billw "Billw" "Bill White <billw@wolfram.com>") - (color-theme-black-on-gray "BlackOnGray" "Sudhir Bhojwani <sbhojwani@altoweb.com>") - (color-theme-blippblopp "Blipp Blopp" "Thomas Sicheritz-Ponten<thomas@biopython.org>") - (color-theme-simple-1 "Black" "Jonadab <jonadab@bright.net>") - (color-theme-blue-erc "Blue ERC" "Alex Schroeder <alex@gnu.org>" t) - (color-theme-blue-gnus "Blue Gnus" "Alex Schroeder <alex@gnu.org>" t) - (color-theme-blue-mood "Blue Mood" "Nelson Loyola <nloyola@yahoo.com>") - (color-theme-blue-sea "Blue Sea" "Alex Schroeder <alex@gnu.org>") - (color-theme-calm-forest "Calm Forest" "Artur Hefczyc <kobit@plusnet.pl>") - (color-theme-charcoal-black "Charcoal Black" "Lars Chr. Hausmann <jazz@zqz.dk>") - (color-theme-goldenrod "Cheap Goldenrod" "Alex Schroeder <alex@gnu.org>") - (color-theme-clarity "Clarity and Beauty" "Richard Wellum <rwellum@cisco.com>") - (color-theme-classic "Classic" "Frederic Giroud <postcard@worldonline.fr>") - (color-theme-comidia "Comidia" "Marcelo Dias de Toledo <mtole@ig.com.br>") - (color-theme-jsc-dark "Cooper Dark" "John S Cooper <John.Cooper@eu.citrix.com>") - (color-theme-jsc-light "Cooper Light" "John S Cooper <John.Cooper@eu.citrix.com>") - (color-theme-jsc-light2 "Cooper Light 2" "John S Cooper <John.Cooper@eu.citrix.com>") - (color-theme-dark-blue "Dark Blue" "Chris McMahan <cmcmahan@one.net>") - (color-theme-dark-blue2 "Dark Blue 2" "Chris McMahan <cmcmahan@one.net>") - (color-theme-dark-green "Dark Green" "eddy_woody@hotmail.com") - (color-theme-dark-laptop "Dark Laptop" "Laurent Michel <ldm@cs.brown.edu>") - (color-theme-deep-blue "Deep Blue" "Tomas Cerha <cerha@brailcom.org>") - (color-theme-digital-ofs1 "Digital OFS1" "Gareth Owen <gowen@gwowen.freeserve.co.uk>") - (color-theme-euphoria "Euphoria" "oGLOWo@oGLOWo.cjb.net") - (color-theme-feng-shui "Feng Shui" "Walter Higgins <walterh@rocketmail.com>") - (color-theme-fischmeister "Fischmeister" - "Sebastian Fischmeister <sfischme@nexus.lzk.tuwien.ac.at>") - (color-theme-gnome "Gnome" "Jonadab <jonadab@bright.net>") - (color-theme-gnome2 "Gnome 2" "Alex Schroeder <alex@gnu.org>") - (color-theme-gray1 "Gray1" "Paul Pulli <P.Pulli@motorola.com>") - (color-theme-gray30 "Gray30" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-kingsajz "Green Kingsajz" "Olgierd `Kingsajz' Ziolko <kingsajz@rpg.pl>") - (color-theme-greiner "Greiner" "Kevin Greiner <kgreiner@mapquest.com>") - (color-theme-gtk-ide "GTK IDE" "Gordon Messmer <gordon@dragonsdawn.net>") - (color-theme-high-contrast "High Contrast" "Alex Schroeder <alex@gnu.org>") - (color-theme-hober "Hober" "Edward O'Connor <ted@oconnor.cx>") - (color-theme-infodoc "Infodoc" "Frederic Giroud <postcard@worldonline.fr>") - (color-theme-jb-simple "JB Simple" "jeff@dvns.com") - (color-theme-jedit-grey "Jedit Grey" "Gordon Messmer <gordon@dragonsdawn.net>") - (color-theme-jonadabian "Jonadab" "Jonadab <jonadab@bright.net>") - (color-theme-jonadabian-slate "Jonadabian Slate" "Jonadab <jonadab@bright.net>") - (color-theme-katester "Katester" "Higgins_Walter@emc.com") - (color-theme-late-night "Late Night" "Alex Schroeder <alex@gnu.org>") - (color-theme-lawrence "Lawrence" "lawrence mitchell <wence@gmx.li>") - (color-theme-lethe "Lethe" "Ivica Loncar <ivica.loncar@srk.fer.hr>") - (color-theme-ld-dark "Linh Dang Dark" "Linh Dang <linhd@nortelnetworks.com>") - (color-theme-marine "Marine" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-matrix "Matrix" "Walter Higgins <walterh@rocketmail.com>") - (color-theme-marquardt "Marquardt" "Colin Marquardt <colin@marquardt-home.de>") - (color-theme-midnight "Midnight" "Gordon Messmer <gordon@dragonsdawn.net>") - (color-theme-mistyday "Misty Day" "Hari Kumar <Hari.Kumar@mtm.kuleuven.ac.be>") - (color-theme-montz "Montz" "Brady Montz <bradym@becomm.com>") - (color-theme-oswald "Oswald" "Tom Oswald <toswald@sharplabs.com>") - (color-theme-parus "Parus" "Jon K Hellan <hellan@acm.org>") - (color-theme-pierson "Pierson" "Dan L. Pierson <dan@sol.control.com>") - (color-theme-ramangalahy "Ramangalahy" "Solofo Ramangalahy <solofo@irisa.fr>") - (color-theme-raspopovic "Raspopovic" "Pedja Raspopovic <pedja@lsil.com>") - (color-theme-renegade "Renegade" "Dave Benjamin <ramen@ramenfest.com>") - (color-theme-resolve "Resolve" "Damien Elmes <resolve@repose.cx>") - (color-theme-retro-green "Retro Green" "Alex Schroeder <alex@gnu.org>") - (color-theme-retro-orange "Retro Orange" "Alex Schroeder <alex@gnu.org>") - (color-theme-robin-hood "Robin Hood" "Alex Schroeder <alex@gnu.org>") - (color-theme-rotor "Rotor" "Jinwei Shen <shenjw@wam.umd.edu>") - (color-theme-ryerson "Ryerson" "Luis Fernandes <elf@ee.ryerson.ca>") - (color-theme-salmon-diff "Salmon Diff" "Alex Schroeder <alex@gnu.org>" t) - (color-theme-salmon-font-lock "Salmon Font-Lock" "Alex Schroeder <alex@gnu.org>" t) - (color-theme-scintilla "Scintilla" "Gordon Messmer <gordon@dragonsdawn.net>") - (color-theme-shaman "Shaman" "shaman@interdon.net") - (color-theme-sitaramv-nt "Sitaram NT" - "Sitaram Venkatraman <sitaramv@loc251.tandem.com>") - (color-theme-sitaramv-solaris "Sitaram Solaris" - "Sitaram Venkatraman <sitaramv@loc251.tandem.com>") - (color-theme-snow "Snow" "Nicolas Rist <Nicolas.Rist@alcatel.de>") - (color-theme-snowish "Snowish" "Girish Bharadwaj <girishb@gbvsoft.com>") - (color-theme-standard-ediff "Standard Ediff" "Emacs Team, added by Alex Schroeder <alex@gnu.org>" t) - (color-theme-standard "Standard Emacs 20" "Emacs Team, added by Alex Schroeder <alex@gnu.org>") - (color-theme-emacs-21 "Standard Emacs 21" "Emacs Team, added by Alex Schroeder <alex@gnu.org>") - (color-theme-emacs-nw "Standard Emacs 21 No Window" "Emacs Team, added by D. Goel <deego@gnufans.org>") - (color-theme-xemacs "Standard XEmacs" "XEmacs Team, added by Alex Schroeder <alex@gnu.org>") - (color-theme-subtle-blue "Subtle Blue" "Chris McMahan <cmcmahan@one.net>") - (color-theme-subtle-hacker "Subtle Hacker" "Colin Walters <levanti@verbum.org>") - (color-theme-taming-mr-arneson "Taming Mr Arneson" "Erik Arneson <erik@aarg.net>") - (color-theme-taylor "Taylor" "Art Taylor <reeses@hemisphere.org>") - (color-theme-tty-dark "TTY Dark" "O Polite <m2@plusseven.com>") - (color-theme-vim-colors "Vim Colors" "Michael Soulier <msoulier@biryani.nssg.mitel.com>") - (color-theme-whateveryouwant "Whateveryouwant" "Fabien Penso <penso@linuxfr.org>, color by Scott Jaderholm <scott@jaderholm.com>") - (color-theme-wheat "Wheat" "Alex Schroeder <alex@gnu.org>") - (color-theme-pok-wob "White On Black" "S. Pokrovsky <pok@nbsp.nsk.su>") - (color-theme-pok-wog "White On Grey" "S. Pokrovsky <pok@nbsp.nsk.su>") - (color-theme-word-perfect "WordPerfect" "Thomas Gehrlein <Thomas.Gehrlein@t-online.de>") - (color-theme-xp "XP" "Girish Bharadwaj <girishb@gbvsoft.com>")) - "List of color themes. - -Each THEME is itself a three element list (FUNC NAME MAINTAINER &optional LIBRARY). - -FUNC is a color theme function which does the setup. The function -FUNC may call `color-theme-install'. The color theme function may be -interactive. - -NAME is the name of the theme and MAINTAINER is the name and/or email of -the maintainer of the theme. - -If LIBRARY is non-nil, the color theme will be considered a library and -may not be shown in the default menu. - -If you defined your own color theme and want to add it to this list, -use something like this: - - (add-to-list 'color-themes '(color-theme-gnome2 \"Gnome2\" \"Alex\"))") - -;;; Functions - -(defun color-theme-backup-original-values () - "Back up the original `default-frame-alist'. -The values are stored in `color-theme-original-frame-alist' on -startup." - (if (null color-theme-original-frame-alist) - (setq color-theme-original-frame-alist - (color-theme-filter (frame-parameters (selected-frame)) - color-theme-legal-frame-parameters)))) -(add-hook 'after-init-hook 'color-theme-backup-original-values) - -;;;###autoload -(defun color-theme-select (&optional arg) - "Displays a special buffer for selecting and installing a color theme. -With optional prefix ARG, this buffer will include color theme libraries -as well. A color theme library is in itself not complete, it must be -used as part of another color theme to be useful. Thus, color theme -libraries are mainly useful for color theme authors." - (interactive "P") - (unless color-theme-initialized (color-theme-initialize)) - (switch-to-buffer (get-buffer-create color-theme-buffer-name)) - (setq buffer-read-only nil) - (erase-buffer) - ;; recreate the snapshot if necessary - (when (or (not (assq 'color-theme-snapshot color-themes)) - (not (commandp 'color-theme-snapshot))) - (fset 'color-theme-snapshot (color-theme-make-snapshot)) - (setq color-themes (delq (assq 'color-theme-snapshot color-themes) - color-themes) - color-themes (delq (assq 'bury-buffer color-themes) - color-themes) - color-themes (append '((color-theme-snapshot - "[Reset]" "Undo changes, if possible.") - (bury-buffer - "[Quit]" "Bury this buffer.")) - color-themes))) - (dolist (theme color-themes) - (let ((func (nth 0 theme)) - (name (nth 1 theme)) - (author (nth 2 theme)) - (library (nth 3 theme)) - (desc)) - (when (or (not library) arg) - (setq desc (format "%-23s %s" - (if library (concat name " [lib]") name) - author)) - (put-text-property 0 (length desc) 'color-theme func desc) - (put-text-property 0 (length name) 'face 'bold desc) - (put-text-property 0 (length name) 'mouse-face 'highlight desc) - (insert desc) - (newline)))) - (goto-char (point-min)) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (color-theme-mode)) - -(when (require 'easymenu) - (easy-menu-add-item nil color-theme-entry-path "--") - (easy-menu-add-item nil color-theme-entry-path - ["Color Themes" color-theme-select t])) - -(defun color-theme-mode () - "Major mode to select and install color themes. - -Use \\[color-theme-install-at-point] to install a color theme on all frames. -Use \\[color-theme-install-at-point-for-current-frame] to install a color theme for the current frame only. - -The changes are applied on top of your current setup. This is a -feature. - -Some of the themes should be considered extensions to the standard color -theme: they modify only a limited number of faces and variables. To -verify the final look of a color theme, install the standard color -theme, then install the other color theme. This is a feature. It allows -you to mix several color themes. - -Use \\[color-theme-describe] to read more about the color theme function at point. -If you want to install the color theme permanently, put the call to the -color theme function into your ~/.emacs: - - \(require 'color-theme) - \(color-theme-gnome2) - -If you worry about the size of color-theme.el: You are right. Use -\\[color-theme-print] to print the current color theme and save the resulting buffer -as ~/.emacs-color-theme. Now you can install only this specific color -theme in your .emacs: - - \(load-file \"~/.emacs-color-theme\") - \(my-color-theme) - -The Emacs menu is not affected by color themes within Emacs. Depending -on the toolkit you used to compile Emacs, you might have to set specific -X ressources. See the info manual for more information. Here is an -example ~/.Xdefaults fragment: - - emacs*Background: DarkSlateGray - emacs*Foreground: wheat - -\\{color-theme-mode-map} - -The color themes are listed in `color-themes', which see." - (kill-all-local-variables) - (setq major-mode 'color-theme-mode) - (setq mode-name "Color Themes") - (use-local-map color-theme-mode-map) - (when (functionp 'goto-address); Emacs - (goto-address)) - (run-hooks 'color-theme-mode-hook)) - -;;; Commands in Color Theme Selection mode - -;;;###autoload -(defun color-theme-describe () - "Describe color theme listed at point. -This shows the documentation of the value of text-property color-theme -at point. The text-property color-theme should be a color theme -function. See `color-themes'." - (interactive) - (describe-function (get-text-property (point) 'color-theme))) - -;;;###autoload -(defun color-theme-install-at-mouse (event) - "Install color theme clicked upon using the mouse. -First argument EVENT is used to set point. Then -`color-theme-install-at-point' is called." - (interactive "e") - (save-excursion - (mouse-set-point event) - (color-theme-install-at-point))) - -;;;autoload -(defun color-theme-install-at-point () - "Install color theme at point. -This calls the value of the text-property `color-theme' at point. -The text-property `color-theme' should be a color theme function. -See `color-themes'." - (interactive) - (let ((func (get-text-property (point) 'color-theme))) - ;; install theme - (if func - (funcall func)) - ;; If goto-address is being used, remove all overlays in the current - ;; buffer and run it again. The face used for the mail addresses in - ;; the the color theme selection buffer is based on the variable - ;; goto-address-mail-face. Changes in that variable will not affect - ;; existing overlays, however, thereby confusing users. - (when (functionp 'goto-address); Emacs - (dolist (o (overlays-in (point-min) (point-max))) - (delete-overlay o)) - (goto-address)))) - -;;;###autoload -(defun color-theme-install-at-point-for-current-frame () - "Install color theme at point for current frame only. -Binds `color-theme-is-global' to nil and calls -`color-theme-install-at-point'." - (interactive) - (let ((color-theme-is-global nil)) - (color-theme-install-at-point))) - - - -;; Taking a snapshot of the current color theme and pretty printing it. - -(defun color-theme-filter (old-list regexp &optional exclude) - "Filter OLD-LIST. -The resulting list will be newly allocated and contains only elements -with names matching REGEXP. OLD-LIST may be a list or an alist. If you -want to filter a plist, use `color-theme-alist' to convert your plist to -an alist, first. - -If the optional argument EXCLUDE is non-nil, then the sense is -reversed: only non-matching elements will be retained." - (let (elem new-list) - (dolist (elem old-list) - (setq name (symbol-name (if (listp elem) (car elem) elem))) - (when (or (and (not exclude) - (string-match regexp name)) - (and exclude - (not (string-match regexp name)))) - ;; Now make sure that if elem is a cons cell, and the cdr of - ;; that cons cell is a string, then we need a *new* string in - ;; the new list. Having a new cons cell is of no use because - ;; modify-frame-parameters will modify this string, thus - ;; modifying our color theme functions! - (when (and (consp elem) - (stringp (cdr elem))) - (setq elem (cons (car elem) - (copy-sequence (cdr elem))))) - ;; Now store elem - (setq new-list (cons elem new-list)))) - new-list)) - -(defun color-theme-spec-filter (spec) - "Filter the attributes in SPEC. -This makes sure that SPEC has the form ((t (PLIST ...))). -Only properties not in `color-theme-illegal-default-attributes' -are included in the SPEC returned." - (let ((props (cadar spec)) - result prop val) - (while props - (setq prop (nth 0 props) - val (nth 1 props) - props (nthcdr 2 props)) - (unless (memq prop color-theme-illegal-default-attributes) - (setq result (cons val (cons prop result))))) - `((t ,(nreverse result))))) - -;; (color-theme-spec-filter '((t (:background "blue3")))) -;; (color-theme-spec-filter '((t (:stipple nil :background "Black" :foreground "SteelBlue" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :width semi-condensed :family "misc-fixed")))) - -(defun color-theme-plist-delete (plist prop) - "Delete property PROP from property list PLIST by side effect. -This modifies PLIST." - ;; deal with prop at the start - (while (eq (car plist) prop) - (setq plist (cddr plist))) - ;; deal with empty plist - (when plist - (let ((lastcell (cdr plist)) - (l (cddr plist))) - (while l - (if (eq (car l) prop) - (progn - (setq l (cddr l)) - (setcdr lastcell l)) - (setq lastcell (cdr l) - l (cddr l)))))) - plist) - -;; (color-theme-plist-delete '(a b c d e f g h) 'a) -;; (color-theme-plist-delete '(a b c d e f g h) 'b) -;; (color-theme-plist-delete '(a b c d e f g h) 'c) -;; (color-theme-plist-delete '(a b c d e f g h) 'g) -;; (color-theme-plist-delete '(a b c d c d e f g h) 'c) -;; (color-theme-plist-delete '(a b c d e f c d g h) 'c) - -(if (or (featurep 'xemacs) - (< emacs-major-version 21)) - (defalias 'color-theme-spec-compat 'identity) - (defun color-theme-spec-compat (spec) - "Filter the attributes in SPEC such that is is never invalid. -Example: Eventhough :bold works in Emacs, it is not recognized by -`customize-face' -- and then the face is uncustomizable. This -function replaces a :bold attribute with the corresponding :weight -attribute, if there is no :weight, or deletes it. This undoes the -doings of `color-theme-spec-canonical-font', more or less." - (let ((props (cadar spec))) - (when (plist-member props :bold) - (setq props (color-theme-plist-delete props :bold)) - (unless (plist-member props :weight) - (setq props (plist-put props :weight 'bold)))) - (when (plist-member props :italic) - (setq props (color-theme-plist-delete props :italic)) - (unless (plist-member props :slant) - (setq props (plist-put props :slant 'italic)))) - `((t ,props))))) - -;; (color-theme-spec-compat '((t (:foreground "blue" :bold t)))) -;; (color-theme-spec-compat '((t (:bold t :foreground "blue" :weight extra-bold)))) -;; (color-theme-spec-compat '((t (:italic t :foreground "blue")))) -;; (color-theme-spec-compat '((t (:slant oblique :italic t :foreground "blue")))) - -(defun color-theme-spec-canonical-font (atts) - "Add :bold and :italic attributes if necessary." - ;; add these to the front of atts -- this will keept the old value for - ;; customize-face in Emacs 21. - (when (and (memq (plist-get atts :weight) - '(ultra-bold extra-bold bold semi-bold)) - (not (plist-get atts :bold))) - (setq atts (cons :bold (cons t atts)))) - (when (and (not (memq (plist-get atts :slant) - '(normal nil))) - (not (plist-get atts :italic))) - (setq atts (cons :italic (cons t atts)))) - atts) -;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'bold (selected-frame))) -;; (defface foo '((t (:weight extra-bold))) "foo") -;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'foo (selected-frame))) -;; (face-spec-set 'foo '((t (:weight extra-bold))) nil) -;; (face-spec-set 'foo '((t (:bold t))) nil) -;; (face-spec-set 'foo '((t (:bold t :weight extra-bold))) nil) - -;; Handle :height according to NEWS file for Emacs 21 -(defun color-theme-spec-resolve-height (old new) - "Return the new height given OLD and NEW height. -OLD is the current setting, NEW is the setting inherited from." - (cond ((not old) - new) - ((integerp old) - old) - ((and (floatp old) - (integerp new)) - (round (* old new))) - ((and (floatp old) - (floatp new)) - (* old new)) - ((and (functionp old) - (integerp new)) - (round (funcall old new))) - ((and (functionp old) - (float new)) - `(lambda (f) (* (funcall ,old f) ,new))) - ((and (functionp old) - (functionp new)) - `(lambda (f) (* (funcall ,old (funcall ,new f))))) - (t - (error "Illegal :height attributes: %S or %S" old new)))) -;; (color-theme-spec-resolve-height 12 1.2) -;; (color-theme-spec-resolve-height 1.2 1.2) -;; (color-theme-spec-resolve-height 1.2 12) -;; (color-theme-spec-resolve-height 1.2 'foo) -;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 5) -;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 2.0) -;; the following lambda is the result from the above calculation -;; (color-theme-spec-resolve-height (lambda (f) (* (funcall (lambda (f) (* 2 f)) f) 2.0)) 5) - -(defun color-theme-spec-resolve-inheritance (atts) - "Resolve all occurences of the :inherit attribute." - (let ((face (plist-get atts :inherit))) - ;; From the Emacs 21 NEWS file: "Attributes from inherited faces are - ;; merged into the face like an underlying face would be." -- - ;; therefore properties of the inherited face only add missing - ;; attributes. - (when face - ;; remove :inherit face from atts -- this assumes only one - ;; :inherit attribute. - (setq atts (delq ':inherit (delq face atts))) - (let ((more-atts (color-theme-spec-resolve-inheritance - (color-theme-face-attr-construct - face (selected-frame)))) - att val) - (while more-atts - (setq att (car more-atts) - val (cadr more-atts) - more-atts (cddr more-atts)) - ;; Color-theme assumes that no value is ever 'unspecified. - (cond ((eq att ':height); cumulative effect! - (setq atts (plist-put atts - ':height - (color-theme-spec-resolve-height - (plist-get atts att) - val)))) - ;; Default: Only put if it has not been specified before. - ((not (plist-get atts att)) - (setq atts (cons att (cons val atts)))) - -)))) - atts)) -;; (color-theme-spec-resolve-inheritance '(:bold t)) -;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "blue")) -;; (color-theme-face-attr-construct 'font-lock-comment-face (selected-frame)) -;; (color-theme-spec-resolve-inheritance '(:bold t :inherit font-lock-comment-face)) -;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "red" :inherit font-lock-comment-face)) -;; (color-theme-face-attr-construct 'Info-title-2-face (selected-frame)) -;; (color-theme-face-attr-construct 'Info-title-3-face (selected-frame)) -;; (color-theme-face-attr-construct 'Info-title-4-face (selected-frame)) -;; (color-theme-spec-resolve-inheritance '(:inherit Info-title-2-face)) - -;; The :inverse-video attribute causes Emacs to swap foreground and -;; background colors, XEmacs does not. Therefore, if anybody chooses -;; the inverse-video attribute, we 1. swap the colors ourselves in Emacs -;; and 2. we remove the inverse-video attribute in Emacs and XEmacs. -;; Inverse-video is only useful on a monochrome tty. -(defun color-theme-spec-maybe-invert (atts) - "Remove the :inverse-video attribute from ATTS. -If ATTS contains :inverse-video t, remove it and swap foreground and -background color. Return ATTS." - (let ((inv (plist-get atts ':inverse-video))) - (if inv - (let (result att) - (while atts - (setq att (car atts) - atts (cdr atts)) - (cond ((and (eq att :foreground) (not color-theme-xemacs-p)) - (setq result (cons :background result))) - ((and (eq att :background) (not color-theme-xemacs-p)) - (setq result (cons :foreground result))) - ((eq att :inverse-video) - (setq atts (cdr atts))); this prevents using dolist - (t - (setq result (cons att result))))) - (nreverse result)) - ;; else - atts))) -;; (color-theme-spec-maybe-invert '(:bold t)) -;; (color-theme-spec-maybe-invert '(:foreground "blue")) -;; (color-theme-spec-maybe-invert '(:background "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t)) -;; (color-theme-spec-maybe-invert '(:inverse-video t :foreground "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red" :foreground "blue" :bold t)) -;; (color-theme-spec-maybe-invert '(:inverse-video nil :background "red" :foreground "blue" :bold t)) - -(defun color-theme-spec (face) - "Return a list for FACE which has the form (FACE SPEC). -See `defface' for the format of SPEC. In this case we use only one -DISPLAY, t, and determine ATTS using `color-theme-face-attr-construct'. -If ATTS is nil, (nil) is used instead. - -If ATTS contains :inverse-video t, we remove it and swap foreground and -background color using `color-theme-spec-maybe-invert'. We do this -because :inverse-video is handled differently in Emacs and XEmacs. We -will loose on a tty without colors, because in that situation, -:inverse-video means something." - (let ((atts - (color-theme-spec-canonical-font - (color-theme-spec-maybe-invert - (color-theme-spec-resolve-inheritance - (color-theme-face-attr-construct face (selected-frame))))))) - (if atts - `(,face ((t ,atts))) - `(,face ((t (nil))))))) - -(defun color-theme-get-params () - "Return a list of frame parameter settings usable in a color theme. -Such an alist may be installed by `color-theme-install-frame-params'. The -frame parameters returned must match `color-theme-legal-frame-parameters'." - (let ((params (color-theme-filter (frame-parameters (selected-frame)) - color-theme-legal-frame-parameters))) - (sort params (lambda (a b) (string< (symbol-name (car a)) - (symbol-name (car b))))))) - -(defun color-theme-get-vars () - "Return a list of variable settings usable in a color theme. -Such an alist may be installed by `color-theme-install-variables'. -The variable names must match `color-theme-legal-variables', and the -variable must be a user variable according to `user-variable-p'." - (let ((vars) - (val)) - (mapatoms (lambda (v) - (and (boundp v) - (user-variable-p v) - (string-match color-theme-legal-variables - (symbol-name v)) - (setq val (eval v)) - (add-to-list 'vars (cons v val))))) - (sort vars (lambda (a b) (string< (car a) (car b)))))) - -(defun color-theme-print-alist (alist) - "Print ALIST." - (insert "\n " (if alist "(" "nil")) - (dolist (elem alist) - (when (= (preceding-char) ?\)) - (insert "\n ")) - (prin1 elem (current-buffer))) - (when (= (preceding-char) ?\)) (insert ")"))) - -(defun color-theme-get-faces () - "Return a list of faces usable in a color theme. -Such an alist may be installed by `color-theme-install-faces'. The -faces returned must not match `color-theme-illegal-faces'." - (let ((faces (color-theme-filter (face-list) color-theme-illegal-faces t))) - ;; default face must come first according to comments in - ;; custom-save-faces, the rest is to be sorted by name - (cons 'default (sort (delq 'default faces) 'string-lessp)))) - -(defun color-theme-get-face-definitions () - "Return face settings usable in a color-theme." - (let ((faces (color-theme-get-faces))) - (mapcar 'color-theme-spec faces))) - -(defun color-theme-print-faces (faces) - "Print face settings for all faces returned by `color-theme-get-faces'." - (when faces - (insert "\n ")) - (dolist (face faces) - (when (= (preceding-char) ?\)) - (insert "\n ")) - (prin1 face (current-buffer)))) - -(defun color-theme-reset-faces () - "Reset face settings for all faces returned by `color-theme-get-faces'." - (let ((faces (color-theme-get-faces)) - (face) (spec) (entry) - (frame (if color-theme-is-global nil (selected-frame)))) - (while faces - (setq entry (color-theme-spec (car faces))) - (setq face (nth 0 entry)) - (setq spec '((t (nil)))) - (setq faces (cdr faces)) - (if (functionp 'face-spec-reset-face) - (face-spec-reset-face face frame) - (face-spec-set face spec frame) - (if color-theme-is-global - (put face 'face-defface-spec spec)))))) - -(defun color-theme-print-theme (func doc params vars faces) - "Print a theme into the current buffer. -FUNC is the function name, DOC the doc string, PARAMS the -frame parameters, VARS the variable bindings, and FACES -the list of faces and their specs." - (insert "(defun " (symbol-name func) " ()\n" - " \"" doc "\"\n" - " (interactive)\n" - " (color-theme-install\n" - " '(" (symbol-name func)) - ;; alist of frame parameters - (color-theme-print-alist params) - ;; alist of variables - (color-theme-print-alist vars) - ;; remaining elements of snapshot: face specs - (color-theme-print-faces faces) - (insert ")))\n") - (insert "(add-to-list 'color-themes '(" (symbol-name func) " " - " \"THEME NAME\" \"YOUR NAME\"))") - (goto-char (point-min))) - -;;;###autoload -(defun color-theme-print (&optional buf) - "Print the current color theme function. - -You can contribute this function to <URL:news:gnu.emacs.sources> or -paste it into your .emacs file and call it. That should recreate all -the settings necessary for your color theme. - -Example: - - \(require 'color-theme) - \(defun my-color-theme () - \"Color theme by Alex Schroeder, created 2000-05-17.\" - \(interactive) - \(color-theme-install - '(... - ... - ...))) - \(my-color-theme) - -If you want to use a specific color theme function, you can call the -color theme function in your .emacs directly. - -Example: - - \(require 'color-theme) - \(color-theme-gnome2)" - (interactive) - (message "Pretty printing current color theme function...") - (switch-to-buffer (if buf - buf - (get-buffer-create "*Color Theme*"))) - (unless buf - (setq buffer-read-only nil) - (erase-buffer)) - ;; insert defun - (insert "(eval-when-compile" - " (require 'color-theme))\n") - (color-theme-print-theme 'my-color-theme - (concat "Color theme by " - (if (string= "" user-full-name) - (user-login-name) - user-full-name) - ", created " (format-time-string "%Y-%m-%d") ".") - (color-theme-get-params) - (color-theme-get-vars) - (mapcar 'color-theme-spec (color-theme-get-faces))) - (unless buf - (emacs-lisp-mode)) - (goto-char (point-min)) - (message "Pretty printing current color theme function... done")) - -(defun color-theme-analyze-find-theme (code) - "Find the sexpr that calls `color-theme-install'." - (let (theme) - (while (and (not theme) code) - (when (eq (car code) 'color-theme-install) - (setq theme code)) - (when (listp (car code)) - (setq theme (color-theme-analyze-find-theme (car code)))) - (setq code (cdr code))) - theme)) - -;; (equal (color-theme-analyze-find-theme -;; '(defun color-theme-blue-eshell () -;; "Color theme for eshell faces only." -;; (color-theme-install -;; '(color-theme-blue-eshell -;; nil -;; (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed")))) -;; (eshell-ls-backup-face ((t (:foreground "Grey")))))))) -;; '(color-theme-install -;; (quote -;; (color-theme-blue-eshell -;; nil -;; (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed")))) -;; (eshell-ls-backup-face ((t (:foreground "Grey"))))))))) - -(defun color-theme-analyze-add-face (a b regexp faces) - "If only one of A or B are in FACES, the other is added, and FACES is returned. -If REGEXP is given, this is only done if faces contains a match for regexps." - (when (or (not regexp) - (catch 'found - (dolist (face faces) - (when (string-match regexp (symbol-name (car face))) - (throw 'found t))))) - (let ((face-a (assoc a faces)) - (face-b (assoc b faces))) - (if (and face-a (not face-b)) - (setq faces (cons (list b (nth 1 face-a)) - faces)) - (if (and (not face-a) face-b) - (setq faces (cons (list a (nth 1 face-b)) - faces)))))) - faces) - -;; (equal (color-theme-analyze-add-face -;; 'blue 'violet nil -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue nil -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue "foo" -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue "blue" -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) - -(defun color-theme-analyze-add-faces (faces) - "Add missing faces to FACES and return it." - ;; The most important thing is to add missing faces for the other - ;; editor. These are the most important faces to check. The - ;; following rules list two faces, A and B. If either of the two is - ;; part of the theme, the other must be, too. The optional third - ;; argument specifies a regexp. Only if an existing face name - ;; matches this regexp, is the rule applied. - (let ((rules '((font-lock-builtin-face font-lock-reference-face) - (font-lock-doc-face font-lock-doc-string-face) - (font-lock-constant-face font-lock-preprocessor-face) - ;; In Emacs 21 `modeline' is just an alias for - ;; `mode-line'. I recommend the use of - ;; `modeline' until further notice. - (modeline mode-line) - (modeline modeline-buffer-id) - (modeline modeline-mousable) - (modeline modeline-mousable-minor-mode) - (region primary-selection) - (region zmacs-region) - (font-lock-string-face dired-face-boring "^dired") - (font-lock-function-name-face dired-face-directory "^dired") - (default dired-face-executable "^dired") - (font-lock-warning-face dired-face-flagged "^dired") - (font-lock-warning-face dired-face-marked "^dired") - (default dired-face-permissions "^dired") - (default dired-face-setuid "^dired") - (default dired-face-socket "^dired") - (font-lock-keyword-face dired-face-symlink "^dired") - (tool-bar menu)))) - (dolist (rule rules) - (setq faces (color-theme-analyze-add-face - (nth 0 rule) (nth 1 rule) (nth 2 rule) faces)))) - ;; The `fringe' face defines what the left and right borders of the - ;; frame look like in Emacs 21. To give them default fore- and - ;; background colors, use (fringe ((t (nil)))) in your color theme. - ;; Usually it makes more sense to choose a color slightly lighter or - ;; darker from the default background. - (unless (assoc 'fringe faces) - (setq faces (cons '(fringe ((t (nil)))) faces))) - ;; The tool-bar should not be part of the frame-parameters, since it - ;; should not appear or disappear depending on the color theme. The - ;; apppearance of the toolbar, however, can be changed by the color - ;; theme. For Emacs 21, use the `tool-bar' face. The easiest way - ;; to do this is to give it the default fore- and background colors. - ;; This can be achieved using (tool-bar ((t (nil)))) in the theme. - ;; Usually it makes more sense, however, to provide the same colors - ;; as used in the `menu' face, and to specify a :box attribute. In - ;; order to alleviate potential Emacs/XEmacs incompatibilities, - ;; `toolbar' will be defined as an alias for `tool-bar' if it does - ;; not exist, and vice-versa. This is done eventhough the face - ;; `toolbar' seems to have no effect on XEmacs. If you look at - ;; XEmacs lisp/faces.el, however, you will find that it is in fact - ;; referenced for XPM stuff. - (unless (assoc 'tool-bar faces) - (setq faces (cons '(tool-bar ((t (nil)))) faces))) - ;; Move the default face back to the front, and sort the rest. - (unless (eq (caar faces) 'default) - (let ((face (assoc 'default faces))) - (setq faces (cons face - (sort (delete face faces) - (lambda (a b) - (string-lessp (car a) (car b)))))))) - faces) - -(defun color-theme-analyze-remove-heights (faces) - "Remove :height property where it is an integer and return FACES." - ;; I don't recommend making font sizes part of a color theme. Most - ;; users would be surprised to see their font sizes change when they - ;; install a color-theme. Therefore, remove all :height attributes - ;; if the value is an integer. If the value is a float, this is ok - ;; -- the value is relative to the default height. One notable - ;; exceptions is for a color-theme created for visually impaired - ;; people. These *must* use a larger font in order to be usable. - (let (result) - (dolist (face faces) - (let ((props (cadar (nth 1 face)))) - (if (and (plist-member props :height) - (integerp (plist-get props :height))) - (setq props (color-theme-plist-delete props :height) - result (cons (list (car face) `((t ,props))) - result)) - (setq result (cons face result))))) - (nreverse result))) - -;; (equal (color-theme-analyze-remove-heights -;; '((blue ((t (:foreground "blue" :height 2)))) -;; (bold ((t (:bold t :height 1.0)))))) -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t :height 1.0)))))) - -;;;###autoload -(defun color-theme-analyze-defun () - "Once you have a color-theme printed, check for missing faces. -This is used by maintainers who receive a color-theme submission -and want to make sure it follows the guidelines by the color-theme -author." - ;; The support for :foreground and :background attributes works for - ;; Emacs 20 and 21 as well as for XEmacs. :inverse-video is taken - ;; care of while printing color themes. - (interactive) - ;; Parse the stuff and find the call to color-theme-install - (save-excursion - (save-restriction - (narrow-to-defun) - ;; define the function - (eval-defun nil) - (goto-char (point-min)) - (let* ((code (read (current-buffer))) - (theme (color-theme-canonic - (eval - (cadr - (color-theme-analyze-find-theme - code))))) - (func (color-theme-function theme)) - (doc (documentation func t)) - (variables (color-theme-variables theme)) - (faces (color-theme-faces theme)) - (params (color-theme-frame-params theme))) - (setq faces (color-theme-analyze-remove-heights - (color-theme-analyze-add-faces faces))) - ;; Remove any variable bindings of faces that point to their - ;; symbol? Perhaps not, because another theme might want to - ;; change this, so it is important to be able to reset them. - ;; (let (result) - ;; (dolist (var variables) - ;; (unless (eq (car var) (cdr var)) - ;; (setq result (cons var result)))) - ;; (setq variables (nreverse result))) - ;; Now modify the theme directly. - (setq theme (color-theme-analyze-find-theme code)) - (setcdr (cadadr theme) (list params variables faces)) - (message "Pretty printing analysed color theme function...") - (with-current-buffer (get-buffer-create "*Color Theme*") - (setq buffer-read-only nil) - (erase-buffer) - ;; insert defun - (color-theme-print-theme func doc params variables faces) - (emacs-lisp-mode)) - (message "Pretty printing analysed color theme function... done") - (ediff-buffers (current-buffer) - (get-buffer "*Color Theme*")))))) - -;;; Creating a snapshot of the current color theme - -(defun color-theme-snapshot nil) - -;;;###autoload -(defun color-theme-make-snapshot () - "Return the definition of the current color-theme. -The function returned will recreate the color-theme in use at the moment." - (eval `(lambda () - "The color theme in use when the selection buffer was created. -\\[color-theme-select] creates the color theme selection buffer. At the -same time, this snapshot is created as a very simple undo mechanism. -The snapshot is created via `color-theme-snapshot'." - (interactive) - (color-theme-install - '(color-theme-snapshot - ;; alist of frame parameters - ,(color-theme-get-params) - ;; alist of variables - ,(color-theme-get-vars) - ;; remaining elements of snapshot: face specs - ,@(color-theme-get-face-definitions)))))) - - - -;;; Handling the various parts of a color theme install - -(defvar color-theme-frame-param-frobbing-rules - '((foreground-color default foreground) - (background-color default background)) - "List of rules to use when frobbing faces based on frame parameters. -This is only necessary for XEmacs, because in Emacs 21 changing the -frame paramters automatically affects the relevant faces.") - -;; fixme: silent the bytecompiler with set-face-property -(defun color-theme-frob-faces (params) - "Change certain faces according to PARAMS. -This uses `color-theme-frame-param-frobbing-rules'." - (dolist (rule color-theme-frame-param-frobbing-rules) - (let* ((param (nth 0 rule)) - (face (nth 1 rule)) - (prop (nth 2 rule)) - (val (cdr (assq param params))) - (frame (if color-theme-is-global nil (selected-frame)))) - (when val - (set-face-property face prop val frame))))) - -(defun color-theme-alist-reduce (old-list) - "Reduce OLD-LIST. -The resulting list will be newly allocated and will not contain any elements -with duplicate cars. This will speed the installation of new themes by -only installing unique attributes." - (let (new-list) - (dolist (elem old-list) - (when (not (assq (car elem) new-list)) - (setq new-list (cons elem new-list)))) - new-list)) - -(defun color-theme-install-frame-params (params) - "Change frame parameters using alist PARAMETERS. - -If `color-theme-is-global' is non-nil, all frames are modified using -`modify-frame-parameters' and the PARAMETERS are prepended to -`default-frame-alist'. The value of `initial-frame-alist' is not -modified. If `color-theme-is-global' is nil, only the selected frame is -modified. If `color-theme-is-cumulative' is nil, the frame parameters -are restored from `color-theme-original-frame-alist'. - -If the current frame parameters have a parameter `minibuffer' with -value `only', then the frame parameters are not installed, since this -indicates a dedicated minibuffer frame. - -Called from `color-theme-install'." - (setq params (color-theme-filter - params color-theme-legal-frame-parameters)) - ;; We have a new list in params now, therefore we may use - ;; destructive nconc. - (if color-theme-is-global - (let ((frames (frame-list))) - (if (or color-theme-is-cumulative - (null color-theme-original-frame-alist)) - (setq default-frame-alist - (append params (color-theme-alist default-frame-alist)) - minibuffer-frame-alist - (append params (color-theme-alist minibuffer-frame-alist))) - (setq default-frame-alist - (append params color-theme-original-frame-alist) - minibuffer-frame-alist - (append params (color-theme-alist minibuffer-frame-alist)))) - (setq default-frame-alist - (color-theme-alist-reduce default-frame-alist) - minibuffer-frame-alist - (color-theme-alist-reduce minibuffer-frame-alist)) - (dolist (frame frames) - (let ((params (if (eq 'only (cdr (assq 'minibuffer (frame-parameters frame)))) - minibuffer-frame-alist - default-frame-alist))) - (condition-case var - (modify-frame-parameters frame params) - (error (message "Error using params %S: %S" params var)))))) - (condition-case var - (modify-frame-parameters (selected-frame) params) - (error (message "Error using params %S: %S" params var)))) - (when color-theme-xemacs-p - (color-theme-frob-faces params))) - -;; (setq default-frame-alist (cons '(height . 30) default-frame-alist)) - -(defun color-theme-install-variables (vars) - "Change variables using alist VARS. -All variables matching `color-theme-legal-variables' are set. - -If `color-theme-is-global' and `color-theme-xemacs-p' are nil, variables -are made frame-local before setting them. Variables are set using `set' -in either case. This may lead to problems if changing the variable -requires the usage of the function specified with the :set tag in -defcustom declarations. - -Called from `color-theme-install'." - (let ((vars (color-theme-filter vars color-theme-legal-variables))) - (dolist (var vars) - (if (or color-theme-is-global color-theme-xemacs-p) - (set (car var) (cdr var)) - (make-variable-frame-local (car var)) - (modify-frame-parameters (selected-frame) (list var)))))) - -(defun color-theme-install-faces (faces) - "Change faces using FACES. - -Change faces for all frames and create any faces listed in FACES which -don't exist. The modified faces will be marked as \"unchanged from -its standard setting\". This is OK, since the changes made by -installing a color theme should never by saved in .emacs by -customization code. - -FACES should be a list where each entry has the form: - - (FACE SPEC) - -See `defface' for the format of SPEC. - -If `color-theme-is-global' is non-nil, faces are modified on all frames -using `face-spec-set'. If `color-theme-is-global' is nil, faces are -only modified on the selected frame. Non-existing faces are created -using `make-empty-face' in either case. If `color-theme-is-cumulative' -is nil, all faces are reset before installing the new faces. - -Called from `color-theme-install'." - ;; clear all previous faces - (when (not color-theme-is-cumulative) - (color-theme-reset-faces)) - ;; install new faces - (let ((faces (color-theme-filter faces color-theme-illegal-faces t)) - (frame (if color-theme-is-global nil (selected-frame)))) - (dolist (entry faces) - (let ((face (nth 0 entry)) - (spec (nth 1 entry))) - (or (facep face) - (make-empty-face face)) - ;; remove weird properties from the default face only - (when (eq face 'default) - (setq spec (color-theme-spec-filter spec))) - ;; Emacs/XEmacs customization issues: filter out :bold when - ;; the spec contains :weight, etc, such that the spec remains - ;; "valid" for custom. - (setq spec (color-theme-spec-compat spec)) - ;; using a spec of ((t (nil))) to reset a face doesn't work - ;; in Emacs 21, we use the new function face-spec-reset-face - ;; instead - (if (and (functionp 'face-spec-reset-face) - (equal spec '((t (nil))))) - (face-spec-reset-face face frame) - (condition-case var - (progn - (face-spec-set face spec frame) - (if color-theme-is-global - (put face 'face-defface-spec spec))) - (error (message "Error using spec %S: %S" spec var)))))))) - -;; `custom-set-faces' is unusable here because it doesn't allow to set -;; the faces for one frame only. - -;; Emacs `face-spec-set': If FRAME is nil, the face is created and -;; marked as a customized face. This is achieved by setting the -;; `face-defface-spec' property. If we don't, new frames will not be -;; created using the face we installed because `face-spec-set' is -;; broken: If given a FRAME of nil, it will not set the default faces; -;; instead it will walk through all the frames and set modify the faces. -;; If we do set a property (`saved-face' or `face-defface-spec'), -;; `make-frame' will correctly use the faces we defined with our color -;; theme. If we used the property `saved-face', -;; `customize-save-customized' will save all the faces installed as part -;; of a color-theme in .emacs. That's why we use the -;; `face-defface-spec' property. - - - -;;; Theme accessor functions, canonicalization, merging, comparing - -(defun color-theme-canonic (theme) - "Return the canonic form of THEME. -This deals with all the backwards compatibility stuff." - (let (function frame-params variables faces) - (when (functionp (car theme)) - (setq function (car theme) - theme (cdr theme))) - (setq frame-params (car theme) - theme (cdr theme)) - ;; optional variable defintions (for backwards compatibility) - (when (listp (caar theme)) - (setq variables (car theme) - theme (cdr theme))) - ;; face definitions - (setq faces theme) - (list function frame-params variables faces))) - -(defun color-theme-function (theme) - "Return function used to create THEME." - (nth 0 theme)) - -(defun color-theme-frame-params (theme) - "Return frame-parameters defined by THEME." - (nth 1 theme)) - -(defun color-theme-variables (theme) - "Return variables set by THEME." - (nth 2 theme)) - -(defun color-theme-faces (theme) - "Return faces defined by THEME." - (nth 3 theme)) - -(defun color-theme-merge-alists (&rest alists) - "Merges all the alist arguments into one alist. -Only the first instance of every key will be part of the resulting -alist. Membership will be tested using `assq'." - (let (result) - (dolist (l alists) - (dolist (entry l) - (unless (assq (car entry) result) - (setq result (cons entry result))))) - (nreverse result))) -;; (color-theme-merge-alists '((a . 1) (b . 2))) -;; (color-theme-merge-alists '((a . 1) (b . 2) (a . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((a . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3) (d . 4))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3) (d . 4) (b . 5))) - -;;;###autoload -(defun color-theme-compare (theme-a theme-b) - "Compare two color themes. -This will print the differences between installing THEME-A and -installing THEME-B. Note that the order is important: If a face is -defined in THEME-A and not in THEME-B, then this will not show up as a -difference, because there is no reset before installing THEME-B. If a -face is defined in THEME-B and not in THEME-A, then this will show up as -a difference." - (interactive - (list - (intern - (completing-read "Theme A: " - (mapcar (lambda (i) (list (symbol-name (car i)))) - color-themes) - (lambda (i) (string-match "color-theme" (car i))))) - (intern - (completing-read "Theme B: " - (mapcar (lambda (i) (list (symbol-name (car i)))) - color-themes) - (lambda (i) (string-match "color-theme" (car i))))))) - ;; install the themes in a new frame and get the definitions - (let ((color-theme-is-global nil)) - (select-frame (make-frame)) - (funcall theme-a) - (setq theme-a (list theme-a - (color-theme-get-params) - (color-theme-get-vars) - (color-theme-get-face-definitions))) - (funcall theme-b) - (setq theme-b (list theme-b - (color-theme-get-params) - (color-theme-get-vars) - (color-theme-get-face-definitions))) - (delete-frame)) - (let ((params (set-difference - (color-theme-frame-params theme-b) - (color-theme-frame-params theme-a) - :test 'equal)) - (vars (set-difference - (color-theme-variables theme-b) - (color-theme-variables theme-a) - :test 'equal)) - (faces (set-difference - (color-theme-faces theme-b) - (color-theme-faces theme-a) - :test 'equal))) - (list 'diff - params - vars - faces))) - - - -;;; Installing a color theme -;;;###autoload -(defun color-theme-install (theme) - "Install a color theme defined by frame parameters, variables and faces. - -The theme is installed for all present and future frames; any missing -faces are created. See `color-theme-install-faces'. - -THEME is a color theme definition. See below for more information. - -If you want to install a color theme from your .emacs, use the output -generated by `color-theme-print'. This produces color theme function -which you can copy to your .emacs. - -A color theme definition is a list: -\([FUNCTION] FRAME-PARAMETERS VARIABLE-SETTINGS FACE-DEFINITIONS) - -FUNCTION is the color theme function which called `color-theme-install'. -This is no longer used. There was a time when this package supported -automatic factoring of color themes. This has been abandoned. - -FRAME-PARAMETERS is an alist of frame parameters. These are installed -with `color-theme-install-frame-params'. These are installed last such -that any changes to the default face can be changed by the frame -parameters. - -VARIABLE-DEFINITIONS is an alist of variable settings. These are -installed with `color-theme-install-variables'. - -FACE-DEFINITIONS is an alist of face definitions. These are installed -with `color-theme-install-faces'. - -If `color-theme-is-cumulative' is nil, a color theme will undo face and -frame-parameter settings of previous color themes." - (setq theme (color-theme-canonic theme)) - (color-theme-install-variables (color-theme-variables theme)) - (color-theme-install-faces (color-theme-faces theme)) - ;; frame parameters override faces - (color-theme-install-frame-params (color-theme-frame-params theme)) - (when color-theme-history-max-length - (color-theme-add-to-history - (car theme)))) - - - -;; Sharing your stuff -;;;###autoload -(defun color-theme-submit () - "Submit your color-theme to the maintainer." - (interactive) - (require 'reporter) - (let ((reporter-eval-buffer (current-buffer)) - final-resting-place - after-sep-pos - (reporter-status-message "Formatting buffer...") - (reporter-status-count 0) - (problem "Yet another color-theme") - (agent (reporter-compose-outgoing)) - (mailbuf (current-buffer)) - hookvar) - ;; do the work - (require 'sendmail) - ;; If mailbuf did not get made visible before, make it visible now. - (let (same-window-buffer-names same-window-regexps) - (pop-to-buffer mailbuf) - ;; Just in case the original buffer is not visible now, bring it - ;; back somewhere - (and pop-up-windows (display-buffer reporter-eval-buffer))) - (goto-char (point-min)) - (mail-position-on-field "to") - (insert color-theme-maintainer-address) - (mail-position-on-field "subject") - (insert problem) - ;; move point to the body of the message - (mail-text) - (setq after-sep-pos (point)) - (unwind-protect - (progn - (setq final-resting-place (point-marker)) - (goto-char final-resting-place)) - (color-theme-print (current-buffer)) - (goto-char final-resting-place) - (insert "\n\n") - (goto-char final-resting-place) - (insert "Hello there!\n\nHere's my color theme named: ") - (set-marker final-resting-place nil)) - ;; compose the minibuf message and display this. - (let* ((sendkey-whereis (where-is-internal - (get agent 'sendfunc) nil t)) - (abortkey-whereis (where-is-internal - (get agent 'abortfunc) nil t)) - (sendkey (if sendkey-whereis - (key-description sendkey-whereis) - "C-c C-c")); TBD: BOGUS hardcode - (abortkey (if abortkey-whereis - (key-description abortkey-whereis) - "M-x kill-buffer"))); TBD: BOGUS hardcode - (message "Enter a message and type %s to send or %s to abort." - sendkey abortkey)))) - - - -;; Use this to define themes -(defmacro define-color-theme (name author description &rest forms) - (let ((n name)) - `(progn - (add-to-list 'color-themes - (list ',n - (upcase-initials - (replace-in-string - (replace-in-string - (symbol-name ',n) "^color-theme-" "") "-" " ")) - ,author)) - (defun ,n () - ,description - (interactive) - ,@forms)))) - - -;;; FIXME: is this useful ?? -;;;###autoload -(defun color-theme-initialize () - "Initialize the color theme package by loading color-theme-libraries." - (interactive) - - (cond ((and (not color-theme-load-all-themes) - color-theme-directory) - (setq color-theme-libraries - (directory-files color-theme-directory t "^color-theme"))) - (color-theme-directory - (push (cdr (directory-files color-theme-directory t "^color-theme")) - color-theme-libraries))) - (dolist (library color-theme-libraries) - (load library))) - -(when nil - (setq color-theme-directory "themes/" - color-theme-load-all-themes nil) - (color-theme-initialize) -) -;; TODO: I don't like all those function names cluttering up my namespace. -;; Instead, a hashtable for the color-themes should be created. Now that -;; define-color-theme is around, it should be easy to change in just the -;; one place. - - -(provide 'color-theme) - -;;; color-theme.el ends here diff --git a/emacs.d/elisp/manage-org.el b/emacs.d/elisp/manage-org.el deleted file mode 100644 index 1b2b5bb..0000000 --- a/emacs.d/elisp/manage-org.el +++ /dev/null @@ -1,40 +0,0 @@ -(defun clone-org-files () - (interactive) - (if (= (shell-command - "git clone git@82.170.172.156:private/org.git ~/prj/org" - "*Messages*" "*Messages*") 0) - (message "success!") - (message "failed!"))) - -(defun get-org-files () - (interactive) - (let ((prev-dir (getenv "PWD"))) - (if (= (shell-command - (format "cd ~/prj/org/; git pull origin master; cd %s" prev-dir) - "*Messages*" "*Messages*") 0) - (message "success!") - (message "failed!")))) - -(defun save-org-files () - (interactive) - (let ((prev-dir (getenv "PWD"))) - (if (= (shell-command - (format - "cd ~/prj/org/; git add .; git commit -m \"Change for %s\"; cd %s" - (format-time-string "%Y-%m-%d at %H:%M:%S") - prev-dir) - "*Messages*" "*Messages*") 0) - (message "success!") - (message "failed!")))) - -(defun push-org-files () - (interactive) - (let ((prev-dir (getenv "PWD"))) - (if (= (shell-command - (format - "cd ~/prj/org/; git push origin master; cd %s" prev-dir) - "*Messages*" "*Messages*") 0) - (message "success!") - (message "failed!")))) - -(provide 'manage-org) diff --git a/emacs.d/elisp/minimap.el b/emacs.d/elisp/minimap.el deleted file mode 100644 index 69db8b1..0000000 --- a/emacs.d/elisp/minimap.el +++ /dev/null @@ -1,630 +0,0 @@ -;;; minimap.el --- Minimap sidebar for Emacs - -;; Copyright (C) 2009, 2010 David Engster - -;; Author: David Engster <dengste@eml.cc> -;; Keywords: -;; Version: 0.7 - -;; This file is NOT part of GNU Emacs. - -;; 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, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file is an implementation of a minimap sidebar, i.e., a -;; smaller display of the current buffer on the left side. It -;; highlights the currently shown region and updates its position -;; automatically. You can navigate in the minibar by dragging the -;; active region with the mouse, which will scroll the corresponding -;; edit buffer. - -;; Usage: -;; * Put minimap.el in your load path. -;; * (require 'minimap) -;; * Use 'M-x minimap-create' in a buffer you're currently editing. -;; * Use 'M-x minimap-kill' to kill the minimap. -;; * Use 'M-x customize-group RET minimap RET' to adapt minimap to your needs. - -;; Download: -;; You can always get the latest version from the git repository: -;; git://randomsample.de/minimap.git -;; or http://randomsample.de/minimap.git - -;;; KNOWN BUGS: - -;; * Currently cannot deal with images. -;; * Display/movement can be a bit erratic at times. - -;;; TODO: - -;; * Fix known bugs. -;; * Make sidebar permanently visible. This requires something like a -;; 'window group' feature in Emacs, which is currently being worked on. -;; * Moving the active region with the keyboard / mouse-wheel ? - - -;;; Customizable variables: - -(defgroup minimap nil - "A minimap sidebar for Emacs." - :group 'convenience) - -(defface minimap-font-face - '((default :family "DejaVu Sans Mono" :height 30)) - "Face used for text in minimap buffer, notably the font family and height. -This height should be really small. You probably want to use a -TrueType font for this. After changing this, you should -recreate the minimap to avoid problems with recentering." - :group 'minimap) - -(defface minimap-active-region-background - '((((background dark)) (:background "#4517305D0000")) - (t (:background "#C847D8FEFFFF"))) - "Face for the active region in the minimap. -By default, this is only a different background color." - :group 'minimap) - -(defface minimap-semantic-function-face - '((((background dark)) - (:box (:line-width 1 :color "white") - :inherit (font-lock-function-name-face minimap-font-face) - :height 2.5 :background "gray10")) - (t (:box (:line-width 1 :color "black") - :inherit (font-lock-function-name-face minimap-font-face) - :height 2.5 :background "gray90"))) - "Face used for functions in the semantic overlay.") - -(defface minimap-semantic-variable-face - '((((background dark)) - (:box (:line-width 1 :color "white") - :inherit (font-lock-variable-name-face minimap-font-face) - :height 2.5 :background "gray10")) - (t (:box (:line-width 1 :color "black") - :inherit (font-lock-function-name-face minimap-font-face) - :height 2.5 :background "gray90"))) - "Face used for variables in the semantic overlay.") - -(defface minimap-semantic-type-face - '((((background dark)) - (:box (:line-width 1 :color "white") - :inherit (font-lock-type-face minimap-font-face) - :height 2.5 :background "gray10")) - (t (:box (:line-width 1 :color "black") - :inherit (font-lock-function-name-face minimap-font-face) - :height 2.5 :background "gray90"))) - "Face used for types in the semantic overlay.") - -(defcustom minimap-width-fraction 0.2 - "Fraction of width which should be used for minimap sidebar." - :type 'number - :group 'minimap) - -(defcustom minimap-window-location 'left - "Location of the minimap window. -Can be either the symbol `left' or `right'." - :type '(choice (const :tag "Left" left) - (const :tag "Right" right)) - :group 'minimap) - -(defcustom minimap-buffer-name-prefix "*MINIMAP* " - "Prefix for buffer names of minimap sidebar." - :type 'string - :group 'minimap) - -(defcustom minimap-update-delay 0.2 - "Delay in seconds after which sidebar gets updated. -Setting this to 0 will let the minimap react immediately, but -this will slow down scrolling." - :type 'number - :set (lambda (sym value) - (set sym value) - (when (and (boundp 'minimap-timer-object) - minimap-timer-object) - (cancel-timer minimap-timer-object) - (setq minimap-timer-object - (run-with-idle-timer - minimap-update-delay t 'minimap-update)))) - :group 'minimap) - -(defcustom minimap-always-recenter nil - "Whether minimap sidebar should be recentered after every point movement." - :type 'boolean - :group 'minimap) - -(defcustom minimap-recenter-type 'relative - "Specifies the type of recentering the minimap should use. -The minimap can use different types of recentering, i.e., how the -minimap should behave when you scroll in the main window or when -you drag the active region with the mouse. The following -explanations will probably not help much, so simply try them and -choose the one which suits you best. - -`relative' -- The position of the active region in the minimap -corresponds with the relative position of this region in the -buffer. This the default. - -`middle' -- The active region will stay fixed in the middle of -the minimap. - -`free' -- The position will be more or less free. When dragging -the active region, the minimap will scroll when you reach the -bottom or top." - :type '(choice (const :tag "Relative" relative) - (const :tag "Middle" middle) - (const :tag "Free" free)) - :group 'minimap) - -(defcustom minimap-hide-scroll-bar t - "Whether the minimap should hide the vertical scrollbar." - :type 'boolean - :group 'minimap) - -(defcustom minimap-hide-fringes t - "Whether the minimap should hide the fringes." - :type 'boolean - :group 'minimap) - -(defcustom minimap-dedicated-window nil - "Whether the minimap should create a dedicated window." - :type 'boolean - :group 'minimap) - -(defcustom minimap-display-semantic-overlays t - "Display overlays from CEDET's semantic analyzer. -If you use CEDET and the buffer's major-mode is supported, the -minimap can display overlays generated by the semantic analyzer. -By default, it will apply the faces `minimap-semantic-<X>-face', -with <X> being \"function\", \"variable\" and \"type\". Also, it -will display the name of the tag in the middle of the overlay in -the corresponding font-lock face. - -See also `minimap-enlarge-certain-faces', which can be used as -fallback." - :type 'boolean - :group 'minimap) - -(defcustom minimap-enlarge-certain-faces 'as-fallback - "Whether certain faces should be enlarged in the minimap. -All faces listed in `minimap-normal-height-faces' will be -displayed using the default font height, allowing you to still -read text using those faces. By default, this should enlarge all -function names in the minimap, given you have font locking -enabled. This variable can have the following values: - -'as-fallback (the default) -- The feature will only be activated - if information from CEDET's semantic analyzer isn't available - (see: `minimap-display-semantic-overlays'). -'always -- Always active. -nil -- Inactive." - :type '(choice (const :tag "Fallback if CEDET unavailable." 'as-fallback) - (const :tag "Always active." 'always) - (const :tag "Inactive." nil)) - :group 'minimap) - -(defcustom minimap-normal-height-faces '(font-lock-function-name-face) - "List of faces which should be displayed with normal height. -When `minimap-enlarge-certain-faces' is non-nil, all faces in -this list will be displayed using the default font height. By -default, this list contains `font-lock-function-name-face', so -you can still read function names in the minimap." - :type '(repeat face) - :group 'minimap) - -(defcustom minimap-sync-overlay-properties '(face invisible) - "Specifies which overlay properties should be synced. -Unlike text properties, overlays are not applied automatically to -the minimap and must be explicitly synced. This variable -specifies which overlay properties should be synced by -`minimap-sync-overlays'. Most importantly, this variable should -include 'invisible', so that hidden text does not appear in the -minimap buffer." - :type '(repeat symbol) - :group 'minimap) - -;;; Internal variables - -(defvar minimap-start nil) -(defvar minimap-end nil) -(defvar minimap-active-overlay nil) -(defvar minimap-bufname nil) -(defvar minimap-timer-object nil) -(defvar minimap-active-minimaps 0) -(defvar minimap-base-overlay nil) -(defvar minimap-numlines nil) -(defvar minimap-pointmin-overlay nil) - -(make-variable-buffer-local 'minimap-start) -(make-variable-buffer-local 'minimap-end) -(make-variable-buffer-local 'minimap-active-overlay) -(make-variable-buffer-local 'minimap-bufname) -(make-variable-buffer-local 'minimap-base-overlay) -(make-variable-buffer-local 'minimap-numlines) -(make-variable-buffer-local 'minimap-pointmin-overlay) - -;;; Minimap creation / killing - -;;;###autoload -(defun minimap-create () - "Create a minimap sidebar for the current window." - (interactive) - ;; If minimap is visible, do nothing. - (unless (and minimap-bufname - (get-buffer minimap-bufname) - (get-buffer-window (get-buffer minimap-bufname))) - (let ((bufname (concat minimap-buffer-name-prefix - (buffer-name (current-buffer)))) - (new-win (if (eq minimap-window-location 'left) - (split-window-horizontally - (round (* (window-width) - minimap-width-fraction))) - (split-window-horizontally - (round (* (window-width) - (- 1 minimap-width-fraction)))) - (other-window 1)))) - ;; If minimap exists but isn't visible, reuse it. - (if (and minimap-bufname - (get-buffer minimap-bufname)) - (switch-to-buffer minimap-bufname t) - ;; Otherwise create new minimap - (minimap-new-minimap bufname) - ;; If this is the first minimap, create the idle timer. - (when (zerop minimap-active-minimaps) - (setq minimap-timer-object - (run-with-idle-timer minimap-update-delay t 'minimap-update))) - (setq minimap-active-minimaps - (1+ minimap-active-minimaps)))) - (other-window 1) - (minimap-sync-overlays))) - -(defun minimap-new-minimap (bufname) - "Create new minimap BUFNAME for current buffer and window." - (let ((indbuf (make-indirect-buffer (current-buffer) bufname t)) - (edges (window-pixel-edges))) - (setq minimap-bufname bufname) - (set-buffer indbuf) - (when minimap-hide-scroll-bar - (setq vertical-scroll-bar nil)) - (switch-to-buffer indbuf) - (setq minimap-base-overlay (make-overlay (point-min) (point-max) nil t t)) - (overlay-put minimap-base-overlay 'face 'minimap-font-face) - (overlay-put minimap-base-overlay 'priority 1) - (setq minimap-pointmin-overlay (make-overlay (point-min) (1+ (point-min)))) - (setq minimap-start (window-start) - minimap-end (window-end) - minimap-active-overlay (make-overlay minimap-start minimap-end) - line-spacing 0) - (overlay-put minimap-active-overlay 'face - 'minimap-active-region-background) - (overlay-put minimap-active-overlay 'priority 5) - (minimap-mode 1) - (when (and (boundp 'linum-mode) - linum-mode) - (linum-mode 0)) - (when minimap-hide-fringes - (set-window-fringes nil 0 0)) - (when minimap-dedicated-window - (set-window-dedicated-p nil t)) - (setq buffer-read-only t) - ;; Calculate the actual number of lines displayable with the minimap face. - (setq minimap-numlines - (floor - (/ - (- (nth 3 edges) (nth 1 edges)) - (car (progn (redisplay) (window-line-height)))))))) - -;;;###autoload -(defun minimap-kill () - "Kill minimap for current buffer. -Cancel the idle timer if no more minimaps are active." - (interactive) - (if (null minimap-bufname) - (message "No minimap associated with %s." (buffer-name (current-buffer))) - (let ((curname (buffer-name (current-buffer))) - (buf (get-buffer minimap-bufname)) - (win (get-buffer-window minimap-bufname))) - (setq minimap-bufname nil) - (if (null buf) - (message "No minimap associated with %s." curname) - (when win - (delete-window win)) - (kill-buffer buf) - (when (zerop - (setq minimap-active-minimaps - (1- minimap-active-minimaps))) - (cancel-timer minimap-timer-object) - (setq minimap-timer-object nil)) - (message "Minimap for %s killed." curname))))) - -;;; Minimap update - -(defun minimap-update (&optional force) - "Update minimap sidebar if necessary. -This is meant to be called from the idle-timer or the post command hook. -When FORCE, enforce update of the active region." - (when minimap-bufname - (let ((win (get-buffer-window minimap-bufname)) - start end pt ov) - (when win - (setq start (window-start) - end (window-end) - pt (point) - ov) - (with-selected-window win - (unless (and (not force) - (= minimap-start start) - (= minimap-end end)) - (move-overlay minimap-active-overlay start end) - (setq minimap-start start - minimap-end end) - (minimap-recenter (line-number-at-pos (/ (+ end start) 2)) - (/ (- (line-number-at-pos end) - (line-number-at-pos start)) - 2))) - (goto-char pt) - (when minimap-always-recenter - (recenter (round (/ (window-height) 2))))))))) - -;;; Overlay movement - -(defun minimap-move-overlay-mouse (start-event) - "Move overlay by tracking mouse movement." - (interactive "e") - (mouse-set-point start-event) - (when (get-buffer-window (buffer-base-buffer (current-buffer))) - (let* ((echo-keystrokes 0) - (end-posn (event-end start-event)) - (start-point (posn-point end-posn)) - (make-cursor-line-fully-visible nil) - (cursor-type nil) - (pcselmode pc-selection-mode) - pt ev) - (when pcselmode - (pc-selection-mode -1)) - (move-overlay minimap-active-overlay start-point minimap-end) - (track-mouse - (minimap-set-overlay start-point) - (while (and - (consp (setq ev (read-event))) - (eq (car ev) 'mouse-movement)) - (setq pt (posn-point (event-start ev))) - (when (numberp pt) - (minimap-set-overlay pt)))) - (select-window (get-buffer-window (buffer-base-buffer))) - (minimap-update) - (when pcselmode - (pc-selection-mode 1))))) - -(defun minimap-set-overlay (pt) - "Set overlay position, with PT being the middle." - (goto-char pt) - (let* ((ovstartline (line-number-at-pos minimap-start)) - (ovendline (line-number-at-pos minimap-end)) - (ovheight (round (/ (- ovendline ovstartline) 2))) - (line (line-number-at-pos)) - (winstart (window-start)) - (winend (window-end)) - newstart newend) - (setq pt (point-at-bol)) - (setq newstart (minimap-line-to-pos (- line ovheight))) - ;; Perform recentering - (minimap-recenter line ovheight) - ;; Set new position in main buffer and redisplay - (with-selected-window (get-buffer-window (buffer-base-buffer)) - (goto-char pt) - (set-window-start nil newstart) - (redisplay t) - (setq newend (window-end))) - (when (eq minimap-recenter-type 'free) - (while (> newend winend) - (scroll-up 5) - (redisplay t) - (setq winend (window-end)))) - (move-overlay minimap-active-overlay newstart newend))) - -(defun minimap-line-to-pos (line) - "Return point position of line number LINE." - (save-excursion - (goto-char 1) - (if (eq selective-display t) - (re-search-forward "[\n\C-m]" nil 'end (1- line)) - (forward-line (1- line))) - (point))) - -(defun minimap-recenter (middle height) - "Recenter the minimap according to `minimap-recenter-type'. -MIDDLE is the line number in the middle of the active region. -HEIGHT is the number of lines from MIDDLE to begin/end of the -active region." - (cond - ;; Relative recentering - ((eq minimap-recenter-type 'relative) - (let* ((maxlines (line-number-at-pos (point-max))) - percentage relpos newline start numlines) - (setq numlines (count-lines (window-start) (window-end))) - (setq percentage (/ (float middle) (float maxlines))) - (setq newline (ceiling (* percentage numlines))) - (setq start (minimap-line-to-pos - (- middle height - (floor (* percentage - (- numlines height height)))))) - (or (> start (point-min)) - (setq start (point-min))) - ;; If (point-max) already visible, don't go further - (if (and (> start (window-start)) - (with-selected-window (get-buffer-window (buffer-base-buffer)) - (= (point-max) (window-end)))) - (save-excursion - (goto-char (point-max)) - (recenter -1)) - (unless (and (> start (window-start)) - (= (point-max) (window-end))) - (set-window-start nil start))))) - ;; Middle recentering - ((eq minimap-recenter-type 'middle) - (let ((start (- middle height - (floor (* 0.5 - (- minimap-numlines height height)))))) - (if (< start 1) - (progn - ;; Hack: Emacs cannot scroll down any further, so we fake - ;; it using an overlay. Otherwise, the active region - ;; would move to the top. - (overlay-put minimap-pointmin-overlay - 'display (concat - (make-string (abs start) 10) - (buffer-substring (point-min) (1+ (point-min))))) - (overlay-put minimap-pointmin-overlay - 'face `(:background ,(face-background 'default))) - (overlay-put minimap-pointmin-overlay - 'priority 10) - (setq start 1)) - (overlay-put minimap-pointmin-overlay 'display "") - (overlay-put minimap-pointmin-overlay 'face nil)) - (set-window-start nil (minimap-line-to-pos start)))) - ;; Free recentering - ((eq minimap-recenter-type 'free) - (let ((newstart (minimap-line-to-pos (- middle height))) - (winstart (window-start))) - (while (< newstart winstart) - (scroll-down 5) - (redisplay t) - (setq winstart (window-start))))))) - -;;; Minimap minor mode - -(defvar minimap-mode-map (make-sparse-keymap) - "Keymap used by `minimap-mode'.") - -(define-key minimap-mode-map [down-mouse-1] 'minimap-move-overlay-mouse) -(define-key minimap-mode-map [down-mouse-2] 'minimap-move-overlay-mouse) -(define-key minimap-mode-map [down-mouse-3] 'minimap-move-overlay-mouse) - -(define-minor-mode minimap-mode - "Minor mode for minimap sidebar." - nil "minimap" minimap-mode-map) - -;;; Sync minimap with modes which create/delete overlays. - -(defun minimap-sync-overlays () - "Synchronize overlays between base and minimap buffer. -Apply semantic overlays or face enlargement if necessary." - (interactive) - (when minimap-bufname - (let ((baseov (overlays-in (point-min) (point-max))) - (semantic (and (boundp 'semantic-version) - (semantic-active-p))) - ov props p) - (with-current-buffer minimap-bufname - (remove-overlays) - (while baseov - (when (setq props (minimap-get-sync-properties (car baseov))) - (setq ov (make-overlay (overlay-start (car baseov)) - (overlay-end (car baseov)))) - (while (setq p (car props)) - (overlay-put ov (car p) (cadr p)) - (setq props (cdr props)))) - (setq baseov (cdr baseov))) - (move-overlay minimap-pointmin-overlay (point-min) (1+ (point-min))) - ;; Re-apply font overlay - (move-overlay minimap-base-overlay (point-min) (point-max))) - ;; Face enlargement - (when (and font-lock-mode - (or (eq minimap-enlarge-certain-faces 'always) - (and (eq minimap-enlarge-certain-faces 'as-fallback) - (or (not minimap-display-semantic-overlays) - (not semantic))))) - (when (eq font-lock-support-mode 'jit-lock-mode) - (jit-lock-fontify-now)) - (with-current-buffer minimap-bufname - (minimap-enlarge-faces))) - ;; Semantic overlays - (when (and semantic - minimap-display-semantic-overlays) - (minimap-apply-semantic-overlays))) - (minimap-update t))) - -(defun minimap-get-sync-properties (ov) - "Get properties from overlay OV which should be synced. -You can specify those properties with -`minimap-sync-overlay-properties'." - (delq nil - (mapcar - (lambda (p) - (let ((val (overlay-get ov p))) - (if val - (list p val) - nil))) - minimap-sync-overlay-properties))) - -(defun minimap-enlarge-faces () - "Apply default font to all faces in `minimap-normal-height-faces'. -This has to be called in the minimap buffer." - (let ((pos (next-single-property-change (point-min) 'face)) - next ov face) - (while pos - (setq face (get-text-property pos 'face)) - (when (delq nil (mapcar (lambda (x) (equal x face)) - minimap-normal-height-faces)) - (setq ov - (make-overlay pos - (setq pos (next-single-property-change pos 'face)))) - (overlay-put ov 'face `(:family ,(face-font 'default))) - (overlay-put ov 'priority 5)) - (setq pos (next-single-property-change pos 'face))))) - -(defun minimap-apply-semantic-overlays () - "Apply semantic overlays to the minimap. -This has to be called from the base buffer." - (let ((tags (semantic-fetch-tags)) - tag class ov ovnew) - (while tags - (setq tag (car tags)) - (setq class (semantic-tag-class tag)) - (setq ov (semantic-tag-overlay tag)) - (when (and (overlayp ov) - (or (eq class 'function) - (eq class 'type) - (eq class 'variable))) - (with-current-buffer minimap-bufname - (let ((start (overlay-start ov)) - (end (overlay-end ov)) - (name (semantic-tag-name tag))) - (overlay-put - (setq ovnew (make-overlay start end)) - 'face `(:background ,(face-background - (intern (format "minimap-semantic-%s-face" - (symbol-name class)))))) - (overlay-put ovnew 'priority 1) - (setq start - (minimap-line-to-pos (/ (+ (line-number-at-pos start) - (line-number-at-pos end)) 2))) - (setq end (progn (goto-char start) (point-at-eol))) - (setq ovnew (make-overlay start end)) - (overlay-put ovnew 'face (format "minimap-semantic-%s-face" - (symbol-name class))) - (overlay-put ovnew 'display (concat " " name " ")) - (overlay-put ovnew 'priority 6)))) - (setq tags (cdr tags))))) - -;; outline-(minor-)mode -(add-hook 'outline-view-change-hook 'minimap-sync-overlays) - -;; hideshow -(add-hook 'hs-hide-hook 'minimap-sync-overlays) -(add-hook 'hs-show-hook 'minimap-sync-overlays) - -(provide 'minimap) - -;;; minimap.el ends here diff --git a/emacs.d/elisp/muse/Makefile b/emacs.d/elisp/muse/Makefile deleted file mode 100644 index 8fa07a0..0000000 --- a/emacs.d/elisp/muse/Makefile +++ /dev/null @@ -1,99 +0,0 @@ -.PHONY: all lisp autoloads clean realclean distclean fullclean install test -.PRECIOUS: %.elc - -DEFS = $(shell test -f ../Makefile.defs && echo ../Makefile.defs \ - || echo ../Makefile.defs.default) - -include $(DEFS) - -EL = $(filter-out $(PROJECT)-autoloads.el,$(wildcard *.el)) -ELC = $(patsubst %.el,%.elc,$(EL)) - -all: lisp - -lisp: autoloads $(ELC) - -$(PROJECT)-build.elc: ../scripts/$(PROJECT)-build.el - @echo $(PROJECT)-build.el is not byte-compiled - -autoloads: $(PROJECT)-autoloads.el - -$(PROJECT)-autoloads.el: $(EL) - @$(EMACS) -q $(SITEFLAG) -batch -l ../scripts/$(PROJECT)-build.el \ - -f $(PROJECT)-generate-autoloads . ../contrib ../experimental - -%.elc: %.el - @$(EMACS) -q $(SITEFLAG) -batch -l ../scripts/$(PROJECT)-build.el \ - -f batch-byte-compile $< - -clean distclean: - -rm -f *.elc *~ - -realclean fullclean: clean - -rm -f $(PROJECT)-autoloads.el - -install: autoloads $(ELC) - install -d $(ELISPDIR) - install -m 0644 $(PROJECT)-autoloads.el $(EL) $(ELC) $(ELISPDIR) - -test: $(ELC) - $(EMACS) -q $(SITEFLAG) -batch -l ../scripts/$(PROJECT)-build.el \ - -f $(PROJECT)-elint-files $(EL) - -# Dependencies -# -# This allows us to recompile Muse safely after an update. - -muse-backlink.elc: muse-mode.elc muse-publish.elc muse.elc - -muse-blosxom.elc: muse-html.elc muse-project.elc muse-publish.elc - -muse-book.elc: muse-latex.elc muse-project.elc muse-publish.elc -muse-book.elc: muse-regexps.elc - -muse-colors.elc: muse-mode.elc muse-regexps.elc - -muse-context.elc: muse-publish.elc - -muse-docbook.elc: muse-publish.elc muse-regexps.elc muse-xml-common.elc - -muse-groff.elc: muse-publish.elc - -muse-html.elc: muse-publish.elc muse-regexps.elc muse-xml-common.elc - -muse-http.elc: muse-html.elc muse-project.elc - -muse-ikiwiki.elc: muse-html.elc muse-ipc.elc muse-publish.elc muse.elc - -muse-import-docbook.elc: muse-import-xml.elc - -muse-import-latex.elc: muse-regexps.elc muse.elc - -muse-ipc.elc: muse-publish.elc muse.elc - -muse-journal.elc: muse-book.elc muse-html.elc muse-latex.elc -muse-journal.elc: muse-publish.elc - -muse-latex.elc: muse-publish.elc - -muse-latex2png.elc: muse-publish.elc - -muse-mode.elc: muse-regexps.elc muse-project.elc - -muse-poem.elc: muse-latex.elc muse-project.elc - -muse-project.elc: muse-publish.elc muse.elc - -muse-protocols.elc: muse-regexps.elc - -muse-publish.elc: muse-regexps.elc muse.elc - -muse-texinfo.elc: muse-latex.elc muse-publish.elc - -muse-wiki.elc: muse-colors.elc muse-regexps.elc muse-mode.elc - -muse-xml-common.elc: muse-publish.elc muse-regexps.elc - -muse-xml.elc: muse-publish.elc muse-regexps.elc muse-xml-common.elc - -muse.elc: muse-protocols.elc muse-regexps.elc diff --git a/emacs.d/elisp/muse/muse-autoloads.el b/emacs.d/elisp/muse/muse-autoloads.el deleted file mode 100644 index d22ce26..0000000 --- a/emacs.d/elisp/muse/muse-autoloads.el +++ /dev/null @@ -1,303 +0,0 @@ -;;; muse-autoloads.el --- autoloads for Muse -;; -;;; Code: - -;;;### (autoloads nil "muse" "muse.el" (19301 54276)) -;;; Generated autoloads from muse.el - (add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode)) - -;;;*** - -;;;### (autoloads (muse-colors-toggle-inline-images) "muse-colors" -;;;;;; "muse-colors.el" (19301 53189)) -;;; Generated autoloads from muse-colors.el - -(autoload 'muse-colors-toggle-inline-images "muse-colors" "\ -Toggle display of inlined images on/off. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (muse-import-docbook-files muse-import-docbook) -;;;;;; "muse-import-docbook" "muse-import-docbook.el" (19301 53204)) -;;; Generated autoloads from muse-import-docbook.el - -(autoload 'muse-import-docbook "muse-import-docbook" "\ -Convert the Docbook buffer SRC to Muse, writing output in the DEST buffer. - -\(fn SRC DEST)" t nil) - -(autoload 'muse-import-docbook-files "muse-import-docbook" "\ -Convert the Docbook file SRC to Muse, writing output to the DEST file. - -\(fn SRC DEST)" t nil) - -;;;*** - -;;;### (autoloads (muse-import-latex) "muse-import-latex" "muse-import-latex.el" -;;;;;; (19301 53192)) -;;; Generated autoloads from muse-import-latex.el - -(autoload 'muse-import-latex "muse-import-latex" "\ -Not documented - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (muse-message-markup) "muse-message" "../experimental/muse-message.el" -;;;;;; (18175 10245)) -;;; Generated autoloads from ../experimental/muse-message.el - -(autoload 'muse-message-markup "muse-message" "\ -Markup a wiki-ish e-mail message as HTML alternative e-mail. -This step is manual by default, to give the author a chance to review -the results and ensure they are appropriate. -If you wish it to be automatic (a risky proposition), just add this -function to `message-send-hook'. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads (muse-list-edit-minor-mode muse-insert-tag muse-index -;;;;;; muse-find-backlinks muse-search muse-search-with-command -;;;;;; muse-what-changed muse-previous-reference muse-next-reference -;;;;;; muse-follow-name-at-point-other-window muse-follow-name-at-point -;;;;;; muse-browse-result muse-edit-link-at-point muse-insert-relative-link-to-file -;;;;;; muse-decrease-list-item-indentation muse-increase-list-item-indentation -;;;;;; muse-insert-list-item muse-mode-choose-mode muse-mode) "muse-mode" -;;;;;; "muse-mode.el" (19301 53218)) -;;; Generated autoloads from muse-mode.el - -(autoload 'muse-mode "muse-mode" "\ -Muse is an Emacs mode for authoring and publishing documents. -\\{muse-mode-map} - -\(fn)" t nil) - -(autoload 'muse-mode-choose-mode "muse-mode" "\ -Turn the proper Emacs Muse related mode on for this file. - -\(fn)" nil nil) - -(autoload 'muse-insert-list-item "muse-mode" "\ -Insert a list item at the current point, taking into account -your current list type and indentation level. - -\(fn)" t nil) - -(autoload 'muse-increase-list-item-indentation "muse-mode" "\ -Increase the indentation of the current list item. - -\(fn)" t nil) - -(autoload 'muse-decrease-list-item-indentation "muse-mode" "\ -Decrease the indentation of the current list item. - -\(fn)" t nil) - -(autoload 'muse-insert-relative-link-to-file "muse-mode" "\ -Insert a relative link to a file, with optional description, at point. - -\(fn)" t nil) - -(autoload 'muse-edit-link-at-point "muse-mode" "\ -Edit the current link. -Do not rename the page originally referred to. - -\(fn)" t nil) - -(autoload 'muse-browse-result "muse-mode" "\ -Visit the current page's published result. - -\(fn STYLE &optional OTHER-WINDOW)" t nil) - -(autoload 'muse-follow-name-at-point "muse-mode" "\ -Visit the link at point. - -\(fn &optional OTHER-WINDOW)" t nil) - -(autoload 'muse-follow-name-at-point-other-window "muse-mode" "\ -Visit the link at point in other window. - -\(fn)" t nil) - -(autoload 'muse-next-reference "muse-mode" "\ -Move forward to next Muse link or URL, cycling if necessary. - -\(fn)" t nil) - -(autoload 'muse-previous-reference "muse-mode" "\ -Move backward to the next Muse link or URL, cycling if necessary. -In case of Emacs x <= 21 and ignoring of intangible properties (see -`muse-mode-intangible-links'). - -This function is not entirely accurate, but it's close enough. - -\(fn)" t nil) - -(autoload 'muse-what-changed "muse-mode" "\ -Show the unsaved changes that have been made to the current file. - -\(fn)" t nil) - -(autoload 'muse-search-with-command "muse-mode" "\ -Search for the given TEXT string in the project directories -using the specified command. - -\(fn TEXT)" t nil) - -(autoload 'muse-search "muse-mode" "\ -Search for the given TEXT using the default grep command. - -\(fn)" t nil) - -(autoload 'muse-find-backlinks "muse-mode" "\ -Grep for the current pagename in all the project directories. - -\(fn)" t nil) - -(autoload 'muse-index "muse-mode" "\ -Display an index of all known Muse pages. - -\(fn)" t nil) - -(autoload 'muse-insert-tag "muse-mode" "\ -Insert a tag interactively with a blank line after it. - -\(fn TAG)" t nil) - -(autoload 'muse-list-edit-minor-mode "muse-mode" "\ -This is a global minor mode for editing files with lists. -It is meant to be used with other major modes, and not with Muse mode. - -Interactively, with no prefix argument, toggle the mode. -With universal prefix ARG turn mode on. -With zero or negative ARG turn mode off. - -This minor mode provides the Muse keybindings for editing lists, -and support for filling lists properly. - -It recognizes not only Muse-style lists, which use the \"-\" -character or numbers, but also lists that use asterisks or plus -signs. This should make the minor mode generally useful. - -Definition lists and footnotes are also recognized. - -Note that list items may omit leading spaces, for compatibility -with modes that set `left-margin', such as -`debian-changelog-mode'. - -\\{muse-list-edit-minor-mode-map} - -\(fn &optional ARG)" t nil) - -;;;*** - -;;;### (autoloads (muse-project-publish muse-project-publish-this-file -;;;;;; muse-project-find-file) "muse-project" "muse-project.el" -;;;;;; (19301 53195)) -;;; Generated autoloads from muse-project.el - -(autoload 'muse-project-find-file "muse-project" "\ -Open the Muse page given by NAME in PROJECT. -If COMMAND is non-nil, it is the function used to visit the file. -If DIRECTORY is non-nil, it is the directory in which the page -will be created if it does not already exist. Otherwise, the -first directory within the project's fileset is used. - -\(fn NAME PROJECT &optional COMMAND DIRECTORY)" t nil) - -(autoload 'muse-project-publish-this-file "muse-project" "\ -Publish the currently-visited file according to `muse-project-alist', -prompting if more than one style applies. - -If FORCE is given, publish the file even if it is up-to-date. - -If STYLE is given, use that publishing style rather than -prompting for one. - -\(fn &optional FORCE STYLE)" t nil) - -(autoload 'muse-project-publish "muse-project" "\ -Publish the pages of PROJECT that need publishing. - -\(fn PROJECT &optional FORCE)" t nil) - -;;;*** - -;;;### (autoloads (muse-browse-url) "muse-protocols" "muse-protocols.el" -;;;;;; (19301 53239)) -;;; Generated autoloads from muse-protocols.el - -(autoload 'muse-browse-url "muse-protocols" "\ -Handle URL with the function specified in `muse-url-protocols'. -If OTHER-WINDOW is non-nil, open in a different window. - -\(fn URL &optional OTHER-WINDOW)" t nil) - -;;;*** - -;;;### (autoloads (muse-publish-this-file muse-publish-file muse-publish-region) -;;;;;; "muse-publish" "muse-publish.el" (19301 53119)) -;;; Generated autoloads from muse-publish.el - -(autoload 'muse-publish-region "muse-publish" "\ -Apply the given STYLE's markup rules to the given region. -The result is placed in a new buffer that includes TITLE in its name. - -\(fn BEG END &optional TITLE STYLE)" t nil) - -(autoload 'muse-publish-file "muse-publish" "\ -Publish the given FILE in a particular STYLE to OUTPUT-DIR. -If the argument FORCE is nil, each file is only published if it is -newer than the published version. If the argument FORCE is non-nil, -the file is published no matter what. - -\(fn FILE STYLE &optional OUTPUT-DIR FORCE)" t nil) - -(autoload 'muse-publish-this-file "muse-publish" "\ -Publish the currently-visited file. -Prompt for both the STYLE and OUTPUT-DIR if they are not -supplied. - -\(fn STYLE OUTPUT-DIR &optional FORCE)" t nil) - -;;;*** - -;;;### (autoloads nil nil ("../contrib/cgi.el" "../contrib/htmlize-hack.el" -;;;;;; "../contrib/httpd.el" "../experimental/muse-cite.el" "../experimental/muse-mathml.el" -;;;;;; "../experimental/muse-protocol-iw.el" "../experimental/muse-split.el" -;;;;;; "muse-backlink.el" "muse-book.el" "muse-context.el" "muse-docbook.el" -;;;;;; "muse-groff.el" "muse-html.el" "muse-http.el" "muse-ikiwiki.el" -;;;;;; "muse-import-xml.el" "muse-ipc.el" "muse-journal.el" "muse-latex.el" -;;;;;; "muse-latex2png.el" "muse-poem.el" "muse-regexps.el" "muse-texinfo.el" -;;;;;; "muse-wiki.el" "muse-xml-common.el" "muse-xml.el") (19301 -;;;;;; 55001 866391)) - -;;;*** - -;;;### (autoloads (muse-blosxom-new-entry) "muse-blosxom" "muse-blosxom.el" -;;;;;; (19301 53232)) -;;; Generated autoloads from muse-blosxom.el - -(autoload 'muse-blosxom-new-entry "muse-blosxom" "\ -Start a new blog entry with given CATEGORY. -The filename of the blog entry is derived from TITLE. -The page will be initialized with the current date and TITLE. - -\(fn CATEGORY TITLE)" t nil) - -;;;*** - -(provide 'muse-autoloads) -;;; muse-autoloads.el ends here -;; -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; End: - diff --git a/emacs.d/elisp/muse/muse-backlink.el b/emacs.d/elisp/muse/muse-backlink.el deleted file mode 100644 index bc21ddd..0000000 --- a/emacs.d/elisp/muse/muse-backlink.el +++ /dev/null @@ -1,327 +0,0 @@ -;;; muse-backlink.el --- backlinks for Muse - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Jim Ottaway <j.ottaway@lse.ac.uk> -;; Keywords: - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Hierarchical backlink insertion into new muse pages. -;; -;; To add: -;; -;; (require 'muse-backlink) -;; (muse-backlink-install) -;; -;; To control what gets backlinked, modify -;; `muse-backlink-exclude-backlink-regexp' and -;; `muse-backlink-exclude-backlink-parent-regexp'. -;; -;; To stop backlinking temporarily: -;; (setq muse-backlink-create-backlinks nil) -;; -;; To remove the backlink functionality completely: -;; -;; (muse-backlink-remove) - -;;; Contributors: - -;;; Code: - -(require 'muse) -(require 'muse-project) - -(eval-when-compile (require 'muse-mode)) - -(eval-and-compile - (if (< emacs-major-version 22) - (progn - ;; Swiped from Emacs 22.0.50.4 - (defvar muse-backlink-split-string-default-separators "[ \f\t\n\r\v]+" - "The default value of separators for `split-string'. - -A regexp matching strings of whitespace. May be locale-dependent -\(as yet unimplemented). Should not match non-breaking spaces. - -Warning: binding this to a different value and using it as default is -likely to have undesired semantics.") - - (defun muse-backlink-split-string (string &optional separators omit-nulls) - "Split STRING into substrings bounded by matches for SEPARATORS. - -The beginning and end of STRING, and each match for SEPARATORS, are -splitting points. The substrings matching SEPARATORS are removed, and -the substrings between the splitting points are collected as a list, -which is returned. - -If SEPARATORS is non-nil, it should be a regular expression matching text -which separates, but is not part of, the substrings. If nil it defaults to -`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and -OMIT-NULLS is forced to t. - -If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so -that for the default value of SEPARATORS leading and trailing whitespace -are effectively trimmed). If nil, all zero-length substrings are retained, -which correctly parses CSV format, for example. - -Note that the effect of `(split-string STRING)' is the same as -`(split-string STRING split-string-default-separators t)'). In the rare -case that you wish to retain zero-length substrings when splitting on -whitespace, use `(split-string STRING split-string-default-separators)'. - -Modifies the match data; use `save-match-data' if necessary." - (let ((keep-nulls (not (if separators omit-nulls t))) - (rexp (or separators muse-backlink-split-string-default-separators)) - (start 0) - notfirst - (list nil)) - (while (and (string-match rexp string - (if (and notfirst - (= start (match-beginning 0)) - (< start (length string))) - (1+ start) start)) - (< start (length string))) - (setq notfirst t) - (if (or keep-nulls (< start (match-beginning 0))) - (setq list - (cons (substring string start (match-beginning 0)) - list))) - (setq start (match-end 0))) - (if (or keep-nulls (< start (length string))) - (setq list - (cons (substring string start) - list))) - (nreverse list)))) - (defalias 'muse-backlink-split-string 'split-string))) - -(defgroup muse-backlink nil - "Hierarchical backlinking for Muse." - :group 'muse) - -(defcustom muse-backlink-create-backlinks t - "When non-nil, create hierarchical backlinks in new Muse pages. -For control over which pages will receive backlinks, see -`muse-backlink-exclude-backlink-parent-regexp' and -`muse-backlink-exclude-backlink-regexp'." - :type 'boolean - :group 'muse-backlink) - -(defcustom muse-backlink-avoid-bad-links t - "When non-nil, avoid bad links when backlinking." - :type 'boolean - :group 'muse-backlink) - -;; The default for exclusion stops backlinks from being added to and -;; from planner day pages. -(defcustom muse-backlink-exclude-backlink-parent-regexp - "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$" - "Regular expression matching pages whose children should not have backlinks." - :type 'regexp - :group 'muse-backlink) - -(defcustom muse-backlink-exclude-backlink-regexp - "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$" - "Regular expression matching pages that should not have backlinks." - :type 'regexp - :group 'muse-backlink) - -(defcustom muse-backlink-separator "/" - "String that separates backlinks. -Should be something that will not appear as a substring in an explicit -link that has no description." - :type 'string - :group 'muse-backlink) - -(defcustom muse-backlink-before-string "backlinks: " - "String to come before the backlink list." - :type 'string - :group 'muse-backlink) - -(defcustom muse-backlink-after-string "" - "String to come after the backlink list." - :type 'string - :group 'muse-backlink) - -(defcustom muse-backlink-separator "/" - "String that separates backlinks. -Should be something that will not appear as a substring in an explicit -link that has no description." - :type 'string - :group 'muse-backlink) - -(defcustom muse-backlink-regexp - (concat "^" - (regexp-quote muse-backlink-before-string) - "\\(" - (regexp-quote muse-backlink-separator) - ".+\\)" - (regexp-quote muse-backlink-after-string)) - ;; Really, I want something like this, but I can't make it work: - ;; (concat "^\\(" - ;; (regexp-quote muse-backlink-separator) - ;; "\\(?:" - ;; muse-explicit-link-regexp - ;; "\\)\\)+") - "Regular expression to match backlinks in a buffer. -Match 1 is the list of backlinks without `muse-backlink-before-string' -and `muse-backlink-after-string'." - :type 'regexp - :group 'muse-backlink) - -(defun muse-backlink-goto-insertion-point () - "Find the right place to add backlinks." - (goto-char (point-min)) - (when (looking-at "\\(?:^#.+[ \t]*\n\\)+") - (goto-char (match-end 0)))) - -(defun muse-backlink-get-current () - "Return a list of backlinks in the current buffer." - (save-excursion - (goto-char (point-min)) - (when (re-search-forward muse-backlink-regexp nil t) - (muse-backlink-split-string - (match-string 1) - (regexp-quote muse-backlink-separator) t)))) - -(defun muse-backlink-format-link-list (links) - "Format the list of LINKS as backlinks." - (concat muse-backlink-separator - (mapconcat #'identity links muse-backlink-separator))) - -(defun muse-backlink-insert-links (links) - "Insert backlinks to LINKS into the current page. -LINKS is a list of links ordered by ancestry, with the parent as the -last element." - (muse-backlink-goto-insertion-point) - (insert muse-backlink-before-string - (muse-backlink-format-link-list links) - muse-backlink-after-string - ;; Could have this in the after string, but they might get - ;; deleted. - "\n\n")) - -(defun muse-backlink-unsaved-page-p (page project) - "Return non-nil if PAGE is in PROJECT but has not been saved." - (member - page - (mapcar - #'(lambda (b) - (with-current-buffer b - (and (derived-mode-p 'muse-mode) - (equal muse-current-project project) - (not (muse-project-page-file - (muse-page-name) - muse-current-project)) - (muse-page-name)))) - (buffer-list)))) - -(defvar muse-backlink-links nil - "Internal variable. -The links to insert in the forthcomingly visited muse page.") - -(defvar muse-backlink-pending nil - "Internal variable.") - -(defvar muse-backlink-parent-buffer nil - "Internal variable. -The parent buffer of the forthcomingly visited muse page.") - - -;;; Attach hook to the derived mode hook, to avoid problems such as -;;; planner-prepare-file thinking that the buffer needs no template. -(defun muse-backlink-get-mode-hook () - (derived-mode-hook-name major-mode)) - -(defun muse-backlink-insert-hook-func () - "Insert backlinks into the current buffer and clean up." - (when (and muse-backlink-links - muse-backlink-pending - (string= (car muse-backlink-links) (muse-page-name))) - (muse-backlink-insert-links (cdr muse-backlink-links)) - (when muse-backlink-avoid-bad-links - (save-buffer) - (when muse-backlink-parent-buffer - (with-current-buffer muse-backlink-parent-buffer - (font-lock-fontify-buffer)))) - (setq muse-backlink-links nil - muse-backlink-parent-buffer nil - muse-backlink-pending nil) - (remove-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func))) - -(defun muse-backlink-handle-link (link) - "When appropriate, arrange for backlinks on visiting LINK." - (when (and muse-backlink-create-backlinks - (not muse-backlink-pending) - (memq this-command - '(muse-follow-name-at-point muse-follow-name-at-mouse)) - (not muse-publishing-p) - (not (and (boundp 'muse-colors-fontifying-p) - muse-colors-fontifying-p))) - (require 'muse-mode) - (setq - muse-backlink-links - (save-match-data - (let* ((orig-link (or link (match-string 1))) - (link (if (string-match "#" orig-link) - (substring orig-link 0 (match-beginning 0)) - orig-link))) - (unless - (or (not muse-current-project) - (string-match muse-url-regexp orig-link) - (string-match muse-image-regexp orig-link) - (and (boundp 'muse-wiki-interwiki-regexp) - (string-match muse-wiki-interwiki-regexp - orig-link)) - ;; Don't add a backlink if the page already - ;; exists, whether it has been saved or not. - (or (muse-project-page-file link muse-current-project) - (muse-backlink-unsaved-page-p link muse-current-project)) - (string-match muse-backlink-exclude-backlink-parent-regexp - (muse-page-name)) - (string-match muse-backlink-exclude-backlink-regexp link)) - ;; todo: Hmm. This will only work if the child page is the - ;; same mode as the parent page. - (add-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func) - (setq muse-backlink-pending t) - (when muse-backlink-avoid-bad-links - (setq muse-backlink-parent-buffer (current-buffer)) - (unless (muse-project-page-file - (muse-page-name) muse-current-project) - ;; It must be modified... - (save-buffer))) - (cons link - (append (muse-backlink-get-current) - (list (muse-make-link (muse-page-name)))))))))) - ;; Make sure we always return nil - nil) - -(defun muse-backlink-install () - "Add backlinking functionality to muse-mode." - (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link)) - -(defun muse-backlink-remove () - "Remove backlinking functionality from muse-mode." - (setq muse-explicit-link-functions - (delq #'muse-backlink-handle-link muse-explicit-link-functions))) - -(provide 'muse-backlink) -;;; muse-backlink.el ends here diff --git a/emacs.d/elisp/muse/muse-blosxom.el b/emacs.d/elisp/muse/muse-blosxom.el deleted file mode 100644 index 78038d7..0000000 --- a/emacs.d/elisp/muse/muse-blosxom.el +++ /dev/null @@ -1,306 +0,0 @@ -;;; muse-blosxom.el --- publish a document tree for serving by (py)Blosxom - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Michael Olson <mwolson@gnu.org> -;; Date: Wed, 23 March 2005 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; The Blosxom publishing style publishes a tree of categorised files -;; to a mirrored tree of stories to be served by blosxom.cgi or -;; pyblosxom.cgi. -;; -;; Serving entries with (py)blosxom -;; -------------------------------- -;; -;; Each Blosxom file must include `#date yyyy-mm-dd', or optionally -;; the longer `#date yyyy-mm-dd-hh-mm', a title (using the `#title' -;; directive) plus whatever normal content is desired. -;; -;; The date directive is not used directly by (py)blosxom or this -;; program. You need to find two additional items to make use of this -;; feature. -;; -;; 1. A script to gather date directives from the entire blog tree -;; into a single file. The file must associate a blog entry with -;; a date. -;; -;; 2. A plugin for (py)blosxom that reads this file. -;; -;; These 2 things are provided for pyblosxom in the contrib/pyblosxom -;; subdirectory. `getstamps.py' provides the 1st service, while -;; `hardcodedates.py' provides the second service. Eventually it is -;; hoped that a blosxom plugin and script will be found/written. -;; -;; Alternately, the pyblosxom metadate plugin may be used. On the -;; plus side, there is no need to run a script to gather the date. On -;; the downside, each entry is read twice rather than once when the -;; page is rendered. Set the value of muse-blosxom-use-metadate to -;; non-nil to enable adding a #postdate directive to all published -;; files. You can do this by: -;; -;; M-x customize-variable RET muse-blosxom-use-metadate RET -;; -;; With the metadate plugin installed in pyblosxom, the date set in -;; this directive will be used instead of the file's modification -;; time. The plugin is included with Muse at -;; contrib/pyblosxom/metadate.py. -;; -;; Generating a Muse project entry -;; ------------------------------- -;; -;; Muse-blosxom has some helper functions to make specifying -;; muse-blosxom projects a lot easier. An example follows. -;; -;; (setq muse-project-alist -;; `(("blog" -;; (,@(muse-project-alist-dirs "~/path/to/blog-entries") -;; :default "index") -;; ,@(muse-project-alist-styles "~/path/to/blog-entries" -;; "~/public_html/blog" -;; "blosxom-xhtml") -;; ))) -;; -;; Note that we need a backtick instead of a single quote on the -;; second line of this example. -;; -;; Creating new blog entries -;; ------------------------- -;; -;; There is a function called `muse-blosxom-new-entry' that will -;; automate the process of making a new blog entry. To make use of -;; it, do the following. -;; -;; - Customize `muse-blosxom-base-directory' to the location that -;; your blog entries are stored. -;; -;; - Assign the `muse-blosxom-new-entry' function to a key sequence. -;; I use the following code to assign this function to `C-c p l'. -;; -;; (global-set-key "\C-cpl" 'muse-blosxom-new-entry) -;; -;; - You should create your directory structure ahead of time under -;; your base directory. These directories, which correspond with -;; category names, may be nested. -;; -;; - When you enter this key sequence, you will be prompted for the -;; category of your entry and its title. Upon entering this -;; information, a new file will be created that corresponds with -;; the title, but in lowercase letters and having special -;; characters converted to underscores. The title and date -;; directives will be inserted automatically. -;; -;; Using tags -;; ---------- -;; -;; If you wish to keep all of your blog entries in one directory and -;; use tags to classify your entries, set `muse-blosxom-use-tags' to -;; non-nil. -;; -;; For this to work, you will need to be using the PyBlosxom plugin at -;; http://pyblosxom.sourceforge.net/blog/registry/meta/Tags. - -;;; Contributors: - -;; Gary Vaughan (gary AT gnu DOT org) is the original author of -;; `emacs-wiki-blosxom.el', which is the ancestor of this file. - -;; Brad Collins (brad AT chenla DOT org) ported this file to Muse. - -;; Björn Lindström (bkhl AT elektrubadur DOT se) made many valuable -;; suggestions. - -;; Sasha Kovar (sasha AT arcocene DOT org) fixed -;; muse-blosxom-new-entry when using tags and also implemented support -;; for the #postdate directive. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Blosxom Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-project) -(require 'muse-publish) -(require 'muse-html) - -(defgroup muse-blosxom nil - "Options controlling the behavior of Muse Blosxom publishing. -See `muse-blosxom' for more information." - :group 'muse-publish) - -(defcustom muse-blosxom-extension ".txt" - "Default file extension for publishing Blosxom files." - :type 'string - :group 'muse-blosxom) - -(defcustom muse-blosxom-header - "<lisp>(concat (muse-publishing-directive \"title\") \"\\n\" - (when muse-blosxom-use-metadate - (let ((date (muse-publishing-directive \"date\"))) - (when date (concat \"#postdate \" - (muse-blosxom-format-date date) \"\\n\")))) - (when muse-blosxom-use-tags - (let ((tags (muse-publishing-directive \"tags\"))) - (when tags (concat \"#tags \" tags \"\\n\")))))</lisp>" - "Header used for publishing Blosxom files. This may be text or a filename." - :type 'string - :group 'muse-blosxom) - -(defcustom muse-blosxom-footer "" - "Footer used for publishing Blosxom files. This may be text or a filename." - :type 'string - :group 'muse-blosxom) - -(defcustom muse-blosxom-base-directory "~/Blog" - "Base directory of blog entries. -This is the top-level directory where your Muse blog entries may be found." - :type 'directory - :group 'muse-blosxom) - -(defcustom muse-blosxom-use-tags nil - "Determine whether or not to enable use of the #tags directive. - -If you wish to keep all of your blog entries in one directory and -use tags to classify your entries, set `muse-blosxom-use-tags' to -non-nil. - -For this to work, you will need to be using the PyBlosxom plugin -at http://pyblosxom.sourceforge.net/blog/registry/meta/Tags." - :type 'boolean - :group 'muse-blosxom) - -(defcustom muse-blosxom-use-metadate nil - "Determine whether or not to use the #postdate directive. - -If non-nil, published entries include the original date (as specified -in the muse #date line) which can be read by the metadate PyBlosxom -plugin. - -For this to work, you will need to be using the PyBlosxom plugin -at http://pyblosxom.sourceforge.net/blog/registry/date/metadate." - :type 'boolean - :group 'muse-blosxom) - -;; Maintain (published-file . date) alist, which will later be written -;; to a timestamps file; not implemented yet. - -(defvar muse-blosxom-page-date-alist nil) - -(defun muse-blosxom-update-page-date-alist () - "Add a date entry to `muse-blosxom-page-date-alist' for this page." - (when muse-publishing-current-file - ;; Make current file be relative to base directory - (let ((rel-file - (concat - (file-name-as-directory - (or (muse-publishing-directive "category") - (file-relative-name - (file-name-directory - (expand-file-name muse-publishing-current-file)) - (file-truename muse-blosxom-base-directory)))) - (file-name-nondirectory muse-publishing-current-file)))) - ;; Strip the file extension - (when muse-ignored-extensions-regexp - (setq rel-file (save-match-data - (and (string-match muse-ignored-extensions-regexp - rel-file) - (replace-match "" t t rel-file))))) - ;; Add to page-date alist - (add-to-list - 'muse-blosxom-page-date-alist - `(,rel-file . ,(muse-publishing-directive "date")))))) - -;; Enter a new blog entry - -(defun muse-blosxom-title-to-file (title) - "Derive a file name from the given TITLE. - -Feel free to overwrite this if you have a different concept of what -should be allowed in a filename." - (muse-replace-regexp-in-string (concat "[^-." muse-regexp-alnum "]") - "_" (downcase title))) - -(defun muse-blosxom-format-date (date) - "Convert a date string to PyBlosxom metadate plugin format." - (apply #'format "%s-%s-%s %s:%s" (split-string date "-"))) - -;;;###autoload -(defun muse-blosxom-new-entry (category title) - "Start a new blog entry with given CATEGORY. -The filename of the blog entry is derived from TITLE. -The page will be initialized with the current date and TITLE." - (interactive - (list - (if muse-blosxom-use-tags - (let ((tag "foo") - (tags nil)) - (while (progn (setq tag (read-string "Tag (RET to continue): ")) - (not (string= tag ""))) - (add-to-list 'tags tag t)) - tags) - (funcall muse-completing-read-function - "Category: " - (mapcar 'list (muse-project-recurse-directory - muse-blosxom-base-directory)))) - (read-string "Title: "))) - (let ((file (muse-blosxom-title-to-file title))) - (muse-project-find-file - file "blosxom" nil - (if muse-blosxom-use-tags - (directory-file-name muse-blosxom-base-directory) - (concat (directory-file-name muse-blosxom-base-directory) - "/" category)))) - (goto-char (point-min)) - (insert "#date " (format-time-string "%Y-%m-%d-%H-%M") - "\n#title " title) - (if muse-blosxom-use-tags - (if (> (length category) 0) - (insert (concat "\n#tags " (mapconcat #'identity category ",")))) - (unless (string= category "") - (insert (concat "\n#category " category)))) - (insert "\n\n") - (forward-line 2)) - -;;; Register the Muse Blosxom Publisher - -(muse-derive-style "blosxom-html" "html" - :suffix 'muse-blosxom-extension - :link-suffix 'muse-html-extension - :header 'muse-blosxom-header - :footer 'muse-blosxom-footer - :after 'muse-blosxom-update-page-date-alist - :browser 'find-file) - -(muse-derive-style "blosxom-xhtml" "xhtml" - :suffix 'muse-blosxom-extension - :link-suffix 'muse-xhtml-extension - :header 'muse-blosxom-header - :footer 'muse-blosxom-footer - :after 'muse-blosxom-update-page-date-alist - :browser 'find-file) - -(provide 'muse-blosxom) - -;;; muse-blosxom.el ends here diff --git a/emacs.d/elisp/muse/muse-book.el b/emacs.d/elisp/muse/muse-book.el deleted file mode 100644 index 213a64e..0000000 --- a/emacs.d/elisp/muse/muse-book.el +++ /dev/null @@ -1,284 +0,0 @@ -;;; muse-book.el --- publish entries into a compilation - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Book Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-project) -(require 'muse-latex) -(require 'muse-regexps) - -(defgroup muse-book nil - "Module for publishing a series of Muse pages as a complete book. -Each page will become a separate chapter in the book, unless the -style keyword :nochapters is used, in which case they are all run -together as if one giant chapter." - :group 'muse-publish) - -(defcustom muse-book-before-publish-hook nil - "A hook run in the book buffer before it is marked up." - :type 'hook - :group 'muse-book) - -(defcustom muse-book-after-publish-hook nil - "A hook run in the book buffer after it is marked up." - :type 'hook - :group 'muse-book) - -(defcustom muse-book-latex-header - "\\documentclass{book} - -\\usepackage[english]{babel} -\\usepackage[latin1]{inputenc} -\\usepackage[T1]{fontenc} - -\\begin{document} - -\\title{<lisp>(muse-publishing-directive \"title\")</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\maketitle - -\\tableofcontents\n" - "Header used for publishing books to LaTeX. This may be text or a filename." - :type 'string - :group 'muse-book) - -(defcustom muse-book-latex-footer - "<lisp>(muse-latex-bibliography)</lisp> -\\end{document}" - "Footer used for publishing books to LaTeX. This may be text or a filename." - :type 'string - :group 'muse-book) - -(defun muse-book-publish-chapter (title entry style &optional nochapters) - "Publish the chapter TITLE for the file ENTRY using STYLE. -TITLE is a string, ENTRY is a cons of the form (PAGE-NAME . -FILE), and STYLE is a Muse style list. - -This routine does the same basic work as `muse-publish-markup-buffer', -but treating the page as if it were a single chapter within a book." - (let ((muse-publishing-directives (list (cons "title" title))) - (muse-publishing-current-file (cdr entry)) - (beg (point)) end) - (muse-insert-file-contents (cdr entry)) - (setq end (copy-marker (point-max) t)) - (muse-publish-markup-region beg end (car entry) style) - (goto-char beg) - (unless (or nochapters - (muse-style-element :nochapters style)) - (insert "\n") - (muse-insert-markup (muse-markup-text 'chapter)) - (insert (let ((chap (muse-publishing-directive "title"))) - (if (string= chap title) - (car entry) - chap))) - (muse-insert-markup (muse-markup-text 'chapter-end)) - (insert "\n\n")) - (save-restriction - (narrow-to-region beg end) - (muse-publish-markup (or title "") - '((100 "<\\(lisp\\)>" 0 - muse-publish-markup-tag))) - (muse-style-run-hooks :after style)) - (goto-char end))) - -(defun muse-book-publish-p (project target) - "Determine whether the book in PROJECT is out-of-date." - (let ((pats (cadr project))) - (catch 'publish - (while pats - (if (symbolp (car pats)) - (if (eq :book-end (car pats)) - (throw 'publish nil) - ;; skip past symbol-value pair - (setq pats (cddr pats))) - (dolist (entry (muse-project-file-entries (car pats))) - (when (and (not (muse-project-private-p (cdr entry))) - (file-newer-than-file-p (cdr entry) target)) - (throw 'publish t))) - (setq pats (cdr pats))))))) - -(defun muse-book-get-directives (file) - "Interpret any publishing directives contained in FILE. -This is meant to be called in a temp buffer that will later be -used for publishing." - (save-restriction - (narrow-to-region (point) (point)) - (unwind-protect - (progn - (muse-insert-file-contents file) - (muse-publish-markup - "attributes" - `(;; Remove leading and trailing whitespace from the file - (100 "\\(\\`\n+\\|\n+\\'\\)" 0 "") - ;; Remove trailing whitespace from all lines - (200 ,(concat "[" muse-regexp-blank "]+$") 0 "") - ;; Handle any leading #directives - (300 "\\`#\\([a-zA-Z-]+\\)\\s-+\\(.+\\)\n+" - 0 muse-publish-markup-directive)))) - (delete-region (point-min) (point-max))))) - -(defun muse-book-publish-project - (project book title style &optional output-dir force) - "Publish PROJECT under the name BOOK with the given TITLE and STYLE. -BOOK should be a page name, i.e., letting the style determine the -prefix and/or suffix. The book is published to OUTPUT-DIR. If FORCE -is nil, the book is only published if at least one of its component -pages has changed since it was last published." - (interactive - (let ((project (muse-read-project "Publish project as book: " nil t))) - (append (list project - (read-string "Basename of book (without extension): ") - (read-string "Title of book: ")) - (muse-publish-get-info)))) - (setq project (muse-project project)) - (let ((muse-current-project project)) - ;; See if any of the project's files need saving first - (muse-project-save-buffers project) - ;; Publish the book - (muse-book-publish book style output-dir force title))) - -(defun muse-book-publish (file style &optional output-dir force title) - "Publish FILE as a book with the given TITLE and STYLE. -The book is published to OUTPUT-DIR. If FORCE is nil, the book -is only published if at least one of its component pages has -changed since it was last published." - ;; Cleanup some of the arguments - (let ((style-name style)) - (setq style (muse-style style)) - (unless style - (error "There is no style '%s' defined" style-name))) - ;; Publish each page in the project as a chapter in one large book - (let* ((output-path (muse-publish-output-file file output-dir style)) - (output-suffix (muse-style-element :osuffix style)) - (target output-path) - (project muse-current-project) - (published nil)) - (when output-suffix - (setq target (concat (muse-path-sans-extension target) - output-suffix))) - ;; Unless force is non-nil, determine if the book needs publishing - (if (and (not force) - (not (muse-book-publish-p project target))) - (message "The book \"%s\" is up-to-date." file) - ;; Create the book from all its component parts - (muse-with-temp-buffer - (let ((style-final (muse-style-element :final style t)) - (style-header (muse-style-element :header style)) - (style-footer (muse-style-element :footer style)) - (muse-publishing-current-style style) - (muse-publishing-directives - (list (cons "title" (or title (muse-page-name file))) - (cons "date" (format-time-string "%B %e, %Y")))) - (muse-publishing-p t) - (muse-current-project project) - (pats (cadr project)) - (nochapters nil)) - (run-hooks 'muse-before-book-publish-hook) - (let ((style-final style-final) - (style-header style-header) - (style-footer style-footer)) - (unless title - (muse-book-get-directives file) - (setq title (muse-publishing-directive "title"))) - (while pats - (if (symbolp (car pats)) - (cond - ((eq :book-part (car pats)) - (insert "\n") - (muse-insert-markup (muse-markup-text 'part)) - (insert (cadr pats)) - (muse-insert-markup (muse-markup-text 'part-end)) - (insert "\n") - (setq pats (cddr pats))) - ((eq :book-chapter (car pats)) - (insert "\n") - (muse-insert-markup (muse-markup-text 'chapter)) - (insert (cadr pats)) - (muse-insert-markup (muse-markup-text 'chapter-end)) - (insert "\n") - (setq pats (cddr pats))) - ((eq :nochapters (car pats)) - (setq nochapters t - pats (cddr pats))) - ((eq :book-style (car pats)) - (setq style (muse-style (cadr pats))) - (setq style-final (muse-style-element :final style t) - style-header (muse-style-element :header style) - style-footer (muse-style-element :footer style) - muse-publishing-current-style style) - (setq pats (cddr pats))) - ((eq :book-funcall (car pats)) - (funcall (cadr pats)) - (setq pats (cddr pats))) - ((eq :book-end (car pats)) - (setq pats nil)) - (t - (setq pats (cddr pats)))) - (let ((entries (muse-project-file-entries (car pats)))) - (while (and entries (car entries) (caar entries)) - (unless (muse-project-private-p (cdar entries)) - (muse-book-publish-chapter title (car entries) - style nochapters) - (setq published t)) - (setq entries (cdr entries)))) - (setq pats (cdr pats))))) - (goto-char (point-min)) - (if style-header (muse-insert-file-or-string style-header file)) - (goto-char (point-max)) - (if style-footer (muse-insert-file-or-string style-footer file)) - (run-hooks 'muse-after-book-publish-hook) - (if (muse-write-file output-path) - (if style-final - (funcall style-final file output-path target)) - (setq published nil))))) - (if published - (message "The book \"%s\" has been published." file)) - published)) - -;;; Register the Muse BOOK Publishers - -(muse-derive-style "book-latex" "latex" - :header 'muse-book-latex-header - :footer 'muse-book-latex-footer - :publish 'muse-book-publish) - -(muse-derive-style "book-pdf" "pdf" - :header 'muse-book-latex-header - :footer 'muse-book-latex-footer - :publish 'muse-book-publish) - -(provide 'muse-book) - -;;; muse-book.el ends here diff --git a/emacs.d/elisp/muse/muse-colors.el b/emacs.d/elisp/muse/muse-colors.el deleted file mode 100644 index fb76ac5..0000000 --- a/emacs.d/elisp/muse/muse-colors.el +++ /dev/null @@ -1,1022 +0,0 @@ -;;; muse-colors.el --- coloring and highlighting used by Muse - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: John Wiegley (johnw AT gnu DOT org) -;; Keywords: hypermedia -;; Date: Thu 11-Mar-2004 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where -;; headings were being given the wrong face, contributing a patch to -;; fix this. - -;; Sergey Vlasov (vsu AT altlinux DOT ru) fixed an issue with coloring -;; links that are in consecutive lines. - -;; Jim Ottaway ported the <lisp> tag from emacs-wiki. - -;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the -;; viewing of inline images. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Emacs Muse Highlighting -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-mode) -(require 'muse-regexps) -(require 'font-lock) - -(defgroup muse-colors nil - "Options controlling the behavior of Emacs Muse highlighting. -See `muse-colors-buffer' for more information." - :group 'muse-mode) - -(defcustom muse-colors-autogen-headings t - "Specify whether the heading faces should be auto-generated. -The default is to scale them. - -Choosing 'outline will copy the colors from the outline-mode -headings. - -If you want to customize each of the headings individually, set -this to nil." - :type '(choice (const :tag "Default (scaled) headings" t) - (const :tag "Use outline-mode headings" outline) - (const :tag "Don't touch the headings" nil)) - :group 'muse-colors) - -(defcustom muse-colors-evaluate-lisp-tags t - "Specify whether to evaluate the contents of <lisp> tags at -display time. If nil, don't evaluate them. If non-nil, evaluate -them. - -The actual contents of the buffer are not changed, only the -displayed text." - :type 'boolean - :group 'muse-colors) - -(defcustom muse-colors-inline-images t - "Specify whether to inline images inside the Emacs buffer. If -nil, don't inline them. If non-nil, an image link will be -replaced by the image. - -The actual contents of the buffer are not changed, only whether -an image is displayed." - :type 'boolean - :group 'muse-colors) - -(defcustom muse-colors-inline-image-method 'default-directory - "Determine how to locate inline images. -Setting this to 'default-directory uses the current directory of -the current Muse buffer. - -Setting this to a function calls that function with the filename -of the image to be inlined. The value that is returned will be -used as the filename of the image." - :type '(choice (const :tag "Current directory" default-directory) - (const :tag "Publishing directory" - muse-colors-use-publishing-directory) - (function :tag "Custom function")) - :group 'muse-colors) - -(defvar muse-colors-region-end nil - "Indicate the end of the region that is currently being font-locked.") -(make-variable-buffer-local 'muse-colors-region-end) - -;;;###autoload -(defun muse-colors-toggle-inline-images () - "Toggle display of inlined images on/off." - (interactive) - ;; toggle the custom setting - (if (not muse-colors-inline-images) - (setq muse-colors-inline-images t) - (setq muse-colors-inline-images nil)) - ;; reprocess the buffer - (muse-colors-buffer) - ;; display informative message - (if muse-colors-inline-images - (message "Images are now displayed inline") - (message "Images are now displayed as links"))) - -(defvar muse-colors-outline-faces-list - (if (facep 'outline-1) - '(outline-1 outline-2 outline-3 outline-4 outline-5) - ;; these are equivalent in coloring to the outline faces - '(font-lock-function-name-face - font-lock-variable-name-face - font-lock-keyword-face - font-lock-builtin-face - font-lock-comment-face)) - "Outline faces to use when assigning Muse header faces.") - -(defun muse-make-faces-default (&optional later) - "Generate the default face definitions for headers." - (dolist (num '(1 2 3 4 5)) - (let ((newsym (intern (concat "muse-header-" (int-to-string num)))) - (docstring (concat - "Muse header face. See " - "`muse-colors-autogen-headings' before changing it."))) - ;; put in the proper group and give documentation - (if later - (unless (featurep 'xemacs) - (muse-copy-face 'variable-pitch newsym) - (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num))) - :weight 'bold)) - (if (featurep 'xemacs) - (eval `(defface ,newsym - '((t (:size - ,(nth (1- num) - '("24pt" "18pt" "14pt" "12pt" "11pt")) - :bold t))) - ,docstring - :group 'muse-colors)) - (eval `(defface ,newsym - '((t (:height ,(1+ (* 0.1 (- 5 num))) - :inherit variable-pitch - :weight bold))) - ,docstring - :group 'muse-colors))))))) - -(progn (muse-make-faces-default)) - -(defun muse-make-faces (&optional frame) - "Generate face definitions for headers based the user's preferences." - (cond - ((not muse-colors-autogen-headings) - nil) - ((eq muse-colors-autogen-headings t) - (muse-make-faces-default t)) - (t - (dolist (num '(1 2 3 4 5)) - (let ((newsym (intern (concat "muse-header-" (int-to-string num))))) - ;; copy the desired face definition - (muse-copy-face (nth (1- num) muse-colors-outline-faces-list) - newsym)))))) - -;; after displaying the Emacs splash screen, the faces are wiped out, -;; so recover from that -(add-hook 'window-setup-hook #'muse-make-faces) -;; ditto for when a new frame is created -(when (boundp 'after-make-frame-functions) - (add-hook 'after-make-frame-functions #'muse-make-faces)) - -(defface muse-link - '((((class color) (background light)) - (:foreground "blue" :underline "blue" :bold t)) - (((class color) (background dark)) - (:foreground "cyan" :underline "cyan" :bold t)) - (t (:bold t))) - "Face for Muse cross-references." - :group 'muse-colors) - -(defface muse-bad-link - '((((class color) (background light)) - (:foreground "red" :underline "red" :bold t)) - (((class color) (background dark)) - (:foreground "coral" :underline "coral" :bold t)) - (t (:bold t))) - "Face for bad Muse cross-references." - :group 'muse-colors) - -(defface muse-verbatim - '((((class color) (background light)) - (:foreground "slate gray")) - (((class color) (background dark)) - (:foreground "gray"))) - "Face for verbatim text." - :group 'muse-colors) - -(defface muse-emphasis-1 - '((t (:italic t))) - "Face for italic emphasized text." - :group 'muse-colors) - -(defface muse-emphasis-2 - '((t (:bold t))) - "Face for bold emphasized text." - :group 'muse-colors) - -(defface muse-emphasis-3 - '((t (:bold t :italic t))) - "Face for bold italic emphasized text." - :group 'muse-colors) - -(muse-copy-face 'italic 'muse-emphasis-1) -(muse-copy-face 'bold 'muse-emphasis-2) -(muse-copy-face 'bold-italic 'muse-emphasis-3) - -(defcustom muse-colors-buffer-hook nil - "A hook run after a region is highlighted. -Each function receives three arguments: BEG END VERBOSE. -BEG and END mark the range being highlighted, and VERBOSE specifies -whether progress messages should be displayed to the user." - :type 'hook - :group 'muse-colors) - -(defvar muse-colors-highlighting-registry nil - "The rules for highlighting Muse and Muse-derived buffers. -This is automatically generated when using font-lock in Muse buffers. - -This an alist of major-mode symbols to `muse-colors-rule' objects.") - -(defun muse-colors-make-highlighting-struct () - (list nil nil nil)) -(defconst muse-colors-highlighting.regexp 0 - "Regexp matching each car of the markup of the current rule.") -(defconst muse-colors-highlighting.vector 1 - "Vector of all characters that are part of the markup of the current rule. -This is composed of the 2nd element of each markup entry.") -(defconst muse-colors-highlighting.remaining 2 - "Expressions for highlighting a buffer which have no corresponding -entry in the vector.") - -(defsubst muse-colors-highlighting-entry (mode) - "Return the highlighting rules for MODE." - (assq mode muse-colors-highlighting-registry)) - -(defun muse-colors-find-highlighting (mode) - "Return the highlighting rules to be used for MODE. -If MODE does not have highlighting rules, check its parent modes." - (let ((seen nil)) - (catch 'rules - (while (and mode (not (memq mode seen))) - (let ((entry (muse-colors-highlighting-entry mode))) - (when entry (throw 'rules (cdr entry)))) - (setq seen (cons mode seen)) - (setq mode (get mode 'derived-mode-parent))) - nil))) - -(defun muse-colors-define-highlighting (mode markup) - "Create or update the markup rules for MODE, using MARKUP. - -See `muse-colors-markup' for an explanation of the format that MARKUP -should take." - (unless (and (symbolp mode) mode (consp markup)) - (error "Invalid arguments")) - (let* ((highlighting-entry (muse-colors-highlighting-entry mode)) - (struct (cdr highlighting-entry)) - (regexp nil) - (vector nil) - (remaining nil)) - ;; Initialize struct - (if struct - (setq vector (nth muse-colors-highlighting.vector struct)) - (setq struct (muse-colors-make-highlighting-struct))) - ;; Initialize vector - (if vector - (let ((i 0)) - (while (< i 128) - (aset vector i nil) - (setq i (1+ i)))) - (setq vector (make-vector 128 nil))) - ;; Determine vector, regexp, remaining - (let ((regexps nil) - (rules nil)) - (dolist (rule markup) - (let ((value (cond ((symbolp (car rule)) - (symbol-value (car rule))) - ((stringp (car rule)) - (car rule)) - (t nil)))) - (when value - (setq rules (cons rule rules)) - (setq regexps (cons value regexps))))) - (setq regexps (nreverse regexps)) - (setq regexp (concat "\\(" (mapconcat #'identity regexps "\\|") "\\)")) - (dolist (rule rules) - (if (eq (nth 1 rule) t) - (setq remaining (cons (cons (nth 0 rule) (nth 2 rule)) - remaining)) - (aset vector (nth 1 rule) - (cons (cons (nth 0 rule) (nth 2 rule)) - (aref vector (nth 1 rule))))))) - ;; Update the struct - (setcar (nthcdr muse-colors-highlighting.regexp struct) regexp) - (setcar (nthcdr muse-colors-highlighting.vector struct) vector) - (setcar (nthcdr muse-colors-highlighting.remaining struct) remaining) - ;; Update entry for mode in muse-colors-highlighting-registry - (if highlighting-entry - (setcdr highlighting-entry struct) - (setq muse-colors-highlighting-registry - (cons (cons mode struct) - muse-colors-highlighting-registry))))) - -(defun muse-configure-highlighting (sym val) - "Extract color markup information from VAL and set to SYM. -This is usually called with `muse-colors-markup' as both arguments." - (muse-colors-define-highlighting 'muse-mode val) - (set sym val)) - -(defun muse-colors-emphasized () - "Color emphasized text and headings." - ;; Here we need to check four different points - the start and end - ;; of the leading *s, and the start and end of the trailing *s. We - ;; allow the outsides to be surrounded by whitespace or punctuation, - ;; but no word characters, and the insides must not be surrounded by - ;; whitespace or punctuation. Thus the following are valid: - ;; - ;; " *foo bar* " - ;; "**foo**," - ;; and the following is invalid: - ;; "** testing **" - (let* ((beg (match-beginning 0)) - (e1 (match-end 0)) - (leader (- e1 beg)) - b2 e2 multiline) - (unless (or (eq (get-text-property beg 'invisible) 'muse) - (get-text-property beg 'muse-comment) - (get-text-property beg 'muse-directive)) - ;; check if it's a header - (if (eq (char-after e1) ?\ ) - (when (or (= beg (point-min)) - (eq (char-before beg) ?\n)) - (add-text-properties - (muse-line-beginning-position) (muse-line-end-position) - (list 'face (intern (concat "muse-header-" - (int-to-string leader)))))) - ;; beginning of line or space or symbol - (when (or (= beg (point-min)) - (eq (char-syntax (char-before beg)) ?\ ) - (memq (char-before beg) - '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n))) - (save-excursion - (skip-chars-forward "^*<>\n" muse-colors-region-end) - (when (eq (char-after) ?\n) - (setq multiline t) - (skip-chars-forward "^*<>" muse-colors-region-end)) - (setq b2 (point)) - (skip-chars-forward "*" muse-colors-region-end) - (setq e2 (point)) - ;; Abort if space exists just before end - ;; or bad leader - ;; or no '*' at end - ;; or word constituent follows - (unless (or (> leader 5) - (not (eq leader (- e2 b2))) - (eq (char-syntax (char-before b2)) ?\ ) - (not (eq (char-after b2) ?*)) - (and (not (eobp)) - (eq (char-syntax (char-after (1+ b2))) ?w))) - (add-text-properties beg e1 '(invisible muse)) - (add-text-properties - e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1) - ((= leader 2) 'muse-emphasis-2) - ((= leader 3) 'muse-emphasis-3)))) - (add-text-properties b2 e2 '(invisible muse)) - (when multiline - (add-text-properties - beg e2 '(font-lock-multiline t)))))))))) - -(defun muse-colors-underlined () - "Color underlined text." - (let ((start (match-beginning 0)) - multiline) - (unless (or (eq (get-text-property start 'invisible) 'muse) - (get-text-property start 'muse-comment) - (get-text-property start 'muse-directive)) - ;; beginning of line or space or symbol - (when (or (= start (point-min)) - (eq (char-syntax (char-before start)) ?\ ) - (memq (char-before start) - '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n))) - (save-excursion - (skip-chars-forward "^_<>\n" muse-colors-region-end) - (when (eq (char-after) ?\n) - (setq multiline t) - (skip-chars-forward "^_<>" muse-colors-region-end)) - ;; Abort if space exists just before end - ;; or no '_' at end - ;; or word constituent follows - (unless (or (eq (char-syntax (char-before (point))) ?\ ) - (not (eq (char-after (point)) ?_)) - (and (not (eobp)) - (eq (char-syntax (char-after (1+ (point)))) ?w))) - (add-text-properties start (1+ start) '(invisible muse)) - (add-text-properties (1+ start) (point) '(face underline)) - (add-text-properties (point) - (min (1+ (point)) (point-max)) - '(invisible muse)) - (when multiline - (add-text-properties - start (min (1+ (point)) (point-max)) - '(font-lock-multiline t))))))))) - -(defun muse-colors-verbatim () - "Render in teletype and suppress further parsing." - (let ((start (match-beginning 0)) - multiline) - (unless (or (eq (get-text-property start 'invisible) 'muse) - (get-text-property start 'muse-comment) - (get-text-property start 'muse-directive)) - ;; beginning of line or space or symbol - (when (or (= start (point-min)) - (eq (char-syntax (char-before start)) ?\ ) - (memq (char-before start) - '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n))) - (let ((pos (point))) - (skip-chars-forward "^=\n" muse-colors-region-end) - (when (eq (char-after) ?\n) - (setq multiline t) - (skip-chars-forward "^=" muse-colors-region-end)) - ;; Abort if space exists just before end - ;; or no '=' at end - ;; or word constituent follows - (unless (or (eq (char-syntax (char-before (point))) ?\ ) - (not (eq (char-after (point)) ?=)) - (and (not (eobp)) - (eq (char-syntax (char-after (1+ (point)))) ?w))) - (setq pos (min (1+ (point)) (point-max))) - (add-text-properties start (1+ start) '(invisible muse)) - (add-text-properties (1+ start) (point) '(face muse-verbatim)) - (add-text-properties (point) - (min (1+ (point)) (point-max)) - '(invisible muse)) - (when multiline - (add-text-properties - start (min (1+ (point)) (point-max)) - '(font-lock-multiline t)))) - (goto-char pos)))))) - -(defcustom muse-colors-markup - `(;; make emphasized text appear emphasized - ("\\*\\{1,5\\}" ?* muse-colors-emphasized) - - ;; make underlined text appear underlined - (,(concat "_[^" muse-regexp-blank "_\n]") - ?_ muse-colors-underlined) - - ("^#title " ?\# muse-colors-title) - - (muse-explicit-link-regexp ?\[ muse-colors-explicit-link) - - ;; render in teletype and suppress further parsing - (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim) - - ;; highlight any markup tags encountered - (muse-tag-regexp ?\< muse-colors-custom-tags) - - ;; display comments - (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment) - - ;; this has to come later since it doesn't have a special - ;; character in the second cell - (muse-url-regexp t muse-colors-implicit-link) - ) - "Expressions to highlight an Emacs Muse buffer. -These are arranged in a rather special fashion, so as to be as quick as -possible. - -Each element of the list is itself a list, of the form: - - (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION) - -LOCATE-REGEXP is a partial regexp, and should be the smallest possible -regexp to differentiate this rule from other rules. It may also be a -symbol containing such a regexp. The buffer region is scanned only -once, and LOCATE-REGEXP indicates where the scanner should stop to -look for highlighting possibilities. - -TEST-CHAR is a char or t. The character should match the beginning -text matched by LOCATE-REGEXP. These chars are used to build a vector -for fast MATCH-FUNCTION calling. - -MATCH-FUNCTION is the function called when a region has been -identified. It is responsible for adding the appropriate text -properties to change the appearance of the buffer. - -This markup is used to modify the appearance of the original text to -make it look more like the published HTML would look (like making some -markup text invisible, inlining images, etc). - -font-lock is used to apply the markup rules, so that they can happen -on a deferred basis. They are not always accurate, but you can use -\\[font-lock-fontifty-block] near the point of error to force -fontification in that area." - :type '(repeat - (list :tag "Highlight rule" - (choice (regexp :tag "Locate regexp") - (symbol :tag "Regexp symbol")) - (choice (character :tag "Confirm character") - (const :tag "Default rule" t)) - function)) - :set 'muse-configure-highlighting - :group 'muse-colors) - -;; XEmacs users don't have `font-lock-multiline'. -(unless (boundp 'font-lock-multiline) - (defvar font-lock-multiline nil)) - -(defun muse-use-font-lock () - "Set up font-locking for Muse." - (muse-add-to-invisibility-spec 'muse) - (set (make-local-variable 'font-lock-multiline) 'undecided) - (set (make-local-variable 'font-lock-defaults) - `(nil t nil nil beginning-of-line - (font-lock-fontify-region-function . muse-colors-region) - (font-lock-unfontify-region-function - . muse-unhighlight-region))) - (set (make-local-variable 'font-lock-fontify-region-function) - 'muse-colors-region) - (set (make-local-variable 'font-lock-unfontify-region-function) - 'muse-unhighlight-region) - (muse-make-faces) - (muse-colors-define-highlighting 'muse-mode muse-colors-markup) - (font-lock-mode t)) - -(defun muse-colors-buffer () - "Re-highlight the entire Muse buffer." - (interactive) - (muse-colors-region (point-min) (point-max) t)) - -(defvar muse-colors-fontifying-p nil - "Indicate whether Muse is fontifying the current buffer.") -(make-variable-buffer-local 'muse-colors-fontifying-p) - -(defvar muse-colors-delayed-commands nil - "Commands to be run immediately after highlighting a region. - -This is meant to accommodate highlighting <lisp> in #title -directives after everything else. - -It may be modified by Muse functions during highlighting, but not -the user.") -(make-variable-buffer-local 'muse-colors-delayed-commands) - -(defun muse-colors-region (beg end &optional verbose) - "Apply highlighting according to `muse-colors-markup'. -Note that this function should NOT change the buffer, nor should any -of the functions listed in `muse-colors-markup'." - (let ((buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - (modified-p (buffer-modified-p)) - (muse-colors-fontifying-p t) - (muse-colors-region-end (muse-line-end-position end)) - (muse-colors-delayed-commands nil) - (highlighting (muse-colors-find-highlighting major-mode)) - regexp vector remaining - deactivate-mark) - (unless highlighting - (error "No highlighting found for this mode")) - (setq regexp (nth muse-colors-highlighting.regexp highlighting) - vector (nth muse-colors-highlighting.vector highlighting) - remaining (nth muse-colors-highlighting.remaining highlighting)) - (unwind-protect - (save-excursion - (save-restriction - (widen) - ;; check to see if we should expand the beg/end area for - ;; proper multiline matches - (when (and font-lock-multiline - (> beg (point-min)) - (get-text-property (1- beg) 'font-lock-multiline)) - ;; We are just after or in a multiline match. - (setq beg (or (previous-single-property-change - beg 'font-lock-multiline) - (point-min))) - (goto-char beg) - (setq beg (muse-line-beginning-position))) - (when font-lock-multiline - (setq end (or (text-property-any end (point-max) - 'font-lock-multiline nil) - (point-max)))) - (goto-char end) - (setq end (muse-line-beginning-position 2)) - ;; Undo any fontification in the area. - (font-lock-unfontify-region beg end) - ;; And apply fontification based on `muse-colors-markup' - (let ((len (float (- end beg))) - (case-fold-search nil) - markup-list) - (goto-char beg) - (while (and (< (point) end) - (re-search-forward regexp end t)) - (if verbose - (message "Highlighting buffer...%d%%" - (* (/ (float (- (point) beg)) len) 100))) - (let ((ch (char-after (match-beginning 0)))) - (when (< ch 128) - (setq markup-list (aref vector ch)))) - (unless markup-list - (setq markup-list remaining)) - (let ((prev (point))) - ;; backtrack and figure out which rule matched - (goto-char (match-beginning 0)) - (catch 'done - (dolist (entry markup-list) - (let ((value (cond ((symbolp (car entry)) - (symbol-value (car entry))) - ((stringp (car entry)) - (car entry)) - (t nil)))) - (when (and (stringp value) (looking-at value)) - (goto-char (match-end 0)) - (when (cdr entry) - (funcall (cdr entry))) - (throw 'done t)))) - ;; if no rule matched, which should never happen, - ;; return to previous position so that forward - ;; progress is ensured - (goto-char prev)))) - (dolist (command muse-colors-delayed-commands) - (apply (car command) (cdr command))) - (run-hook-with-args 'muse-colors-buffer-hook - beg end verbose) - (if verbose (message "Highlighting buffer...done"))))) - (set-buffer-modified-p modified-p)))) - -(defcustom muse-colors-tags - '(("example" t nil nil muse-colors-example-tag) - ("code" t nil nil muse-colors-example-tag) - ("verbatim" t nil nil muse-colors-literal-tag) - ("lisp" t t nil muse-colors-lisp-tag) - ("literal" t nil nil muse-colors-literal-tag)) - "A list of tag specifications for specially highlighting text. -XML-style tags are the best way to add custom highlighting to Muse. -This is easily accomplished by customizing this list of markup tags. - -For each entry, the name of the tag is given, whether it expects -a closing tag and/or an optional set of attributes, whether it is -nestable, and a function that performs whatever action is desired -within the delimited region. - -The function is called with three arguments, the beginning and -end of the region surrounded by the tags. If properties are -allowed, they are passed as a third argument in the form of an -alist. The `end' argument to the function is the last character -of the enclosed tag or region. - -Functions should not modify the contents of the buffer." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-colors) - -(defvar muse-colors-inhibit-tags-in-directives t - "If non-nil, don't allow tags to be interpreted in directives. -This is used to delay highlighting of <lisp> tags in #title until later.") -(make-variable-buffer-local 'muse-colors-inhibit-tags-in-directives) - -(defsubst muse-colors-tag-info (tagname &rest args) - "Get tag info associated with TAGNAME, ignoring ARGS." - (assoc tagname muse-colors-tags)) - -(defun muse-colors-custom-tags () - "Highlight `muse-colors-tags'." - (let ((tag-info (muse-colors-tag-info (match-string 1)))) - (unless (or (not tag-info) - (get-text-property (match-beginning 0) 'muse-comment) - (and muse-colors-inhibit-tags-in-directives - (get-text-property (match-beginning 0) 'muse-directive))) - (let ((closed-tag (match-string 3)) - (start (match-beginning 0)) - end attrs) - (when (nth 2 tag-info) - (let ((attrstr (match-string 2))) - (while (and attrstr - (string-match (concat "\\([^" - muse-regexp-blank - "=\n]+\\)\\(=\"" - "\\([^\"]+\\)\"\\)?") - attrstr)) - (let ((attr (cons (downcase - (muse-match-string-no-properties 1 attrstr)) - (muse-match-string-no-properties 3 attrstr)))) - (setq attrstr (replace-match "" t t attrstr)) - (if attrs - (nconc attrs (list attr)) - (setq attrs (list attr))))))) - (if (and (cadr tag-info) (not closed-tag)) - (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info)) - (setq end (match-end 0)) - (setq tag-info nil))) - (when tag-info - (let ((args (list start end))) - (if (nth 2 tag-info) - (nconc args (list attrs))) - (apply (nth 4 tag-info) args))))))) - -(defun muse-unhighlight-region (begin end &optional verbose) - "Remove all visual highlights in the buffer (except font-lock)." - (let ((buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - (modified-p (buffer-modified-p)) - deactivate-mark) - (unwind-protect - (remove-text-properties - begin end '(face nil font-lock-multiline nil end-glyph nil - invisible nil intangible nil display nil - mouse-face nil keymap nil help-echo nil - muse-link nil muse-directive nil muse-comment nil - muse-no-implicit-link nil muse-no-flyspell nil)) - (set-buffer-modified-p modified-p)))) - -(defun muse-colors-example-tag (beg end) - "Strip properties and colorize with `muse-verbatim'." - (muse-unhighlight-region beg end) - (let ((multi (save-excursion - (goto-char beg) - (forward-line 1) - (> end (point))))) - (add-text-properties beg end `(face muse-verbatim - font-lock-multiline ,multi)))) - -(defun muse-colors-literal-tag (beg end) - "Strip properties and mark as literal." - (muse-unhighlight-region beg end) - (let ((multi (save-excursion - (goto-char beg) - (forward-line 1) - (> end (point))))) - (add-text-properties beg end `(font-lock-multiline ,multi)))) - -(defun muse-colors-lisp-tag (beg end attrs) - "Color the region enclosed by a <lisp> tag." - (if (not muse-colors-evaluate-lisp-tags) - (muse-colors-literal-tag beg end) - (muse-unhighlight-region beg end) - (let (beg-lisp end-lisp) - (save-match-data - (goto-char beg) - (setq beg-lisp (and (looking-at "<[^>]+>") - (match-end 0))) - (goto-char end) - (setq end-lisp (and (muse-looking-back "</[^>]+>") - (match-beginning 0)))) - (add-text-properties - beg end - (list 'font-lock-multiline t - 'display (muse-eval-lisp - (concat - "(progn " - (buffer-substring-no-properties beg-lisp end-lisp) - ")")) - 'intangible t))))) - -(defvar muse-mode-local-map - (let ((map (make-sparse-keymap))) - (define-key map [return] 'muse-follow-name-at-point) - (define-key map [(control ?m)] 'muse-follow-name-at-point) - (define-key map [(shift return)] 'muse-follow-name-at-point-other-window) - (if (featurep 'xemacs) - (progn - (define-key map [(button2)] 'muse-follow-name-at-mouse) - (define-key map [(shift button2)] - 'muse-follow-name-at-mouse-other-window)) - (define-key map [(shift control ?m)] - 'muse-follow-name-at-point-other-window) - (define-key map [mouse-2] 'muse-follow-name-at-mouse) - (define-key map [(shift mouse-2)] - 'muse-follow-name-at-mouse-other-window) - (unless (eq emacs-major-version 21) - (set-keymap-parent map muse-mode-map))) - map) - "Local keymap used by Muse while on a link.") - -(defvar muse-keymap-property - (if (or (featurep 'xemacs) - (>= emacs-major-version 21)) - 'keymap - 'local-map) - "The name of the keymap or local-map property.") - -(defsubst muse-link-properties (help-str &optional face) - "Determine text properties to use for a link." - (append (if face - (list 'face face 'mouse-face 'highlight 'muse-link t) - (list 'invisible 'muse 'intangible t)) - (list 'help-echo help-str 'rear-nonsticky t - muse-keymap-property muse-mode-local-map))) - -(defun muse-link-face (link-name &optional explicit) - "Return the type of LINK-NAME as a face symbol. -For EXPLICIT links, this is either a normal link or a bad-link -face. For implicit links, it is either colored normally or -ignored." - (save-match-data - (let ((link (if explicit - (muse-handle-explicit-link link-name) - (muse-handle-implicit-link link-name)))) - (when link - (cond ((string-match muse-url-regexp link) - 'muse-link) - ((muse-file-remote-p link) - 'muse-link) - ((string-match muse-file-regexp link) - (when (string-match "/[^/]+#[^#./]+\\'" link) - ;; strip anchor from the end of a path - (setq link (substring link 0 (match-beginning 0)))) - (if (file-exists-p link) - 'muse-link - 'muse-bad-link)) - ((not (featurep 'muse-project)) - 'muse-link) - (t - (if (string-match "#" link) - (setq link (substring link 0 (match-beginning 0)))) - (if (or (and (muse-project-of-file) - (muse-project-page-file - link muse-current-project t)) - (file-exists-p link)) - 'muse-link - 'muse-bad-link))))))) - -(defun muse-colors-use-publishing-directory (link) - "Make LINK relative to the directory where we will publish the -current file." - (let ((style (car (muse-project-applicable-styles - link (cddr (muse-project))))) - path) - (when (and style - (setq path (muse-style-element :path style))) - (expand-file-name link path)))) - -(defun muse-colors-resolve-image-file (link) - "Determine if we can create images and see if the link is an image -file." - (save-match-data - (and (or (fboundp 'create-image) - (fboundp 'make-glyph)) - (not (string-match "\\`[uU][rR][lL]:" link)) - (string-match muse-image-regexp link)))) - -(defun muse-make-file-glyph (filename) - "Given a file name, return a newly-created image glyph. -This is a hack for supporting inline images in XEmacs." - (let ((case-fold-search nil)) - ;; Scan filename to determine image type - (when (fboundp 'make-glyph) - (save-match-data - (cond ((string-match "jpe?g" filename) - (make-glyph (vector 'jpeg :file filename) 'buffer)) - ((string-match "gif" filename) - (make-glyph (vector 'gif :file filename) 'buffer)) - ((string-match "png" filename) - (make-glyph (vector 'png :file filename) 'buffer))))))) - -(defun muse-colors-insert-image (link beg end invis-props) - "Create an image using create-image or make-glyph and insert it -in place of an image link defined by BEG and END." - (setq link (expand-file-name link)) - (let ((image-file (cond - ((eq muse-colors-inline-image-method 'default-directory) - link) - ((functionp muse-colors-inline-image-method) - (funcall muse-colors-inline-image-method link)))) - glyph) - (when (stringp image-file) - (if (fboundp 'create-image) - ;; use create-image and display property - (let ((display-stuff (condition-case nil - (create-image image-file) - (error nil)))) - (when display-stuff - (add-text-properties beg end (list 'display display-stuff)))) - ;; use make-glyph and invisible property - (and (setq glyph (muse-make-file-glyph image-file)) - (progn - (add-text-properties beg end invis-props) - (add-text-properties beg end (list - 'end-glyph glyph - 'help-echo link)))))))) - -(defun muse-colors-explicit-link () - "Color explicit links." - (when (and (eq ?\[ (char-after (match-beginning 0))) - (not (get-text-property (match-beginning 0) 'muse-comment)) - (not (get-text-property (match-beginning 0) 'muse-directive))) - ;; remove flyspell overlays - (when (fboundp 'flyspell-unhighlight-at) - (let ((cur (match-beginning 0))) - (while (> (match-end 0) cur) - (flyspell-unhighlight-at cur) - (setq cur (1+ cur))))) - (let* ((unesc-link (muse-get-link)) - (unesc-desc (muse-get-link-desc)) - (link (muse-link-unescape unesc-link)) - (desc (muse-link-unescape unesc-desc)) - (props (muse-link-properties desc (muse-link-face link t))) - (invis-props (append props (muse-link-properties desc)))) - ;; see if we should try and inline an image - (if (and muse-colors-inline-images - (or (muse-colors-resolve-image-file link) - (and desc - (muse-colors-resolve-image-file desc) - (setq link desc)))) - ;; we found an image, so inline it - (muse-colors-insert-image - link - (match-beginning 0) (match-end 0) invis-props) - (if desc - (progn - ;; we put the normal face properties on the invisible - ;; portion too, since emacs sometimes will position - ;; the cursor on an intangible character - (add-text-properties (match-beginning 0) - (match-beginning 2) invis-props) - (add-text-properties (match-beginning 2) (match-end 2) props) - (add-text-properties (match-end 2) (match-end 0) invis-props) - ;; in case specials were escaped, cause the unescaped - ;; text to be displayed - (unless (string= desc unesc-desc) - (add-text-properties (match-beginning 2) (match-end 2) - (list 'display desc)))) - (add-text-properties (match-beginning 0) - (match-beginning 1) invis-props) - (add-text-properties (match-beginning 1) (match-end 0) props) - (add-text-properties (match-end 1) (match-end 0) invis-props) - (unless (string= link unesc-link) - (add-text-properties (match-beginning 1) (match-end 1) - (list 'display link)))) - (goto-char (match-end 0)) - (add-text-properties - (match-beginning 0) (match-end 0) - (muse-link-properties (muse-match-string-no-properties 0) - (muse-link-face link t))))))) - -(defun muse-colors-implicit-link () - "Color implicit links." - (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse) - (get-text-property (match-beginning 0) 'muse-comment) - (get-text-property (match-beginning 0) 'muse-directive) - (get-text-property (match-beginning 0) 'muse-no-implicit-link) - (eq (char-before (match-beginning 0)) ?\") - (eq (char-after (match-end 0)) ?\")) - ;; remove flyspell overlays - (when (fboundp 'flyspell-unhighlight-at) - (let ((cur (match-beginning 0))) - (while (> (match-end 0) cur) - (flyspell-unhighlight-at cur) - (setq cur (1+ cur))))) - ;; colorize link - (let ((link (muse-match-string-no-properties 0)) - (face (muse-link-face (match-string 0)))) - (when face - (add-text-properties (match-beginning 0) (match-end 0) - (muse-link-properties - (muse-match-string-no-properties 0) face)))))) - -(defun muse-colors-title () - "Color #title directives." - (let ((beg (+ 7 (match-beginning 0)))) - (add-text-properties beg (muse-line-end-position) '(muse-directive t)) - ;; colorize <lisp> tags in #title after other <lisp> tags have had a - ;; chance to run, so that we can have behavior that is consistent - ;; with how the document is published - (setq muse-colors-delayed-commands - (cons (list 'muse-colors-title-lisp beg (muse-line-end-position)) - muse-colors-delayed-commands)))) - -(defun muse-colors-title-lisp (beg end) - "Called after other highlighting is done for a region in order to handle -<lisp> tags that exist in #title directives." - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (let ((muse-colors-inhibit-tags-in-directives nil) - (muse-colors-tags '(("lisp" t t nil muse-colors-lisp-tag)))) - (while (re-search-forward muse-tag-regexp nil t) - (muse-colors-custom-tags)))) - (add-text-properties beg end '(face muse-header-1))) - -(defun muse-colors-comment () - "Color comments." - (add-text-properties (match-beginning 0) (muse-line-end-position) - (list 'face 'font-lock-comment-face - 'muse-comment t))) - - -(provide 'muse-colors) - -;;; muse-colors.el ends here diff --git a/emacs.d/elisp/muse/muse-context.el b/emacs.d/elisp/muse/muse-context.el deleted file mode 100644 index 45968b0..0000000 --- a/emacs.d/elisp/muse/muse-context.el +++ /dev/null @@ -1,458 +0,0 @@ -;;; muse-context.el --- publish entries in ConTeXt or PDF format - -;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Jean Magnan de Bornier (jean@bornier.net) -;; Created: 16-Apr-2007 - -;; Emacs Muse 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 when loaded allows you to publish .muse files as ConTeXt -;; files or as pdf files, using respectively the "context" and -;; "context-pdf" styles. It is far from being perfect, so any feedback -;; will be welcome and any mistake hopefully fixed. - -;;; Author: - -;; Jean Magnan de Bornier, who based this file on muse-latex.el and -;; made the context, context-pdf, context-slides, and -;; context-slides-pdf Muse publishing styles. - -;; 16 Avril 2007 - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse ConTeXt Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) - -(defgroup muse-context nil - "Rules for marking up a Muse file as a ConTeXt article." - :group 'muse-publish) - -(defcustom muse-context-extension ".tex" - "Default file extension for publishing ConTeXt files." - :type 'string - :group 'muse-context) - -(defcustom muse-context-pdf-extension ".pdf" - "Default file extension for publishing ConTeXt files to PDF." - :type 'string - :group 'muse-context) - -(defcustom muse-context-pdf-program "texexec --pdf" - "The program that is called to generate PDF content from ConTeXt content." - :type 'string - :group 'muse-context) - -(defcustom muse-context-pdf-cruft '(".pgf" ".tmp" ".tui" ".tuo" ".toc" ".log") - "Extensions of files to remove after generating PDF output successfully." - :type 'string - :group 'muse-context) - -(defcustom muse-context-header - "\\setupinteraction [state=start] -\\usemodule[tikz] -\\usemodule[bib]\n -<lisp>(muse-context-setup-bibliography)</lisp> - \\setuppublications[]\n -\\setuppublicationlist[]\n\\setupcite[]\n -\\starttext -\\startalignment[center] - \\blank[2*big] - {\\tfd <lisp>(muse-publishing-directive \"title\")</lisp>} - \\blank[3*medium] - {\\tfa <lisp>(muse-publishing-directive \"author\")</lisp>} - \\blank[2*medium] - {\\tfa <lisp>(muse-publishing-directive \"date\")</lisp>} - \\blank[3*medium] -\\stopalignment - -<lisp>(and muse-publish-generate-contents - (not muse-context-permit-contents-tag) - \"\\\\placecontent\n\\\\page[yes]\")</lisp>\n\n" - "Header used for publishing ConTeXt files. This may be text or a filename." - :type 'string - :group 'muse-context) - -(defcustom muse-context-footer "<lisp>(muse-context-bibliography)</lisp> -\\stoptext\n" - "Footer used for publishing ConTeXt files. This may be text or a filename." - :type 'string - :group 'muse-context) - -(defcustom muse-context-markup-regexps - `(;; numeric ranges - (10000 "\\([0-9]+\\)-\\([0-9]+\\)" 0 "\\1--\\2") - - ;; be careful of closing quote pairs - (10100 "\"'" 0 "\"\\\\-'")) - "List of markup regexps for identifying regions in a Muse page. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-context) - -(defcustom muse-context-markup-functions - '((table . muse-context-markup-table)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-context) - -(defcustom muse-context-markup-strings - '((image-with-desc . "\\placefigure[][]{%3%}{\\externalfigure[%1%.%2%]}") - (image . "\\placefigure[][]{}{\\externalfigure[%s.%s]}") - (image-link . "\\useURL[aa][%s][][%1%] \\from[aa]") - (anchor-ref . "\\goto{%2%}{}[%1%]") - (url . "\\useURL[aa][%s][][%s] \\from[aa]") - (url-and-desc . "\\useURL[bb][%s][][%s]\\from[bb]\\footnote{%1%}") - (link . "\\goto{%2%}[program(%1%)]\\footnote{%1%}") - (link-and-anchor . "\\useexternaldocument[%4%][%4%][] \\at{%3%, page}{}[%4%::%2%]\\footnote{%1%}") - (email-addr . "\\useURL[mail][mailto:%s][][%s]\\from[mail]") - (anchor . "\\reference[%s] ") - (emdash . "---") - (comment-begin . "\\doifmode{comment}{") - (comment-end . "}") - (rule . "\\blank[medium]\\hrule\\blank[medium]") - (no-break-space . "~") - (enddots . "\\ldots ") - (dots . "\\dots ") - (part . "\\part{") - (part-end . "}") - (chapter . "\\chapter{") - (chapter-end . "}") - (section . "\\section{") - (section-end . "}") - (subsection . "\\subsection{") - (subsection-end . "}") - (subsubsection . "\\subsubsection{") - (subsubsection-end . "}") - (section-other . "\\subsubsubject{") - (section-other-end . "}") - (footnote . "\\footnote{") - (footnote-end . "}") - (footnotetext . "\\footnotetext[%d]{") - (begin-underline . "\\underbar{") - (end-underline . "}") - (begin-literal . "\\type{") - (end-literal . "}") - (begin-emph . "{\\em ") - (end-emph . "}") - (begin-more-emph . "{\\bf ") - (end-more-emph . "}") - (begin-most-emph . "{\\bf {\\em ") - (end-most-emph . "}}") - (begin-example . "\\starttyping") - (end-example . "\\stoptyping") - (begin-center . "\\startalignment[center]\n") - (end-center . "\n\\stopalignment") - (begin-quote . "\\startquotation\n") - (end-quote . "\n\\stopquotation") - (begin-cite . "\\cite[authoryear][") - (begin-cite-author . "\\cite[author][") - (begin-cite-year . "\\cite[year][") - (end-cite . "]") - (begin-uli . "\\startitemize\n") - (end-uli . "\n\\stopitemize") - (begin-uli-item . "\\item ") - (begin-oli . "\\startitemize[n]\n") - (end-oli . "\n\\stopitemize") - (begin-oli-item . "\\item ") - (begin-dl . "\\startitemize\n") - (end-dl . "\n\\stopitemize") - (begin-ddt . "\\head ") - (end-ddt . "\n") - (begin-verse . "\\blank[big]") - (end-verse-line . "\\par") - (verse-space . "\\fixedspaces ~~") - (end-verse . "\\blank[big]")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-context) - -(defcustom muse-context-slides-header - "\\usemodule[<lisp>(if (string-equal (muse-publishing-directive \"module\") nil) \"pre-01\" (muse-publishing-directive \"module\"))</lisp>] -\\usemodule[tikz] -\\usemodule[newmat] -\\setupinteraction [state=start] -\\starttext -\\TitlePage { <lisp>(muse-publishing-directive \"title\")</lisp> -\\blank[3*medium] -\\tfa <lisp>(muse-publishing-directive \"author\")</lisp> - \\blank[2*medium] - \\tfa <lisp>(muse-publishing-directive \"date\")</lisp>}" - "Header for publishing a presentation (slides) using ConTeXt. -Any of the predefined modules, which are available in the -tex/context/base directory, can be used by writing a \"module\" -directive at the top of the muse file; if no such directive is -provided, module pre-01 is used. Alternatively, you can use your -own style (\"mystyle\", in this example) by replacing -\"\\usemodule[]\" with \"\\input mystyle\". - -This may be text or a filename." - :type 'string - :group 'muse-context) - -(defcustom muse-context-slides-markup-strings - '((section . "\\Topic {") - (subsection . "\\page \n{\\bf ") - (subsubsection . "{\\em ")) - "Strings used for marking up text in ConTeXt slides." - :type '(alist :key-type symbol :value-type string) - :group 'muse-context) - -(defcustom muse-context-markup-specials-document - '((?\\ . "\\textbackslash{}") - (?\_ . "\\textunderscore{}") - (?\< . "\\switchtobodyfont[small]") - (?\> . "\\switchtobodyfont[big]") - (?^ . "\\^") - (?\~ . "\\~") - (?\@ . "\\@") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#")) - "A table of characters which must be represented specially. -These are applied to the entire document, sans already-escaped -regions." - :type '(alist :key-type character :value-type string) - :group 'muse-context) - -(defcustom muse-context-markup-specials-example - '() - "A table of characters which must be represented specially. -These are applied to <example> regions. - -With the default interpretation of <example> regions, no specials -need to be escaped." - :type '(alist :key-type character :value-type string) - :group 'muse-context) - -(defcustom muse-context-markup-specials-literal - '() - "A table of characters which must be represented specially. -This applies to =monospaced text= and <code> regions." - :type '(alist :key-type character :value-type string) - :group 'muse-context) - -(defcustom muse-context-markup-specials-url - '((?\\ . "\\textbackslash") - (?\_ . "\\_") - (?\< . "\\<") - (?\> . "\\>") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#")) - "A table of characters which must be represented specially. -These are applied to URLs." - :type '(alist :key-type character :value-type string) - :group 'muse-context) - -(defcustom muse-context-markup-specials-image - '((?\\ . "\\textbackslash") ; cannot find suitable replacement - (?\< . "\\<") - (?\> . "\\>") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#") ; cannot find suitable replacement - ) - "A table of characters which must be represented specially. -These are applied to image filenames." - :type '(alist :key-type character :value-type string) - :group 'muse-context) - -(defun muse-context-decide-specials (context) - "Determine the specials to escape, depending on the CONTEXT argument." - (cond ((memq context '(underline emphasis document url-desc verbatim - footnote)) - muse-context-markup-specials-document) - ((eq context 'image) - muse-context-markup-specials-image) - ((memq context '(email url)) - muse-context-markup-specials-url) - ((eq context 'literal) - muse-context-markup-specials-literal) - ((eq context 'example) - muse-context-markup-specials-example) - (t (error "Invalid context argument '%s' in muse-context" context)))) - -(defun muse-context-markup-table () - (let* ((table-info (muse-publish-table-fields (match-beginning 0) - (match-end 0))) - (row-len (car table-info)) - (field-list (cdr table-info))) - (when table-info - (muse-insert-markup "\\starttable[|" - (mapconcat 'symbol-name (make-vector row-len 'l) - "|") "|]\n \\HL\n \\VL ") - (dolist (fields field-list) - (let ((type (car fields))) - (setq fields (cdr fields)) - (when (= type 3) - (muse-insert-markup "")) - (insert (car fields)) - (setq fields (cdr fields)) - (dolist (field fields) - (muse-insert-markup " \\VL ") - (insert field)) - (muse-insert-markup "\\VL\\NR\n \\HL\n \\VL ") - (when (= type 2) - (muse-insert-markup " ")))) - (muse-insert-markup "\\stoptable\n") - (while (search-backward "VL \\stoptable" nil t) - (replace-match "stoptable" nil t))))) - -(defun muse-context-fixup-dquotes () - "Fixup double quotes." - (goto-char (point-min)) - (let ((open t)) - (while (search-forward "\"" nil t) - (unless (get-text-property (match-beginning 0) 'read-only) - (when (or (bobp) - (eq (char-before) ?\n)) - (setq open t)) - (if open - (progn - (replace-match "``") - (setq open nil)) - (replace-match "''") - (setq open t)))))) - -(defcustom muse-context-permit-contents-tag nil - "If nil, ignore <contents> tags. Otherwise, insert table of contents. - -Most of the time, it is best to have a table of contents on the -first page, with a new page immediately following. To make this -work with documents published in both HTML and ConTeXt, we need to -ignore the <contents> tag. - -If you don't agree with this, then set this option to non-nil, -and it will do what you expect." - :type 'boolean - :group 'muse-context) - -(defun muse-context-fixup-citations () - "Replace semicolons in multi-head citations with colons." - (goto-char (point-min)) - (while (re-search-forward "\\\\cite.?\\[" nil t) - (let ((start (point)) - (end (re-search-forward "]"))) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward ";" nil t) - (replace-match ",")))))) - -(defun muse-context-munge-buffer () - (muse-context-fixup-dquotes) - (muse-context-fixup-citations) - (when (and muse-context-permit-contents-tag - muse-publish-generate-contents) - (goto-char (car muse-publish-generate-contents)) - (muse-insert-markup "\\placecontent"))) - -(defun muse-context-bibliography () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "\\\\cite.?\\[" nil t) - "\\completepublications[criterium=all]" - ""))) - -(defun muse-context-setup-bibliography () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "\\\\cite.?\\[" nil t) - (concat - "\\usemodule[bibltx]\n\\setupbibtex [database=" - (muse-publishing-directive "bibsource") "]") - ""))) - -(defun muse-context-pdf-browse-file (file) - (shell-command (concat "open " file))) - -(defun muse-context-pdf-generate (file output-path final-target) - (apply - #'muse-publish-transform-output - file output-path final-target "PDF" - (function - (lambda (file output-path) - (let* ((fnd (file-name-directory output-path)) - (command (format "%s \"%s\"" - muse-context-pdf-program - (file-relative-name file fnd))) - (times 0) - (default-directory fnd) - result) - ;; XEmacs can sometimes return a non-number result. We'll err - ;; on the side of caution by continuing to attempt to generate - ;; the PDF if this happens and treat the final result as - ;; successful. - (while (and (< times 2) - (or (not (numberp result)) - (not (eq result 0)) - ;; table of contents takes 2 passes -;; (file-readable-p -;; (muse-replace-regexp-in-string -;; "\\.tex\\'" ".toc" file t t)) - )) - (setq result (shell-command command) - times (1+ times))) - (if (or (not (numberp result)) - (eq result 0)) - t - nil)))) - muse-context-pdf-cruft)) - -(muse-define-style "context" - :suffix 'muse-context-extension - :regexps 'muse-context-markup-regexps - :functions 'muse-context-markup-functions - :strings 'muse-context-markup-strings - :specials 'muse-context-decide-specials - :after 'muse-context-munge-buffer - :header 'muse-context-header - :footer 'muse-context-footer - :browser 'find-file) - -(muse-derive-style "context-pdf" "context" - :final 'muse-context-pdf-generate - :browser 'muse-context-pdf-browse-file - :link-suffix 'muse-context-pdf-extension - :osuffix 'muse-context-pdf-extension) - -(muse-derive-style "context-slides" "context" - :header 'muse-context-slides-header - :strings 'muse-context-slides-markup-strings) - -(muse-derive-style "context-slides-pdf" "context-pdf" - :header 'muse-context-slides-header - :strings 'muse-context-slides-markup-strings) - -(provide 'muse-context) - -;;; muse-context.el ends here diff --git a/emacs.d/elisp/muse/muse-docbook.el b/emacs.d/elisp/muse/muse-docbook.el deleted file mode 100644 index a54089f..0000000 --- a/emacs.d/elisp/muse/muse-docbook.el +++ /dev/null @@ -1,352 +0,0 @@ -;;; muse-docbook.el --- publish DocBook files - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Dale P. Smith (dpsm AT en DOT com) improved the markup -;; significantly and made many valuable suggestions. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse DocBook XML Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-regexps) -(require 'muse-xml-common) - -(defgroup muse-docbook nil - "Options controlling the behavior of Muse DocBook XML publishing. -See `muse-docbook' for more information." - :group 'muse-publish) - -(defcustom muse-docbook-extension ".xml" - "Default file extension for publishing DocBook XML files." - :type 'string - :group 'muse-docbook) - -(defcustom muse-docbook-header - "<?xml version=\"1.0\" encoding=\"<lisp> - (muse-docbook-encoding)</lisp>\"?> -<!DOCTYPE article PUBLIC \"-//OASIS//DTD DocBook V4.2//EN\" - \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\"<lisp>(muse-docbook-entities)</lisp>> -<article> - <articleinfo> - <title><lisp>(muse-publishing-directive \"title\")</lisp></title> - <author><lisp>(muse-docbook-get-author - (muse-publishing-directive \"author\"))</lisp></author> - <pubdate><lisp>(muse-publishing-directive \"date\")</lisp></pubdate> - </articleinfo> - <!-- Page published by Emacs Muse begins here -->\n" - "Header used for publishing DocBook XML files. -This may be text or a filename." - :type 'string - :group 'muse-docbook) - -(defcustom muse-docbook-footer " - <!-- Page published by Emacs Muse ends here --> -<lisp>(muse-docbook-bibliography)</lisp></article>\n" - "Footer used for publishing DocBook XML files. -This may be text or a filename." - :type 'string - :group 'muse-docbook) - -(defcustom muse-docbook-markup-regexps - `(;; Beginning of doc, end of doc, or plain paragraph separator - (10000 ,(concat "\\(\\(\n\\(?:[" muse-regexp-blank "]*\n\\)*" - "\\([" muse-regexp-blank "]*\n\\)\\)" - "\\|\\`\\s-*\\|\\s-*\\'\\)") - 3 muse-docbook-markup-paragraph)) - "List of markup rules for publishing a Muse page to DocBook XML. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-docbook) - -(defcustom muse-docbook-markup-functions - '((anchor . muse-xml-markup-anchor) - (table . muse-xml-markup-table)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-docbook) - -(defcustom muse-docbook-markup-strings - '((image-with-desc . "<mediaobject> -<imageobject> -<imagedata fileref=\"%1%.%2%\" format=\"%2%\" /> -</imageobject> -<caption><para>%3%</para></caption> -</mediaobject>") - (image . "<inlinemediaobject><imageobject> -<imagedata fileref=\"%1%.%2%\" format=\"%2%\" /> -</imageobject></inlinemediaobject>") - (image-link . "<ulink url=\"%1%\"><inlinemediaobject><imageobject> -<imagedata fileref=\"%2%.%3%\" format=\"%3%\" /> -</imageobject></inlinemediaobject></ulink>") - (anchor-ref . "<link linkend=\"%s\">%s</link>") - (url . "<ulink url=\"%s\">%s</ulink>") - (link . "<ulink url=\"%s\">%s</ulink>") - (link-and-anchor . "<ulink url=\"%s#%s\">%s</ulink>") - (email-addr . "<email>%s</email>") - (anchor . "<anchor id=\"%s\" />\n") - (emdash . "%s—%s") - (comment-begin . "<!-- ") - (comment-end . " -->") - (rule . "") - (no-break-space . " ") - (enddots . "....") - (dots . "...") - (section . "<section><title>") - (section-end . "</title>") - (subsection . "<section><title>") - (subsection-end . "</title>") - (subsubsection . "<section><title>") - (subsubsection-end . "</title>") - (section-other . "<section><title>") - (section-other-end . "</title>") - (section-close . "</section>") - (footnote . "<footnote><para>") - (footnote-end . "</para></footnote>") - (begin-underline . "") - (end-underline . "") - (begin-literal . "<systemitem>") - (end-literal . "</systemitem>") - (begin-emph . "<emphasis>") - (end-emph . "</emphasis>") - (begin-more-emph . "<emphasis role=\"strong\">") - (end-more-emph . "</emphasis>") - (begin-most-emph . "<emphasis role=\"strong\"><emphasis>") - (end-most-emph . "</emphasis></emphasis>") - (begin-verse . "<literallayout>\n") - (verse-space . " ") - (end-verse . "</literallayout>") - (begin-example . "<programlisting>") - (end-example . "</programlisting>") - (begin-center . "<para role=\"centered\">\n") - (end-center . "\n</para>") - (begin-quote . "<blockquote>\n") - (end-quote . "\n</blockquote>") - (begin-cite . "<citation role=\"%s\">") - (begin-cite-author . "<citation role=\"%s\">A:") - (begin-cite-year . "<citation role=\"%s\">Y:") - (end-cite . "</citation>") - (begin-quote-item . "<para>") - (end-quote-item . "</para>") - (begin-uli . "<itemizedlist mark=\"bullet\">\n") - (end-uli . "\n</itemizedlist>") - (begin-uli-item . "<listitem><para>") - (end-uli-item . "</para></listitem>") - (begin-oli . "<orderedlist>\n") - (end-oli . "\n</orderedlist>") - (begin-oli-item . "<listitem><para>") - (end-oli-item . "</para></listitem>") - (begin-dl . "<variablelist>\n") - (end-dl . "\n</variablelist>") - (begin-dl-item . "<varlistentry>\n") - (end-dl-item . "\n</varlistentry>") - (begin-ddt . "<term>") - (end-ddt . "</term>") - (begin-dde . "<listitem><para>") - (end-dde . "</para></listitem>") - (begin-table . "<informaltable>\n") - (end-table . "</informaltable>") - (begin-table-group . " <tgroup cols='%s'>\n") - (end-table-group . " </tgroup>\n") - (begin-table-row . " <row>\n") - (end-table-row . " </row>\n") - (begin-table-entry . " <entry>") - (end-table-entry . "</entry>\n")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-docbook) - -(defcustom muse-docbook-encoding-default 'utf-8 - "The default Emacs buffer encoding to use in published files. -This will be used if no special characters are found." - :type 'symbol - :group 'muse-docbook) - -(defcustom muse-docbook-charset-default "utf-8" - "The default DocBook XML charset to use if no translation is -found in `muse-docbook-encoding-map'." - :type 'string - :group 'muse-docbook) - -(defun muse-docbook-encoding () - (muse-xml-transform-content-type - (or (and (boundp 'buffer-file-coding-system) - buffer-file-coding-system) - muse-docbook-encoding-default) - muse-docbook-charset-default)) - -(defun muse-docbook-markup-paragraph () - (catch 'bail-out - (let ((end (copy-marker (match-end 0) t))) - (goto-char (match-beginning 0)) - (when (save-excursion - (save-match-data - (and (not (get-text-property (max (point-min) (1- (point))) - 'muse-no-paragraph)) - (re-search-backward - "<\\(/?\\)\\(para\\|footnote\\|literallayout\\)[ >]" - nil t) - (cond ((string= (match-string 2) "literallayout") - (and (not (string= (match-string 1) "/")) - (throw 'bail-out t))) - ((string= (match-string 2) "para") - (and - (not (string= (match-string 1) "/")) - ;; don't mess up nested lists - (not (and (muse-looking-back "<listitem>") - (throw 'bail-out t))))) - ((string= (match-string 2) "footnote") - (string= (match-string 1) "/")) - (t nil))))) - (when (get-text-property (1- (point)) 'muse-end-list) - (goto-char (previous-single-property-change (1- (point)) - 'muse-end-list))) - (muse-insert-markup "</para>")) - (goto-char end)) - (cond - ((eobp) - (unless (bolp) - (insert "\n"))) - ((get-text-property (point) 'muse-no-paragraph) - (forward-char 1) - nil) - ((eq (char-after) ?\<) - (when (looking-at (concat "<\\(emphasis\\|systemitem\\|inlinemediaobject" - "\\|u?link\\|anchor\\|email\\)[ >]")) - (muse-insert-markup "<para>"))) - (t - (muse-insert-markup "<para>"))))) - -(defun muse-docbook-get-author (&optional author) - "Split the AUTHOR directive into separate fields. -AUTHOR should be of the form: \"Firstname Other Names Lastname\", -and anything after `Firstname' is optional." - (setq author (save-match-data (split-string author))) - (let ((num-el (length author))) - (cond ((eq num-el 1) - (concat "<firstname>" (car author) "</firstname>")) - ((eq num-el 2) - (concat "<firstname>" (nth 0 author) "</firstname>" - "<surname>" (nth 1 author) "</surname>")) - ((eq num-el 3) - (concat "<firstname>" (nth 0 author) "</firstname>" - "<othername>" (nth 1 author) "</othername>" - "<surname>" (nth 2 author) "</surname>")) - (t - (let (first last) - (setq first (car author)) - (setq author (nreverse (cdr author))) - (setq last (car author)) - (setq author (nreverse (cdr author))) - (concat "<firstname>" first "</firstname>" - "<othername>" - (mapconcat 'identity author " ") - "</othername>" - "<surname>" last "</surname>")))))) - -(defun muse-docbook-fixup-images () - (goto-char (point-min)) - (while (re-search-forward (concat "<imagedata fileref=\"[^\"]+\"" - " format=\"\\([^\"]+\\)\" />$") - nil t) - (replace-match (upcase (match-string 1)) t t nil 1))) - -(defun muse-docbook-fixup-citations () - ;; remove the role attribute if there is no role - (goto-char (point-min)) - (while (re-search-forward "<\\(citation role=\"nil\"\\)>" nil t) - (replace-match "citation" t t nil 1)) - ;; replace colons in multi-head citations with semicolons - (goto-char (point-min)) - (while (re-search-forward "<citation.*>" nil t) - (let ((start (point)) - (end (re-search-forward "</citation>"))) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward "," nil t) - (replace-match ";")))))) - -(defun muse-docbook-munge-buffer () - (muse-docbook-fixup-images) - (muse-docbook-fixup-citations)) - -(defun muse-docbook-entities () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "<citation" nil t) - (concat - " [\n<!ENTITY bibliography SYSTEM \"" - (if (string-match ".short$" (muse-page-name)) - (substring (muse-page-name) 0 -6) - (muse-page-name)) - ".bib.xml\">\n]") - ""))) - -(defun muse-docbook-bibliography () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "<citation" nil t) - "&bibliography;\n" - ""))) - -(defun muse-docbook-finalize-buffer () - (when (boundp 'buffer-file-coding-system) - (when (memq buffer-file-coding-system '(no-conversion undecided-unix)) - ;; make it agree with the default charset - (setq buffer-file-coding-system muse-docbook-encoding-default)))) - -;;; Register the Muse DocBook XML Publisher - -(muse-define-style "docbook" - :suffix 'muse-docbook-extension - :regexps 'muse-docbook-markup-regexps - :functions 'muse-docbook-markup-functions - :strings 'muse-docbook-markup-strings - :specials 'muse-xml-decide-specials - :before-end 'muse-docbook-munge-buffer - :after 'muse-docbook-finalize-buffer - :header 'muse-docbook-header - :footer 'muse-docbook-footer - :browser 'find-file) - -(provide 'muse-docbook) - -;;; muse-docbook.el ends here diff --git a/emacs.d/elisp/muse/muse-groff.el b/emacs.d/elisp/muse/muse-groff.el deleted file mode 100644 index 7218652..0000000 --- a/emacs.d/elisp/muse/muse-groff.el +++ /dev/null @@ -1,274 +0,0 @@ -;;; muse-groff.el --- publish groff -mom -mwww files - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Andrew J. Korty (ajk AT iu DOT edu) -;; Date: Tue 5-Jul-2005 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Publishing Using groff -mom -mwww -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) - -(defgroup muse-groff nil - "Rules for marking up a Muse file with groff -mom -mwww macros." - :group 'muse-publish) - -(defcustom muse-groff-extension ".groff" - "Default file extension for publishing groff -mom -mwww files." - :type 'string - :group 'muse-groff) - -(defcustom muse-groff-pdf-extension ".pdf" - "Default file extension for publishing groff -mom -mwww files to PDF." - :type 'string - :group 'muse-groff) - -(defcustom muse-groff-header - ".TITLE \"<lisp>(muse-publishing-directive \"title\")</lisp>\" -.SUBTITLE \"<lisp>(muse-publishing-directive \"date\")</lisp>\" -.AUTHOR \"<lisp>(muse-publishing-directive \"author\")</lisp>\" -.PRINTSTYLE TYPESET -.de list -. LIST \\$1 -. SHIFT_LIST \\$2 -.. -.PARA_INDENT 0 -.START -<lisp>(and muse-publish-generate-contents \".TOC\n\")</lisp>\n" - "Header used for publishing groff -mom -mwww files." - :type '(choice string file) - :group 'muse-groff) - -(defcustom muse-groff-footer " " - "Footer used for publishing groff -mom -mwww files." - :type '(choice string file) - :group 'muse-groff) - -(defcustom muse-groff-markup-regexps - `((10400 ,(concat "\\(\n</\\(blockquote\\|center\\)>\\)?\n" - "\\([" - muse-regexp-blank - "]*\n\\)+\\(<\\(blockquote\\|center\\)>\n\\)?") - 0 muse-groff-markup-paragraph)) -"List of markup regexps for identifying regions in a Muse page. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-groff) - -(defcustom muse-groff-markup-functions - '((table . muse-groff-markup-table)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-groff) - -(defcustom muse-groff-markup-tags - '() - "A list of tag specifications, for specially marking up GROFF." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-groff) - -(defcustom muse-groff-markup-strings - `((image-with-desc . "\n.MPIMG -R %s.%s\n") - (image . "\n.MPIMG -R %s.%s\n") - (image-link . "\n.\\\" %s\n.MPIMG -R %s.%s") - (url . "\n.URL %s %s\n\\z") - (link . "\n.URL %s %s\n\\z") - (email-addr . "\f[C]%s\f[]") - (emdash . "\\(em") - (rule . "\n.RULE\n") - (no-break-space . "\\h") - (line-break . "\\p") - (enddots . "....") - (dots . "...") -;; (part . "\\part{") -;; (part-end . "}") -;; (chapter . "\\chapter{") -;; (chapter-end . "}") - (section . ".HEAD \"") - (section-end . "\"") - (subsection . ".SUBHEAD \"") - (subsection-end . "\"") - (subsubsection . ".PARAHEAD \"") - (subsubsection-end . "\"") -;; (footnote . "\\c\n.FOOTNOTE\n") -;; (footnote-end . "\n.FOOTNOTE OFF\n") -;; (footnotemark . "\\footnotemark[%d]") -;; (footnotetext . "\\footnotetext[%d]{") -;; (footnotetext-end . "}") - (begin-underline . "\n.UNDERSCORE \"") - (end-underline . "\"\n") - (begin-literal . "\\fC") - (end-literal . "\\fP") - (begin-emph . "\\fI") - (end-emph . "\\fP") - (begin-more-emph . "\\fB") - (end-more-emph . "\\fP") - (begin-most-emph . "\\f(BI") - (end-most-emph . "\\fP") - (begin-verse . ".QUOTE") - (end-verse . ".QUOTE OFF") - (begin-center . "\n.CENTER\n") - (end-center . "\n.QUAD L\n") - (begin-example . ,(concat - ".QUOTE_FONT CR\n.QUOTE_INDENT 1\n"".QUOTE_SIZE -2\n" - ".UNDERLINE_QUOTES OFF\n.QUOTE")) - (end-example . ".QUOTE OFF") - (begin-quote . ".BLOCKQUOTE") - (end-quote . ".BLOCKQUOTE OFF") - (begin-cite . "") - (begin-cite-author . "") - (begin-cite-year . "") - (end-cite . "") - (begin-uli . ".list BULLET\n.SHIFT_LIST 2m\n.ITEM\n") - (end-uli . "\n.LIST OFF") - (begin-oli . ".list DIGIT\n.SHIFT_LIST 2m\n.ITEM\n") - (end-oli . "\n.LIST OFF") - (begin-ddt . "\\fB") - (begin-dde . "\\fP\n.IR 4P\n") - (end-ddt . ".IRX CLEAR")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-groff) - -(defcustom muse-groff-markup-specials - '((?\\ . "\\e")) - "A table of characters which must be represented specially." - :type '(alist :key-type character :value-type string) - :group 'muse-groff) - -(defun muse-groff-markup-paragraph () - (let ((end (copy-marker (match-end 0) t))) - (goto-char (1+ (match-beginning 0))) - (delete-region (point) end) - (unless (looking-at "\.\\(\\(\\(SUB\\|PARA\\)?HEAD \\)\\|RULE$\\)") - (muse-insert-markup ".ALD .5v\n.PP\n.ne 2\n")))) - -(defun muse-groff-protect-leading-chars () - "Protect leading periods and apostrophes from being interpreted as -command characters." - (while (re-search-forward "^[.']" nil t) - (replace-match "\\\\&\\&" t))) - -(defun muse-groff-concat-lists () - "Join like lists." - (let ((type "") - arg begin) - (while (re-search-forward "^\.LIST[ \t]+\\(.*\\)\n" nil t) - (setq arg (match-string 1)) - (if (string= arg "OFF") - (setq begin (match-beginning 0)) - (if (and begin (string= type arg)) - (delete-region begin (match-end 0)) - (setq type arg - begin 0)))))) - -(defun muse-groff-fixup-dquotes () - "Fixup double quotes." - (let ((open t)) - (while (search-forward "\"" nil t) - (unless (get-text-property (match-beginning 0) 'read-only) - (if (and (bolp) (eq (char-before) ?\n)) - (setq open t)) - (if open - (progn - (replace-match "``") - (setq open nil)) - (replace-match "''") - (setq open t)))))) - -(defun muse-groff-prepare-buffer () - (goto-char (point-min)) - (muse-groff-protect-leading-chars)) - -(defun muse-groff-munge-buffer () - (goto-char (point-min)) - (muse-groff-concat-lists)) - -(defun muse-groff-pdf-browse-file (file) - (shell-command (concat "open " file))) - -(defun muse-groff-pdf-generate (file output-path final-target) - (muse-publish-transform-output - file output-path final-target "PDF" - (function - (lambda (file output-path) - (let ((command - (format - (concat "file=%s; ext=%s; cd %s && cp $file$ext $file.ref && " - "groff -mom -mwww -t $file$ext > $file.ps && " - "pstopdf $file.ps") - (file-name-sans-extension file) - muse-groff-extension - (file-name-directory output-path)))) - (shell-command command)))) - ".ps")) - -;;; Register the Muse GROFF Publisher - -(muse-define-style "groff" - :suffix 'muse-groff-extension - :regexps 'muse-groff-markup-regexps -;;; :functions 'muse-groff-markup-functions - :strings 'muse-groff-markup-strings - :tags 'muse-groff-markup-tags - :specials 'muse-groff-markup-specials - :before 'muse-groff-prepare-buffer - :before-end 'muse-groff-munge-buffer - :header 'muse-groff-header - :footer 'muse-groff-footer - :browser 'find-file) - -(muse-derive-style "groff-pdf" "groff" - :final 'muse-groff-pdf-generate - :browser 'muse-groff-pdf-browse-file - :osuffix 'muse-groff-pdf-extension) - -(provide 'muse-groff) - -;;; muse-groff.el ends here -;; -;; Local Variables: -;; indent-tabs-mode: nil -;; End: diff --git a/emacs.d/elisp/muse/muse-html.el b/emacs.d/elisp/muse/muse-html.el deleted file mode 100644 index 6a9356b..0000000 --- a/emacs.d/elisp/muse/muse-html.el +++ /dev/null @@ -1,754 +0,0 @@ -;;; muse-html.el --- publish to HTML and XHTML - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Zhiqiang Ye (yezq AT mail DOT cbi DOT pku DOT edu DOT cn) suggested -;; appending an 'encoding="..."' fragment to the first line of the -;; sample publishing header so that when editing the resulting XHTML -;; file, Emacs would use the proper encoding. - -;; Sun Jiyang (sunyijiang AT gmail DOT com) came up with the idea for -;; the <src> tag and provided an implementation for emacs-wiki. - -;; Charles Wang (wcy123 AT gmail DOT com) provided an initial -;; implementation of the <src> tag for Muse. - -;; Clinton Ebadi (clinton AT unknownlamer DOT org) provided further -;; ideas for the implementation of the <src> tag. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse HTML Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-regexps) -(require 'muse-xml-common) - -(defgroup muse-html nil - "Options controlling the behavior of Muse HTML publishing." - :group 'muse-publish) - -(defcustom muse-html-extension ".html" - "Default file extension for publishing HTML files." - :type 'string - :group 'muse-html) - -(defcustom muse-xhtml-extension ".html" - "Default file extension for publishing XHTML files." - :type 'string - :group 'muse-html) - -(defcustom muse-html-style-sheet - "<style type=\"text/css\"> -body { - background: white; color: black; - margin-left: 3%; margin-right: 7%; -} - -p { margin-top: 1% } -p.verse { margin-left: 3% } - -.example { margin-left: 3% } - -h2 { - margin-top: 25px; - margin-bottom: 0px; -} -h3 { margin-bottom: 0px; } - </style>" - "Store your stylesheet definitions here. -This is used in `muse-html-header'. -You can put raw CSS in here or a <link> tag to an external stylesheet. -This text may contain <lisp> markup tags. - -An example of using <link> is as follows. - -<link rel=\"stylesheet\" type=\"text/css\" charset=\"utf-8\" media=\"all\" href=\"/default.css\">" - :type 'string - :group 'muse-html) - -(defcustom muse-xhtml-style-sheet - "<style type=\"text/css\"> -body { - background: white; color: black; - margin-left: 3%; margin-right: 7%; -} - -p { margin-top: 1% } -p.verse { margin-left: 3% } - -.example { margin-left: 3% } - -h2 { - margin-top: 25px; - margin-bottom: 0px; -} -h3 { margin-bottom: 0px; } - </style>" - "Store your stylesheet definitions here. -This is used in `muse-xhtml-header'. -You can put raw CSS in here or a <link> tag to an external stylesheet. -This text may contain <lisp> markup tags. - -An example of using <link> is as follows. - -<link rel=\"stylesheet\" type=\"text/css\" charset=\"utf-8\" media=\"all\" href=\"/default.css\" />" - :type 'string - :group 'muse-html) - -(defcustom muse-html-header - "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\"> -<html> - <head> - <title><lisp> - (concat (muse-publishing-directive \"title\") - (let ((author (muse-publishing-directive \"author\"))) - (if (not (string= author (user-full-name))) - (concat \" (by \" author \")\"))))</lisp></title> - <meta name=\"generator\" content=\"muse.el\"> - <meta http-equiv=\"<lisp>muse-html-meta-http-equiv</lisp>\" - content=\"<lisp>muse-html-meta-content-type</lisp>\"> - <lisp> - (let ((maintainer (muse-style-element :maintainer))) - (when maintainer - (concat \"<link rev=\\\"made\\\" href=\\\"\" maintainer \"\\\">\"))) - </lisp><lisp> - (muse-style-element :style-sheet muse-publishing-current-style) - </lisp> - </head> - <body> - <h1><lisp> - (concat (muse-publishing-directive \"title\") - (let ((author (muse-publishing-directive \"author\"))) - (if (not (string= author (user-full-name))) - (concat \" (by \" author \")\"))))</lisp></h1> - <!-- Page published by Emacs Muse begins here -->\n" - "Header used for publishing HTML files. This may be text or a filename." - :type 'string - :group 'muse-html) - -(defcustom muse-html-footer " -<!-- Page published by Emacs Muse ends here --> - </body> -</html>\n" - "Footer used for publishing HTML files. This may be text or a filename." - :type 'string - :group 'muse-html) - -(defcustom muse-xhtml-header - "<?xml version=\"1.0\" encoding=\"<lisp> - (muse-html-encoding)</lisp>\"?> -<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" - \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"> -<html xmlns=\"http://www.w3.org/1999/xhtml\"> - <head> - <title><lisp> - (concat (muse-publishing-directive \"title\") - (let ((author (muse-publishing-directive \"author\"))) - (if (not (string= author (user-full-name))) - (concat \" (by \" author \")\"))))</lisp></title> - <meta name=\"generator\" content=\"muse.el\" /> - <meta http-equiv=\"<lisp>muse-html-meta-http-equiv</lisp>\" - content=\"<lisp>muse-html-meta-content-type</lisp>\" /> - <lisp> - (let ((maintainer (muse-style-element :maintainer))) - (when maintainer - (concat \"<link rev=\\\"made\\\" href=\\\"\" maintainer \"\\\" />\"))) - </lisp><lisp> - (muse-style-element :style-sheet muse-publishing-current-style) - </lisp> - </head> - <body> - <h1><lisp> - (concat (muse-publishing-directive \"title\") - (let ((author (muse-publishing-directive \"author\"))) - (if (not (string= author (user-full-name))) - (concat \" (by \" author \")\"))))</lisp></h1> - <!-- Page published by Emacs Muse begins here -->\n" - "Header used for publishing XHTML files. This may be text or a filename." - :type 'string - :group 'muse-html) - -(defcustom muse-xhtml-footer " -<!-- Page published by Emacs Muse ends here --> - </body> -</html>\n" - "Footer used for publishing XHTML files. This may be text or a filename." - :type 'string - :group 'muse-html) - -(defcustom muse-html-anchor-on-word nil - "When true, anchors surround the closest word. This allows you -to select them in a browser (i.e. for pasting), but has the -side-effect of marking up headers in multiple colors if your -header style is different from your link style." - :type 'boolean - :group 'muse-html) - -(defcustom muse-html-table-attributes - " class=\"muse-table\" border=\"2\" cellpadding=\"5\"" - "The attribute to be used with HTML <table> tags. -Note that Muse supports insertion of raw HTML tags, as long -as you wrap the region in <literal></literal>." - :type 'string - :group 'muse-html) - -(defcustom muse-html-markup-regexps - `(;; Beginning of doc, end of doc, or plain paragraph separator - (10000 ,(concat "\\(\\(\n\\(?:[" muse-regexp-blank "]*\n\\)*" - "\\([" muse-regexp-blank "]*\n\\)\\)" - "\\|\\`\\s-*\\|\\s-*\\'\\)") - ;; this is somewhat repetitive because we only require the - ;; line just before the paragraph beginning to be not - ;; read-only - 3 muse-html-markup-paragraph)) - "List of markup rules for publishing a Muse page to HTML. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-html) - -(defcustom muse-html-markup-functions - '((anchor . muse-html-markup-anchor) - (table . muse-html-markup-table) - (footnote . muse-html-markup-footnote)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-html) - -(defcustom muse-html-markup-strings - '((image-with-desc . "<table class=\"image\" width=\"100%%\"> - <tr><td align=\"center\"><img src=\"%1%.%2%\" alt=\"%3%\"></td></tr> - <tr><td align=\"center\" class=\"image-caption\">%3%</td></tr> -</table>") - (image . "<img src=\"%s.%s\" alt=\"\">") - (image-link . "<a class=\"image-link\" href=\"%s\"> -<img src=\"%s.%s\"></a>") - (anchor-ref . "<a href=\"#%s\">%s</a>") - (url . "<a href=\"%s\">%s</a>") - (link . "<a href=\"%s\">%s</a>") - (link-and-anchor . "<a href=\"%s#%s\">%s</a>") - (email-addr . "<a href=\"mailto:%s\">%s</a>") - (anchor . "<a name=\"%1%\" id=\"%1%\">") - (emdash . "%s—%s") - (comment-begin . "<!-- ") - (comment-end . " -->") - (rule . "<hr>") - (fn-sep . "<hr>\n") - (no-break-space . " ") - (line-break . "<br>") - (enddots . "....") - (dots . "...") - (section . "<h2>") - (section-end . "</h2>") - (subsection . "<h3>") - (subsection-end . "</h3>") - (subsubsection . "<h4>") - (subsubsection-end . "</h4>") - (section-other . "<h5>") - (section-other-end . "</h5>") - (begin-underline . "<u>") - (end-underline . "</u>") - (begin-literal . "<code>") - (end-literal . "</code>") - (begin-cite . "<span class=\"citation\">") - (begin-cite-author . "<span class=\"citation-author\">") - (begin-cite-year . "<span class=\"citation-year\">") - (end-cite . "</span>") - (begin-emph . "<em>") - (end-emph . "</em>") - (begin-more-emph . "<strong>") - (end-more-emph . "</strong>") - (begin-most-emph . "<strong><em>") - (end-most-emph . "</em></strong>") - (begin-verse . "<p class=\"verse\">\n") - (verse-space . " ") - (end-verse-line . "<br>") - (end-last-stanza-line . "<br>") - (empty-verse-line . "<br>") - (end-verse . "</p>") - (begin-example . "<pre class=\"example\">") - (end-example . "</pre>") - (begin-center . "<center>\n<p>") - (end-center . "</p>\n</center>") - (begin-quote . "<blockquote>\n") - (end-quote . "\n</blockquote>") - (begin-quote-item . "<p class=\"quoted\">") - (end-quote-item . "</p>") - (begin-uli . "<ul>\n") - (end-uli . "\n</ul>") - (begin-uli-item . "<li>") - (end-uli-item . "</li>") - (begin-oli . "<ol>\n") - (end-oli . "\n</ol>") - (begin-oli-item . "<li>") - (end-oli-item . "</li>") - (begin-dl . "<dl>\n") - (end-dl . "\n</dl>") - (begin-ddt . "<dt><strong>") - (end-ddt . "</strong></dt>") - (begin-dde . "<dd>") - (end-dde . "</dd>") - (begin-table . "<table%s>\n") - (end-table . "</table>") - (begin-table-row . " <tr>\n") - (end-table-row . " </tr>\n") - (begin-table-entry . " <%s>") - (end-table-entry . "</%s>\n")) - "Strings used for marking up text as HTML. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-html) - -(defcustom muse-xhtml-markup-strings - '((image-with-desc . "<table class=\"image\" width=\"100%%\"> - <tr><td align=\"center\"><img src=\"%1%.%2%\" alt=\"%3%\" /></td></tr> - <tr><td align=\"center\" class=\"image-caption\">%3%</td></tr> -</table>") - (image . "<img src=\"%s.%s\" alt=\"\" />") - (image-link . "<a class=\"image-link\" href=\"%s\"> -<img src=\"%s.%s\" alt=\"\" /></a>") - (rule . "<hr />") - (fn-sep . "<hr />\n") - (line-break . "<br />") - (begin-underline . "<span style=\"text-decoration: underline;\">") - (end-underline . "</span>") - (begin-center . "<p style=\"text-align: center;\">\n") - (end-center . "\n</p>") - (end-verse-line . "<br />") - (end-last-stanza-line . "<br />") - (empty-verse-line . "<br />")) - "Strings used for marking up text as XHTML. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles. - -If a markup rule is not found here, `muse-html-markup-strings' is -searched." - :type '(alist :key-type symbol :value-type string) - :group 'muse-html) - -(defcustom muse-xhtml1.1-markup-strings - '((anchor . "<a id=\"%s\">")) - "Strings used for marking up text as XHTML 1.1. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles. - -If a markup rule is not found here, `muse-xhtml-markup-strings' -and `muse-html-markup-strings' are searched." - :type '(alist :key-type symbol :value-type string) - :group 'muse-html) - -(defcustom muse-html-markup-tags - '(("class" t t t muse-html-class-tag) - ("div" t t t muse-html-div-tag) - ("src" t t nil muse-html-src-tag)) - "A list of tag specifications, for specially marking up HTML." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-html) - -(defcustom muse-html-meta-http-equiv "Content-Type" - "The http-equiv attribute used for the HTML <meta> tag." - :type 'string - :group 'muse-html) - -(defcustom muse-html-meta-content-type "text/html" - "The content type used for the HTML <meta> tag. -If you are striving for XHTML 1.1 compliance, you may want to -change this to \"application/xhtml+xml\"." - :type 'string - :group 'muse-html) - -(defcustom muse-html-meta-content-encoding (if (featurep 'mule) - 'detect - "iso-8859-1") - "The charset to append to the HTML <meta> tag. -If set to the symbol 'detect, use `muse-html-encoding-map' to try -and determine the HTML charset from emacs's coding. If set to a -string, this string will be used to force a particular charset" - :type '(choice string symbol) - :group 'muse-html) - -(defcustom muse-html-encoding-default 'iso-8859-1 - "The default Emacs buffer encoding to use in published files. -This will be used if no special characters are found." - :type 'symbol - :group 'muse-html) - -(defcustom muse-html-charset-default "iso-8859-1" - "The default HTML meta charset to use if no translation is found in -`muse-html-encoding-map'." - :type 'string - :group 'muse-html) - -(defcustom muse-html-src-allowed-modes t - "Modes that we allow the <src> tag to colorize. -If t, permit the <src> tag to colorize any mode. - -If a list of mode names, such as '(\"html\" \"latex\"), and the -lang argument to <src> is not in the list, then use fundamental -mode instead." - :type '(choice (const :tag "Any" t) - (repeat (string :tag "Mode"))) - :group 'muse-html) - -(defun muse-html-insert-anchor (anchor) - "Insert an anchor, either around the word at point, or within a tag." - (skip-chars-forward (concat muse-regexp-blank "\n")) - (if (looking-at (concat "<\\([^" muse-regexp-blank "/>\n]+\\)>")) - (let ((tag (match-string 1))) - (goto-char (match-end 0)) - (muse-insert-markup (muse-markup-text 'anchor anchor)) - (when muse-html-anchor-on-word - (or (and (search-forward (format "</%s>" tag) - (muse-line-end-position) t) - (goto-char (match-beginning 0))) - (forward-word 1))) - (muse-insert-markup "</a>")) - (muse-insert-markup (muse-markup-text 'anchor anchor)) - (when muse-html-anchor-on-word - (forward-word 1)) - (muse-insert-markup "</a>\n"))) - -(defun muse-html-markup-anchor () - (unless (get-text-property (match-end 1) 'muse-link) - (save-match-data - (muse-html-insert-anchor (match-string 2))) - (match-string 1))) - -(defun muse-html-markup-paragraph () - (let ((end (copy-marker (match-end 0) t))) - (goto-char (match-beginning 0)) - (when (save-excursion - (save-match-data - (and (not (get-text-property (max (point-min) (1- (point))) - 'muse-no-paragraph)) - (re-search-backward "<\\(/?\\)p[ >]" nil t) - (not (string-equal (match-string 1) "/"))))) - (when (get-text-property (1- (point)) 'muse-end-list) - (goto-char (previous-single-property-change (1- (point)) - 'muse-end-list))) - (muse-insert-markup "</p>")) - (goto-char end)) - (cond - ((eobp) - (unless (bolp) - (insert "\n"))) - ((get-text-property (point) 'muse-no-paragraph) - (forward-char 1) - nil) - ((eq (char-after) ?\<) - (cond - ((looking-at "<\\(em\\|strong\\|code\\|span\\)[ >]") - (muse-insert-markup "<p>")) - ((looking-at "<a ") - (if (looking-at "<a[^>\n]+><img") - (muse-insert-markup "<p class=\"image-link\">") - (muse-insert-markup "<p>"))) - ((looking-at "<img[ >]") - (muse-insert-markup "<p class=\"image\">")) - (t - (forward-char 1) - nil))) - ((muse-looking-back "\\(</h[1-4]>\\|<hr>\\)\n\n") - (muse-insert-markup "<p class=\"first\">")) - (t - (muse-insert-markup "<p>")))) - -(defun muse-html-markup-footnote () - (cond - ((get-text-property (match-beginning 0) 'muse-link) - nil) - ((= (muse-line-beginning-position) (match-beginning 0)) - (prog1 - (let ((text (match-string 1))) - (muse-insert-markup - (concat "<p class=\"footnote\">" - "<a class=\"footnum\" name=\"fn." text - "\" href=\"#fnr." text "\">" - text ".</a>"))) - (save-excursion - (save-match-data - (let* ((beg (goto-char (match-end 0))) - (end (and (search-forward "\n\n" nil t) - (prog1 - (copy-marker (match-beginning 0)) - (goto-char beg))))) - (while (re-search-forward (concat "^[" - muse-regexp-blank - "]+\\([^\n]\\)") - end t) - (replace-match "\\1" t))))) - (replace-match ""))) - (t (let ((text (match-string 1))) - (muse-insert-markup - (concat "<sup><a class=\"footref\" name=\"fnr." text - "\" href=\"#fn." text "\">" - text "</a></sup>"))) - (replace-match "")))) - -(defun muse-html-markup-table () - (muse-xml-markup-table muse-html-table-attributes)) - -;; Handling of tags for HTML - -(defun muse-html-strip-links (string) - "Remove all HTML links from STRING." - (muse-replace-regexp-in-string "\\(<a .*?>\\|</a>\\)" "" string nil t)) - -(defun muse-html-insert-contents (depth) - "Scan the current document and generate a table of contents at point. -DEPTH indicates how many levels of headings to include. The default is 2." - (let ((max-depth (or depth 2)) - (index 1) - base contents l end) - (save-excursion - (goto-char (point-min)) - (search-forward "Page published by Emacs Muse begins here" nil t) - (catch 'done - (while (re-search-forward "<h\\([0-9]+\\)>\\(.+?\\)</h\\1>$" nil t) - (unless (and (get-text-property (point) 'read-only) - (not (get-text-property (match-beginning 0) - 'muse-contents))) - (remove-text-properties (match-beginning 0) (match-end 0) - '(muse-contents nil)) - (setq l (1- (string-to-number (match-string 1)))) - (if (null base) - (setq base l) - (if (< l base) - (throw 'done t))) - (when (<= l max-depth) - ;; escape specials now before copying the text, so that we - ;; can deal sanely with both emphasis in titles and - ;; special characters - (goto-char (match-end 2)) - (setq end (point-marker)) - (muse-publish-escape-specials (match-beginning 2) end - nil 'document) - (muse-publish-mark-read-only (match-beginning 2) end) - (setq contents (cons (cons l (buffer-substring-no-properties - (match-beginning 2) end)) - contents)) - (set-marker end nil) - (goto-char (match-beginning 2)) - (muse-html-insert-anchor (concat "sec" (int-to-string index))) - (setq index (1+ index))))))) - (setq index 1 contents (nreverse contents)) - (let ((depth 1) (sub-open 0) (p (point))) - (muse-insert-markup "<div class=\"contents\">\n<dl>\n") - (while contents - (muse-insert-markup "<dt>\n" - "<a href=\"#sec" (int-to-string index) "\">" - (muse-html-strip-links (cdar contents)) - "</a>\n" - "</dt>\n") - (setq index (1+ index) - depth (caar contents) - contents (cdr contents)) - (when contents - (cond - ((< (caar contents) depth) - (let ((idx (caar contents))) - (while (< idx depth) - (muse-insert-markup "</dl>\n</dd>\n") - (setq sub-open (1- sub-open) - idx (1+ idx))))) - ((> (caar contents) depth) ; can't jump more than one ahead - (muse-insert-markup "<dd>\n<dl>\n") - (setq sub-open (1+ sub-open)))))) - (while (> sub-open 0) - (muse-insert-markup "</dl>\n</dd>\n") - (setq sub-open (1- sub-open))) - (muse-insert-markup "</dl>\n</div>\n") - (muse-publish-mark-read-only p (point))))) - -(defun muse-html-denote-headings () - "Place a text property on any headings in the current buffer. -This allows the headings to be picked up later on if publishing a -table of contents." - (save-excursion - (goto-char (point-min)) - (search-forward "Page published by Emacs Muse begins here" nil t) - (while (re-search-forward "<h\\([0-9]+\\)>\\(.+?\\)</h\\1>$" nil t) - (unless (get-text-property (point) 'read-only) - (add-text-properties (match-beginning 0) (match-end 0) - '(muse-contents t)))))) - -(defun muse-html-class-tag (beg end attrs) - (let ((name (cdr (assoc "name" attrs)))) - (when name - (goto-char beg) - (muse-insert-markup "<span class=\"" name "\">") - (save-excursion - (goto-char end) - (muse-insert-markup "</span>"))))) - -(defun muse-html-div-tag (beg end attrs) - "Publish a <div> tag for HTML." - (let ((id (cdr (assoc "id" attrs))) - (style (cdr (assoc "style" attrs)))) - (when (or id style) - (goto-char beg) - (if (null id) - (muse-insert-markup "<div style=\"" style "\">") - (muse-insert-markup "<div id=\"" id "\">")) - (save-excursion - (goto-char end) - (muse-insert-markup "</div>"))))) - -(defun muse-html-src-tag (beg end attrs) - "Publish the region using htmlize. -The language to use may be specified by the \"lang\" attribute. - -Muse will look for a function named LANG-mode, where LANG is the -value of the \"lang\" attribute. - -This tag requires htmlize 1.34 or later in order to work." - (if (condition-case nil - (progn - (require 'htmlize) - (if (fboundp 'htmlize-region-for-paste) - nil - (muse-display-warning - (concat "The `htmlize-region-for-paste' function was not" - " found.\nThis is available in htmlize.el 1.34" - " or later.")) - t)) - (error nil t)) - ;; if htmlize.el was not found, treat this like an example tag - (muse-publish-example-tag beg end) - (muse-publish-ensure-block beg end) - (let* ((lang (cdr (assoc "lang" attrs))) - (mode (or (and (not (eq muse-html-src-allowed-modes t)) - (not (member lang muse-html-src-allowed-modes)) - 'fundamental-mode) - (intern-soft (concat lang "-mode")))) - (text (muse-delete-and-extract-region beg end)) - (htmltext - (with-temp-buffer - (insert text) - (if (functionp mode) - (funcall mode) - (fundamental-mode)) - (font-lock-fontify-buffer) - ;; silence the byte-compiler - (when (fboundp 'htmlize-region-for-paste) - ;; transform the region to HTML - (htmlize-region-for-paste (point-min) (point-max)))))) - (save-restriction - (narrow-to-region (point) (point)) - (insert htmltext) - (goto-char (point-min)) - (re-search-forward "<pre\\([^>]*\\)>\n?" nil t) - (replace-match "<pre class=\"src\">") - (goto-char (point-max)) - (muse-publish-mark-read-only (point-min) (point-max)))))) - -;; Register the Muse HTML Publisher - -(defun muse-html-browse-file (file) - (browse-url (concat "file:" file))) - -(defun muse-html-encoding () - (if (stringp muse-html-meta-content-encoding) - muse-html-meta-content-encoding - (muse-xml-transform-content-type - (or (and (boundp 'buffer-file-coding-system) - buffer-file-coding-system) - muse-html-encoding-default) - muse-html-charset-default))) - -(defun muse-html-prepare-buffer () - (make-local-variable 'muse-html-meta-http-equiv) - (set (make-local-variable 'muse-html-meta-content-type) - (if (save-match-data - (string-match "charset=" muse-html-meta-content-type)) - muse-html-meta-content-type - (concat muse-html-meta-content-type "; charset=" - (muse-html-encoding))))) - -(defun muse-html-munge-buffer () - (if muse-publish-generate-contents - (progn - (goto-char (car muse-publish-generate-contents)) - (muse-html-insert-contents (cdr muse-publish-generate-contents)) - (setq muse-publish-generate-contents nil)) - (muse-html-denote-headings))) - -(defun muse-html-finalize-buffer () - (when (and (boundp 'buffer-file-coding-system) - (memq buffer-file-coding-system '(no-conversion undecided-unix))) - ;; make it agree with the default charset - (setq buffer-file-coding-system muse-html-encoding-default))) - -;;; Register the Muse HTML and XHTML Publishers - -(muse-define-style "html" - :suffix 'muse-html-extension - :regexps 'muse-html-markup-regexps - :functions 'muse-html-markup-functions - :strings 'muse-html-markup-strings - :tags 'muse-html-markup-tags - :specials 'muse-xml-decide-specials - :before 'muse-html-prepare-buffer - :before-end 'muse-html-munge-buffer - :after 'muse-html-finalize-buffer - :header 'muse-html-header - :footer 'muse-html-footer - :style-sheet 'muse-html-style-sheet - :browser 'muse-html-browse-file) - -(muse-derive-style "xhtml" "html" - :suffix 'muse-xhtml-extension - :strings 'muse-xhtml-markup-strings - :header 'muse-xhtml-header - :footer 'muse-xhtml-footer - :style-sheet 'muse-xhtml-style-sheet) - -;; xhtml1.0 is an alias for xhtml -(muse-derive-style "xhtml1.0" "xhtml") - -;; xhtml1.1 has some quirks that need attention from us -(muse-derive-style "xhtml1.1" "xhtml" - :strings 'muse-xhtml1.1-markup-strings) - -(provide 'muse-html) - -;;; muse-html.el ends here diff --git a/emacs.d/elisp/muse/muse-http.el b/emacs.d/elisp/muse/muse-http.el deleted file mode 100644 index 40bd1cb..0000000 --- a/emacs.d/elisp/muse/muse-http.el +++ /dev/null @@ -1,239 +0,0 @@ -;;; muse-http.el --- publish HTML files over HTTP - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Publishing HTML over HTTP (using httpd.el) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-html) -(require 'muse-project) -(require 'httpd) -(require 'cgi) - -(defgroup muse-http nil - "Options controlling the behavior of Emacs Muse over HTTP." - :group 'press) - -(defcustom muse-http-maintainer (concat "webmaster@" (system-name)) - "The maintainer address to use for the HTTP 'From' field." - :type 'string - :group 'muse-http) - -(defcustom muse-http-publishing-style "html" - "The style to use when publishing projects over http." - :type 'string - :group 'muse-http) - -(defcustom muse-http-max-cache-size 64 - "The number of pages to cache when serving over HTTP. -This only applies if set while running the persisted invocation -server. See main documentation for the `muse-http' -customization group." - :type 'integer - :group 'muse-http) - -(defvar muse-buffer-mtime nil) -(make-variable-buffer-local 'muse-buffer-mtime) - -(defun muse-sort-buffers (l r) - (let ((l-mtime (with-current-buffer l muse-buffer-mtime)) - (r-mtime (with-current-buffer r muse-buffer-mtime))) - (cond - ((and (null l-mtime) (null r-mtime)) l) - ((null l-mtime) r) - ((null r-mtime) l) - (t (muse-time-less-p r-mtime l-mtime))))) - -(defun muse-winnow-list (entries &optional predicate) - "Return only those ENTRIES for which PREDICATE returns non-nil." - (let ((flist (list t))) - (let ((entry entries)) - (while entry - (if (funcall predicate (car entry)) - (nconc flist (list (car entry)))) - (setq entry (cdr entry)))) - (cdr flist))) - -(defun muse-http-prune-cache () - "If the page cache has become too large, prune it." - (let* ((buflist - (sort (muse-winnow-list (buffer-list) - (function - (lambda (buf) - (with-current-buffer buf - muse-buffer-mtime)))) - 'muse-sort-buffers)) - (len (length buflist))) - (while (> len muse-http-max-cache-size) - (kill-buffer (car buflist)) - (setq len (1- len))))) - -(defvar muse-http-serving-p nil) - -(defun muse-http-send-buffer (&optional modified code msg) - "Markup and send the contents of the current buffer via HTTP." - (httpd-send (or code 200) (or msg "OK") - "Server: muse.el/" muse-version httpd-endl - "Connection: close" httpd-endl - "MIME-Version: 1.0" httpd-endl - "Date: " (format-time-string "%a, %e %b %Y %T %Z") - httpd-endl - "From: " muse-http-maintainer httpd-endl) - (when modified - (httpd-send-data "Last-Modified: " - (format-time-string "%a, %e %b %Y %T %Z" modified) - httpd-endl)) - (httpd-send-data "Content-Type: text/html; charset=iso-8859-1" httpd-endl - "Content-Length: " (number-to-string (1- (point-max))) - httpd-endl httpd-endl - (buffer-string)) - (httpd-send-eof)) - -(defun muse-http-reject (title msg &optional annotation) - (muse-with-temp-buffer - (insert msg ".\n") - (if annotation - (insert annotation "\n")) - (muse-publish-markup-buffer title muse-http-publishing-style) - (muse-http-send-buffer nil 404 msg))) - -(defun muse-http-prepare-url (target explicit) - (save-match-data - (unless (or (not explicit) - (string-match muse-url-regexp target) - (string-match muse-image-regexp target) - (string-match muse-file-regexp target)) - (setq target (concat "page?" target - "&project=" muse-http-serving-p)))) - (muse-publish-read-only target)) - -(defun muse-http-render-page (name) - "Render the Muse page identified by NAME. -When serving from a dedicated Emacs process (see the httpd-serve -script), a maximum of `muse-http-max-cache-size' pages will be -cached in memory to speed up serving time." - (let ((file (muse-project-page-file name muse-http-serving-p)) - (muse-publish-url-transforms - (cons 'muse-http-prepare-url muse-publish-url-transforms)) - (inhibit-read-only t)) - (when file - (with-current-buffer (get-buffer-create file) - (let ((modified-time (nth 5 (file-attributes file))) - (muse-publishing-current-file file) - muse-publishing-current-style) - (when (or (null muse-buffer-mtime) - (muse-time-less-p muse-buffer-mtime modified-time)) - (erase-buffer) - (setq muse-buffer-mtime modified-time)) - (goto-char (point-max)) - (when (bobp) - (muse-insert-file-contents file t) - (let ((styles (cddr (muse-project muse-http-serving-p))) - style) - (while (and styles (null style)) - (let ((include-regexp - (muse-style-element :include (car styles))) - (exclude-regexp - (muse-style-element :exclude (car styles)))) - (when (and (or (and (null include-regexp) - (null exclude-regexp)) - (if include-regexp - (string-match include-regexp file) - (not (string-match exclude-regexp file)))) - (not (muse-project-private-p file))) - (setq style (car styles)) - (while (muse-style-element :base style) - (setq style - (muse-style (muse-style-element :base style)))) - (if (string= (car style) muse-http-publishing-style) - (setq style (car styles)) - (setq style nil)))) - (setq styles (cdr styles))) - (muse-publish-markup-buffer - name (or style muse-http-publishing-style)))) - (set-buffer-modified-p nil) - (muse-http-prune-cache) - (current-buffer)))))) - -(defun muse-http-transmit-page (name) - "Render the Muse page identified by NAME. -When serving from a dedicated Emacs process (see the httpd-serve -script), a maximum of `muse-http-max-cache-size' pages will be -cached in memory to speed up serving time." - (let ((inhibit-read-only t) - (buffer (muse-http-render-page name))) - (if buffer - (with-current-buffer buffer - (muse-http-send-buffer muse-buffer-mtime))))) - -(defvar httpd-vars nil) - -(defsubst httpd-var (var) - "Return value of VAR as a URL variable. If VAR doesn't exist, nil." - (cdr (assoc var httpd-vars))) - -(defsubst httpd-var-p (var) - "Return non-nil if VAR was passed as a URL variable." - (not (null (assoc var httpd-vars)))) - -(defun muse-http-serve (page &optional content) - "Serve the given PAGE from this press server." - ;; index.html is really a reference to the project home page - (if (and muse-project-alist - (string-match "\\`index.html?\\'" page)) - (setq page (concat "page?" - (muse-get-keyword :default - (cadr (car muse-project-alist)))))) - ;; handle the actual request - (let ((vc-follow-symlinks t) - (muse-publish-report-threshhold nil) - muse-http-serving-p - httpd-vars) - (save-excursion - ;; process any CGI variables, if cgi.el is available - (if (string-match "\\`\\([^&]+\\)&" page) - (setq httpd-vars (cgi-decode (substring page (match-end 0))) - page (match-string 1 page))) - (unless (setq muse-http-serving-p (httpd-var "project")) - (let ((project (car muse-project-alist))) - (setq muse-http-serving-p (car project)) - (setq httpd-vars (cons (cons "project" (car project)) - httpd-vars)))) - (if (and muse-http-serving-p - (string-match "\\`page\\?\\(.+\\)" page)) - (muse-http-transmit-page (match-string 1 page)))))) - -(if (featurep 'httpd) - (httpd-add-handler "\\`\\(index\\.html?\\|page\\(\\?\\|\\'\\)\\)" - 'muse-http-serve)) - -(provide 'muse-http) - -;;; muse-http.el ends here diff --git a/emacs.d/elisp/muse/muse-ikiwiki.el b/emacs.d/elisp/muse/muse-ikiwiki.el deleted file mode 100644 index a664880..0000000 --- a/emacs.d/elisp/muse/muse-ikiwiki.el +++ /dev/null @@ -1,219 +0,0 @@ -;;; muse-ikiwiki.el --- integrate with Ikiwiki - -;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Ikiwiki Integration -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse) -(require 'muse-html) -(require 'muse-ipc) -(require 'muse-publish) - -(eval-when-compile - (require 'muse-colors)) - -(defgroup muse-ikiwiki nil - "Options controlling the behavior of Muse integration with Ikiwiki." - :group 'muse-publish) - -(defcustom muse-ikiwiki-header "" - "Header used for publishing Ikiwiki output files. -This may be text or a filename." - :type 'string - :group 'muse-ikiwiki) - -(defcustom muse-ikiwiki-footer "" - "Footer used for publishing Ikiwiki output files. -This may be text or a filename." - :type 'string - :group 'muse-ikiwiki) - -(defcustom muse-ikiwiki-markup-regexps - `(;; Ikiwiki directives - (1350 ,(concat "\\(\\\\?\\)\\[\\[!""\\(?:-\\|\\w\\)+" - "\\([" muse-regexp-blank "\n]+" - "\\(?:\\(?:\\(?:-\\|\\w\\)+=\\)?" - "\\(?:\"\"\".*?\"\"\"\\|\"[^\"]+\"" - "\\|[^]" muse-regexp-blank "\n]+\\)" - "[" muse-regexp-blank "\n]*\\)*\\)?\\]\\]") - 0 muse-ikiwiki-markup-directive)) - "List of markup rules for publishing Ikiwiki markup on Muse pages. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-ikiwiki) - -;;; Publishing - -(defun muse-ikiwiki-markup-directive () - "Handle publishing of an Ikiwiki directive." - (unless (get-text-property (match-beginning 0) 'read-only) - (add-text-properties (match-beginning 0) (match-end 0) - '(muse-no-paragraph t)) - (muse-publish-mark-read-only (match-beginning 0) (match-end 0)))) - -(defun muse-ikiwiki-publish-buffer (name title &optional style) - "Publish a buffer for Ikiwki. -The name of the corresponding file is NAME. -The name of the style is given by STYLE. It defaults to \"ikiwiki\"." - (unless style (setq style "ikiwiki")) - (unless title (setq title (muse-page-name name))) - (let ((muse-batch-publishing-p t) - (muse-publishing-current-file name) - (muse-publishing-current-output-path name) - (muse-publishing-current-style style) - (font-lock-verbose nil) - (vc-handled-backends nil)) ; don't activate VC when publishing files - (run-hooks 'muse-before-publish-hook) - (let ((muse-inhibit-before-publish-hook t)) - (muse-publish-markup-buffer title style)))) - -(defun muse-ikiwiki-publish-file (file name &optional style) - "Publish a single file for Ikiwiki. -The name of the real file is NAME, and the name of the temporary -file containing the content is FILE. -The name of the style is given by STYLE. It defaults to \"ikiwiki\"." - (if (not (stringp file)) - (message "Error: No file given to publish") - (unless style - (setq style "ikiwiki")) - (let ((output-path file) - (target file) - (vc-handled-backends nil) ; don't activate VC when publishing files - auto-mode-alist - muse-current-output-style) - (setq auto-mode-alist - (delete (cons (concat "\\." muse-file-extension "\\'") - 'muse-mode-choose-mode) - auto-mode-alist)) - (setq muse-current-output-style (list :base style :path file)) - (muse-with-temp-buffer - (muse-insert-file-contents file) - (muse-ikiwiki-publish-buffer name nil style) - (when (muse-write-file output-path t) - (muse-style-run-hooks :final style file output-path target)))))) - -(defun muse-ikiwiki-start-server (port) - "Start Muse IPC server, initializing with the client on PORT." - (muse-ipc-start "foo" #'muse-ikiwiki-publish-buffer port)) - -;;; Colors - -(defface muse-ikiwiki-directive - '((((class color) (background light)) - (:foreground "dark green")) - (((class color) (background dark)) - (:foreground "green"))) - "Face for Ikiwiki directives." - :group 'muse-ikiwiki) - -(defun muse-colors-ikiwiki-directive () - "Color ikiwiki directives." - (let ((start (match-beginning 0))) - (unless (or (eq (get-text-property start 'invisible) 'muse) - (get-text-property start 'muse-comment) - (get-text-property start 'muse-directive)) - ;; beginning of line or space or symbol - (save-excursion - (and - (catch 'valid - (while t - (skip-chars-forward "^\"]" muse-colors-region-end) - (cond ((eq (point) (point-max)) - (throw 'valid nil)) - ((> (point) muse-colors-region-end) - (throw 'valid nil)) - ((eq (char-after) ?\") - (if (and (< (1+ (point)) muse-colors-region-end) - (eq (char-after (1+ (point))) ?\")) - (if (and (< (+ 2 (point)) muse-colors-region-end) - (eq (char-after (+ 2 (point))) ?\")) - ;; triple-quote - (progn - (forward-char 3) - (or (and (looking-at "\"\"\"") - (goto-char (match-end 0))) - (re-search-forward - "\"\"\"" muse-colors-region-end t) - (throw 'valid nil))) - ;; empty quotes (""), which are invalid - (throw 'valid nil)) - ;; quote with content - (forward-char 1) - (skip-chars-forward "^\"" muse-colors-region-end) - (when (eq (char-after) ?\") - (forward-char 1)))) - ((eq (char-after) ?\]) - (forward-char 1) - (when (and (< (point) muse-colors-region-end) - (eq (char-after (point)) ?\])) - (forward-char 1) - (throw 'valid t))) - (t (throw 'valid nil))))) - ;; found a valid directive - (let ((end (point))) - ;; remove flyspell overlays - (when (fboundp 'flyspell-unhighlight-at) - (let ((cur start)) - (while (> end cur) - (flyspell-unhighlight-at cur) - (setq cur (1+ cur))))) - (add-text-properties start end - '(face muse-ikiwiki-directive - muse-directive t muse-no-flyspell t)) - (when (progn - (goto-char start) - (skip-chars-forward "^\n" end) - (and (eq (char-after) ?\n) - (not (= (point) end)))) - (add-text-properties start end - '(font-lock-multiline t))))))))) - -(defun muse-ikiwiki-insinuate-colors () - (add-to-list 'muse-colors-markup - '("\\[\\[!" ?\[ muse-colors-ikiwiki-directive) - nil)) - -(eval-after-load "muse-colors" '(muse-ikiwiki-insinuate-colors)) - -;; Styles -(muse-derive-style "ikiwiki" "xhtml" - :header 'muse-ikiwiki-header - :footer 'muse-ikiwiki-footer - :regexps 'muse-ikiwiki-markup-regexps) - -(provide 'muse-ikiwiki) - -;;; muse-ikiwiki.el ends here diff --git a/emacs.d/elisp/muse/muse-import-docbook.el b/emacs.d/elisp/muse/muse-import-docbook.el deleted file mode 100644 index ed1b22b..0000000 --- a/emacs.d/elisp/muse/muse-import-docbook.el +++ /dev/null @@ -1,137 +0,0 @@ -;;; muse-import-docbook.el --- convert Docbook XML into Muse format - -;; Copyright (C) 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Elena Pomohaci <e.pomohaci@gmail.com> - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; It works only for article type docbook docs and recognize -;; followings elements: article, sect1, sect2, sect3, title, - -;;; Contributors: - -;;; Code: - -(require 'muse-import-xml) - -(defvar muse-import-docbook-prefix "muse-import-docbook-" - "The name prefix for tag functions") - -(defvar muse-import-docbook-para-indent "\n\n" - "Para elements indentation (0, less than 6 spaces, more than 6 spaces)") - -(defun muse-import-docbook-reset-para-indent () - (setq muse-import-docbook-para-indent "\n\n")) - - -;;;###autoload -(defun muse-import-docbook (src dest) - "Convert the Docbook buffer SRC to Muse, writing output in the DEST buffer." - (interactive "bDocbook buffer:\nBMuse buffer:") - (setq muse-import-xml-prefix muse-import-docbook-prefix) - (setq muse-import-xml-generic-function-name "muse-import-xml-node") - (muse-import-xml src dest)) - -;;;###autoload -(defun muse-import-docbook-files (src dest) - "Convert the Docbook file SRC to Muse, writing output to the DEST file." - (interactive "fDocbook file:\nFMuse file:") - (with-temp-file dest - (muse-import-docbook (find-file-noselect src) (current-buffer)))) - - -;;; element specific functions - -(defun muse-import-docbook-get-title (node) - (let ((tit (car (xml-get-children node 'title)))) - (insert (car (cddr tit)) ?\n ?\n) - (muse-import-xml-parse-tree (xml-node-children (remove tit node))))) - - -(defun muse-import-docbook-article (node) - "Article conversion function" - (muse-import-xml-node node)) - -(defun muse-import-docbook-articleinfo (node) - "Article conversion function" - (insert "#title ") - (muse-import-docbook-get-title node) - (insert ?\n)) - - -(defalias 'muse-import-docbook-appendix 'muse-import-docbook-article) - -(defalias 'muse-import-docbook-appendixinfo 'muse-import-docbook-articleinfo) - - -(defun muse-import-docbook-sect1 (node) - "Section 1 conversion function" - (insert ?\n "* ") - (muse-import-docbook-get-title node)) - -(defun muse-import-docbook-sect2 (node) - "Section 2 conversion function" - (insert ?\n "** ") - (muse-import-docbook-get-title node)) - -(defun muse-import-docbook-sect3 (node) - "Section 3 conversion function" - (insert ?\n "*** ") - (muse-import-docbook-get-title node)) - - -(defun muse-import-docbook-graphic (node) - "Graphic conversion function. Image format is forced to PNG" - (let ((name (xml-get-attribute node 'fileref))) - (insert "\n[[img/" name ".png][" name "]]"))) - -(defun muse-import-docbook-para (node) - (insert muse-import-docbook-para-indent) - (muse-import-xml-node node)) - - -(defun muse-import-docbook-emphasis (node) - (insert "*") - (muse-import-xml-node node) - (insert "*")) - -(defun muse-import-docbook-quote (node) - (insert "\"") - (muse-import-xml-node node) - (insert "\"")) - -(defun muse-import-docbook-blockquote (node) - (setq muse-import-docbook-para-indent "\n\n ") - (muse-import-xml-node node) - (muse-import-docbook-reset-para-indent)) - -(defun muse-import-docbook-member (node) - (insert "\n> ") - (muse-import-xml-node node)) - -(defun muse-import-docbook-bridgehead (node) - (insert "\n* ") - (muse-import-xml-node node)) - -(provide 'muse-import-docbook) - -;;; muse-import-docbook.el ends here diff --git a/emacs.d/elisp/muse/muse-import-latex.el b/emacs.d/elisp/muse/muse-import-latex.el deleted file mode 100644 index 5297131..0000000 --- a/emacs.d/elisp/muse/muse-import-latex.el +++ /dev/null @@ -1,149 +0,0 @@ -;;; muse-import-latex.el --- convert a LaTex file into a Muse file - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Helper commands for converting a LaTeX file into a Muse file. - -;;; Contributors: - -;;; Code: - -(require 'muse) -(require 'muse-regexps) - -(defun muse-i-l-write-citation (note author citation pages) - (save-excursion - (goto-char (point-max)) - (if (= note 1) - (insert "\nFootnotes:\n\n")) - (let ((beg (point))) - (insert "\n[" (number-to-string note) "] " author) - (if (and citation pages) - (insert ", " citation ", " pages)) - (insert "\n") - (goto-char beg) - (while (re-search-forward (concat "p.\\\\[" muse-regexp-blank "\n]+") - nil t) - (replace-match "p.")) - (goto-char beg) - (while (re-search-forward "--" nil t) - (replace-match "-"))))) - -(defun muse-i-l-write-footnote (note text) - (save-excursion - (goto-char (point-max)) - (if (= note 1) - (insert "\nFootnotes:\n\n")) - (insert "\n[" (number-to-string note) "] " text ?\n))) - -;;;###autoload -(defun muse-import-latex () - (interactive) - (goto-char (point-min)) - (while (not (eobp)) - (cond - ((or (looking-at "^\\\\documentclass") - (looking-at "^\\\\input") - (looking-at "^\\\\begin{document}") - (looking-at "^\\\\end{document}") - (looking-at "^\\\\author") - (looking-at "^\\\\\\(med\\|big\\|small\\)skip") - (looking-at "^\\\\maketitle")) - (delete-region (point) (muse-line-end-position))) - ((looking-at "^\\\\title{\\(.+\\)}") - (delete-region (match-end 1) (muse-line-end-position)) - (delete-region (point) (match-beginning 1)) - (insert "#title "))) - (forward-line)) - (goto-char (point-min)) - (while (re-search-forward "\\\\\\(l\\)?dots{}" nil t) - (replace-match (concat (and (string= (match-string 1) "l") ".") - "..."))) - (goto-char (point-min)) - (while (re-search-forward "\\(``\\|''\\)" nil t) - (replace-match "\"")) - (goto-char (point-min)) - (while (re-search-forward "---" nil t) - (replace-match " -- ")) - (goto-char (point-min)) - (while (re-search-forward "\\\\tableofcontents" nil t) - (replace-match "<contents>")) - (goto-char (point-min)) - (while (re-search-forward "\\\\\\\\" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward "\\\\\\(sub\\)?section{\\([^}]+\\)}" nil t) - (replace-match (concat (if (string= (match-string 1) "sub") - "**" "*") - " " (match-string 2)))) - (goto-char (point-min)) - (while (re-search-forward "\\\\\\(begin\\|end\\){verse}" nil t) - (replace-match (concat "<" (if (string= (match-string 1) "end") "/") - "verse>"))) - (goto-char (point-min)) - (while (re-search-forward "\\\\\\(begin\\|end\\){quote}\n" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward - "\\\\\\(emph\\|textbf\\){\\([^}]+?\\)\\(\\\\/\\)?}" nil t) - (replace-match - (if (string= (match-string 1) "emph") "*\\2*" "**\\2**"))) - (let ((footnote-index 1)) - (goto-char (point-min)) - (while (re-search-forward - (concat "\\\\\\(q\\)?\\(footnote\\|excerpt\\)\\(np\\)?" - "\\({\\([^}]+\\)}\\)?" - "\\({\\([^}]+\\)}{\\([^}]+\\)}\\)?{\\([^}]+\\)}") nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (unless (string= (match-string 2) "footnote") - (if (null (match-string 1)) - (insert " " (match-string 9)) - (let ((b (point)) e) - (insert "\"" (match-string 9) "\"") - (setq e (point-marker)) - (save-match-data - (save-excursion - (goto-char b) - (while (< (point) e) - (if (looking-at "\\s-+") - (delete-region (match-beginning 0) - (match-end 0))) - (forward-line)))) - (set-marker e nil)))) - (insert "[" (number-to-string footnote-index) "]") - (if (string= (match-string 2) "footnote") - (muse-i-l-write-footnote footnote-index (match-string 9)) - (muse-i-l-write-citation footnote-index (match-string 5) - (match-string 7) (match-string 8))) - (setq footnote-index (1+ footnote-index)) - (delete-region beg end)))) - (goto-char (point-min)) - (while (looking-at "\n") (delete-char 1)) - (goto-char (point-min)) - (while (re-search-forward "\n\n+" nil t) - (replace-match "\n\n"))) - -(provide 'muse-import-latex) - -;;; muse-import-latex.el ends here diff --git a/emacs.d/elisp/muse/muse-import-xml.el b/emacs.d/elisp/muse/muse-import-xml.el deleted file mode 100644 index 2579ce8..0000000 --- a/emacs.d/elisp/muse/muse-import-xml.el +++ /dev/null @@ -1,88 +0,0 @@ -;;; muse-import-xml.el --- common to all from-xml converters - -;; Copyright (C) 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Elena Pomohaci <e.pomohaci@gmail.com> - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -(provide 'muse-import-xml) - -(require 'xml) -(require 'muse) - -(defvar muse-import-xml-prefix "" - "The name prefix for tag functions") - -(defvar muse-import-xml-generic-function-name "muse-import-xml-generic" - "The generic function name") - -(defun muse-import-xml-convert-to-list (buf) - "Convert xml BUF in a xml-list" - (with-temp-buffer - (insert-buffer-substring buf) - (goto-char (point-min)) - (while (re-search-forward ">[ \n\t]*<" nil t) - (replace-match "><" nil nil)) ; clean all superfluous blank characters - (xml-parse-region (point-min) - (point-max) - (current-buffer)))) - - -(defun muse-import-xml-generic (node) - "The generic function called when there is no node specific function." - (let ((name (xml-node-name node))) - (insert "<" (symbol-name name) ">") - (muse-import-xml-node node) - (insert "</" (symbol-name name) ">"))) - -(defun muse-import-xml-parse-tree (lst) - "Parse an xml tree list" - (mapc #'muse-import-xml-parse-node lst)) - -(defun muse-import-xml-parse-node (node) - "Parse a xml tree node" - (if (stringp node) - (insert (muse-replace-regexp-in-string "^[ \t]+" "" node)) - (let ((fname (intern-soft (concat muse-import-xml-prefix - (symbol-name (xml-node-name node)))))) - (if (functionp fname) - (funcall fname node) - (funcall (intern muse-import-xml-generic-function-name) node))))) - - -(defun muse-import-xml-node (node) - "Default node function" - (muse-import-xml-parse-tree (xml-node-children node))) - - -(defun muse-import-xml (src dest) - "Convert the xml SRC buffer in a muse DEST buffer" - (set-buffer (get-buffer-create dest)) - (when (fboundp 'muse-mode) - (muse-mode)) - (muse-import-xml-parse-tree (muse-import-xml-convert-to-list src))) - -;;; muse-import-xml.el ends here diff --git a/emacs.d/elisp/muse/muse-ipc.el b/emacs.d/elisp/muse/muse-ipc.el deleted file mode 100644 index 9ce8eb1..0000000 --- a/emacs.d/elisp/muse/muse-ipc.el +++ /dev/null @@ -1,194 +0,0 @@ -;;; muse-ipc.el --- publish Muse documents from other processes - -;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This file is still in alpha state. Not for production use! - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Inter-Process Communication -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(eval-when-compile (require 'cl)) - -(require 'muse) -(require 'muse-publish) - -(defgroup muse-ipc nil - "Options controlling the behavior of Muse's IPC module." - :group 'muse-publish) - -(defcustom muse-ipc-timeout 60 - "Maximum time to wait for a client to respond." - :group 'muse-ipc - :type 'number) - -(defcustom muse-ipc-ignore-done nil - "If non-nil, ignore any 'done' messages that we get from clients." - :group 'muse-ipc - :type 'boolean) - -(defvar muse-ipc-server-port nil - "Port of the Emacs server.") - -(defvar muse-ipc-server-process nil - "Process of the Emacs server.") - -(defvar muse-ipc-server-registered nil - "Whether we have successfully registered our port with the client.") - -(defun muse-ipc-init-filter (proc string) - "Handle data from client while initiating a connection." - (unless muse-ipc-server-registered - (when (string-match "\\`ok$" string) - (setq muse-ipc-server-registered t)))) - -(defun muse-ipc-delete-client (proc) - "Delete a client." - (let ((buffer (process-get proc :buffer))) - (when (and buffer (buffer-live-p buffer)) - (with-current-buffer buffer - (set-buffer-modified-p nil)) - (kill-buffer buffer))) - (when (eq (process-status proc) 'open) - (delete-process proc))) - -(defun* muse-ipc-server-filter (proc string) - "Handle data from a client after it connects." - ;; Authenticate - (unless (process-get proc :authenticated) - (if (and (string-match "\\`begin \\(.+\\)$" string) - (equal (match-string 1 string) - (process-get proc :shared-secret))) - (progn - (setq string (substring string (match-end 0))) - (process-put proc :authenticated t) - (process-send-string proc "ok\n")) - (process-send-string proc "nok\n") - (delete-process proc)) - (return-from muse-ipc-server-filter)) - - ;; Handle case where the client is sending data to be published - (when (process-get proc :sending-data) - (with-current-buffer (process-get proc :buffer) - (insert string) - (let ((buf-len (1- (point))) - (expected-len (process-get proc :data-bytes))) - (cond ((= buf-len expected-len) - (process-put proc :sending-data nil)) - ((> buf-len expected-len) - (process-send-string proc "nok\n") - (muse-ipc-delete-client proc))))) - (return-from muse-ipc-server-filter)) - - ;; Dispatch commands - (cond - ((string-match "\\`done$" string) - ;; done, close the server - (unless muse-ipc-ignore-done - (muse-ipc-stop-server))) - - ((string-match "\\`name \\(.+\\)$" string) - ;; set name - (process-put proc :file-name (match-string 1 string)) - (process-send-string proc "ok\n")) - - ((string-match "\\`title \\(.+\\)$" string) - ;; set title - (process-put proc :title (match-string 1 string)) - (process-send-string proc "ok\n")) - - (t - ;; unrecognized command - (process-send-string proc "nok\n")))) - -(defun muse-ipc-stop-server () - "Stop Muse IPC server and reset connection data." - (stop-process muse-ipc-server-process) - (delete-process muse-ipc-server-process) - (setq muse-ipc-server-port nil) - (setq muse-ipc-server-process nil)) - -(defun muse-ipc-start (shared-secret publish-fn client-port &optional server-port) - "Start an IPC connection and send a response to CLIENT-PORT. -If SERVER-PORT is provided, start the IPC server on that port, otherwise -choose a random port. - -SHARED-SECRET is used as a very minimal security measure to -authenticate the Muse IPC server during initialization, and also -any incoming clients once the server is started. - -PUBLISH-FN is the function which should be called in buffer of -the received contents. It should transform the buffer into a -published state. It must take at least two arguments. The first -argument is the full path of the file that the contents -correspond with. The second argument is the title to use when -publishing the file." - (when (stringp client-port) - (setq client-port (string-to-number client-port))) - (when (stringp server-port) - (setq server-port (string-to-number server-port))) - (setq muse-ipc-server-process - (make-network-process - :name "muse-ipc" - :buffer nil - :host 'local :service (or server-port t) - :server t :noquery t :nowait t - :plist (list :authenticated nil :shared-secret shared-secret - :publish-fn publish-fn) - :filter 'muse-ipc-server-filter)) - (unless muse-ipc-server-process - (error "Error: Could not start Muse IPC Server process")) - (set-process-coding-system muse-ipc-server-process - 'raw-text-unix 'raw-text-unix) - (setq muse-ipc-server-port - (number-to-string - (cadr (process-contact muse-ipc-server-process)))) - (let ((client-proc - (make-network-process - :name "muse-ipc-client" - :buffer nil - :host 'local :service client-port - :noquery t - :filter 'muse-ipc-init-filter))) - (setq muse-ipc-server-registered nil) - (process-send-string client-proc - (concat "begin " shared-secret "\n")) - (accept-process-output client-proc muse-ipc-timeout nil t) - (unless muse-ipc-server-registered - (error "Error: Did not register listener")) - (process-send-string client-proc - (concat "port " muse-ipc-server-port "\n")) - (stop-process client-proc) - (delete-process client-proc)) - - ;; Accept process output until the server dies - (while muse-ipc-server-process (accept-process-output nil 1))) - -(provide 'muse-ipc) - -;;; muse-ipc.el ends here diff --git a/emacs.d/elisp/muse/muse-journal.el b/emacs.d/elisp/muse/muse-journal.el deleted file mode 100644 index e523b4c..0000000 --- a/emacs.d/elisp/muse/muse-journal.el +++ /dev/null @@ -1,774 +0,0 @@ -;;; muse-journal.el --- keep and publish a journal - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; The module facilitates the keeping and publication of a journal. -;; When publishing to HTML, it assumes the form of a web log, or blog. -;; -;; The input format for each entry is as follows: -;; -;; * 20040317: Title of entry -;; -;; Text for the entry. -;; -;; <qotd> -;; "You know who you are. It comes down to a simple gut check: You -;; either love what you do or you don't. Period." -- P. Bronson -;; </qotd> -;; -;; The "qotd", or Quote of the Day, is entirely optional. When -;; generated to HTML, this entry is rendered as: -;; -;; <div class="entry"> -;; <div class="entry-qotd"> -;; <h3>Quote of the Day:</h3> -;; <p>"You know who you are. It comes down to a simple gut -;; check: You either love what you do or you don't. Period." -;; -- P. Bronson</p> -;; </div> -;; <div class="entry-body"> -;; <div class="entry-head"> -;; <div class="entry-date"> -;; <span class="date">March 17, 2004</span> -;; </div> -;; <div class="entry-title"> -;; <h2>Title of entry</h2> -;; </div> -;; </div> -;; <div class="entry-text"> -;; <p>Text for the entry.</p> -;; </div> -;; </div> -;; </div> -;; -;; The plurality of "div" tags makes it possible to display the -;; entries in any form you wish, using a CSS style. -;; -;; Also, an .RDF file can be generated from your journal by publishing -;; it with the "rdf" style. It uses the first two sentences of the -;; first paragraph of each entry as its "description", and -;; autogenerates tags for linking to the various entries. - -;;; Contributors: - -;; René Stadler (mail AT renestadler DOT de) provided a patch that -;; causes dates in RSS feeds to be generated in a format that RSS -;; readers can parse. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Journal Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-html) -(require 'muse-latex) -(require 'muse-book) - -(defgroup muse-journal nil - "Rules for transforming a journal into its final form." - :group 'muse-publish) - -(defcustom muse-journal-heading-regexp - "\\(?:\\([0-9]+\\)\\(?:: \\)?\\)?\\(.+?\\)?" - "A regexp that matches a journal heading. -Paren group 1 is the ISO date, group 2 is the optional category, -and group 3 is the optional heading for the entry." - :type 'regexp - :group 'muse-journal) - -(defcustom muse-journal-date-format "%a, %e %b %Y" - "Date format to use for journal entries." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-html-heading-regexp - (concat "^<h2[^>\n]*>" muse-journal-heading-regexp "</h2>$") - "A regexp that matches a journal heading from an HTML document. -Paren group 1 is the ISO date, group 2 is the optional category, -and group 3 is the optional heading for the entry." - :type 'regexp - :group 'muse-journal) - -(defcustom muse-journal-rss-heading-regexp - (concat "^\\* " muse-journal-heading-regexp "$") - "A regexp that matches a journal heading from an HTML document. -Paren group 1 is the ISO date, group 2 is the optional category, -and group 3 is the optional heading for the entry." - :type 'regexp - :group 'muse-journal) - -(defcustom muse-journal-html-entry-template - "<div class=\"entry\"> - <a name=\"%anchor%\" style=\"text-decoration: none\"> </a> - <div class=\"entry-body\"> - <div class=\"entry-head\"> - <div class=\"entry-date\"> - <span class=\"date\">%date%</span> - </div> - <div class=\"entry-title\"> - <h2>%title%</h2> - </div> - </div> - <div class=\"entry-text\"> - <div class=\"entry-qotd\"> - <p>%qotd%</p> - </div> -%text% - </div> - </div> -</div>\n\n" - "Template used to publish individual journal entries as HTML. -This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-latex-section - "\\section*{%title% \\hfill {\\normalsize %date%}} -\\addcontentsline{toc}{chapter}{%title%}" - "Template used to publish a LaTeX section." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-latex-subsection - "\\subsection*{%title%} -\\addcontentsline{toc}{section}{%title%}" - "Template used to publish a LaTeX subsection." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-markup-tags - '(("qotd" t nil nil muse-journal-qotd-tag)) - "A list of tag specifications, for specially marking up Journal entries. -See `muse-publish-markup-tags' for more info. - -This is used by journal-latex and its related styles, as well as -the journal-rss-entry style, which both journal-rdf and -journal-rss use." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-journal) - -;; FIXME: This doesn't appear to be used. -(defun muse-journal-generate-pages () - (let ((output-dir (muse-style-element :path))) - (goto-char (point-min)) - (while (re-search-forward muse-journal-heading-regexp nil t) - (let* ((date (match-string 1)) - (category (match-string 1)) - (category-file (concat output-dir category "/index.html")) - (heading (match-string 1))) - t)))) - -(defcustom muse-journal-rdf-extension ".rdf" - "Default file extension for publishing RDF (RSS 1.0) files." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-base-url "" - "The base URL of the website referenced by the RDF file." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-header - "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" - xmlns=\"http://purl.org/rss/1.0/\" - xmlns:dc=\"http://purl.org/dc/elements/1.1/\"> - <channel rdf:about=\"<lisp>(concat (muse-style-element :base-url) - (muse-publish-link-name))</lisp>\"> - <title><lisp>(muse-publishing-directive \"title\")</lisp></title> - <link><lisp>(concat (muse-style-element :base-url) - (concat (muse-page-name) - muse-html-extension))</lisp></link> - <description><lisp>(muse-publishing-directive \"desc\")</lisp></description> - <items> - <rdf:Seq> - <rdf:li resource=\"<lisp> - (concat (muse-style-element :base-url) - (concat (muse-page-name) - muse-html-extension))</lisp>\"/> - </rdf:Seq> - </items> - </channel>\n" - "Header used for publishing RDF (RSS 1.0) files. -This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-footer - "</rdf:RDF>\n" - "Footer used for publishing RDF (RSS 1.0) files. -This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-date-format - "%Y-%m-%dT%H:%M:%S" - "Date format to use for RDF entries." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-entry-template - "\n <item rdf:about=\"%link%#%anchor%\"> - <title>%title%</title> - <description> - %desc% - </description> - <link>%link%#%anchor%</link> - <dc:date>%date%</dc:date> - <dc:creator>%maintainer%</dc:creator> - </item>\n" - "Template used to publish individual journal entries as RDF. -This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rdf-summarize-entries nil - "If non-nil, include only summaries in the RDF file, not the full data. - -The default is nil, because this annoys some subscribers." - :type 'boolean - :group 'muse-journal) - -(defcustom muse-journal-rss-extension ".xml" - "Default file extension for publishing RSS 2.0 files." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-base-url "" - "The base URL of the website referenced by the RSS file." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-header - "<\?xml version=\"1.0\" encoding=\"<lisp> - (muse-html-encoding)</lisp>\"?> -<rss version=\"2.0\"> - <channel> - <title><lisp>(muse-publishing-directive \"title\")</lisp></title> - <link><lisp>(concat (muse-style-element :base-url) - (concat (muse-page-name) - muse-html-extension))</lisp></link> - <description><lisp>(muse-publishing-directive \"desc\")</lisp></description> - <language>en-us</language> - <generator>Emacs Muse</generator>\n\n" - "Header used for publishing RSS 2.0 files. This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-footer - "\n\n </channel> -</rss>\n" - "Footer used for publishing RSS 2.0 files. This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-date-format - "%a, %d %b %Y %H:%M:%S %Z" - "Date format to use for RSS 2.0 entries." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-entry-template - "\n <item> - <title>%title%</title> - <link>%link%#%anchor%</link> - <description>%desc%</description> - <author><lisp>(muse-publishing-directive \"author\")</lisp></author> - <pubDate>%date%</pubDate> - <guid>%link%#%anchor%</guid> - %enclosure% - </item>\n" - "Template used to publish individual journal entries as RSS 2.0. -This may be text or a filename." - :type 'string - :group 'muse-journal) - -(defcustom muse-journal-rss-enclosure-types-alist - '(("mp3" . "audio/mpeg")) - "File types that are accepted as RSS enclosures. -This is an alist that maps file extension to content type. -Useful for podcasting." - :type '(alist :key-type string :value-type string) - :group 'muse-journal) - -(defcustom muse-journal-rss-summarize-entries nil - "If non-nil, include only summaries in the RSS file, not the full data. - -The default is nil, because this annoys some subscribers." - :type 'boolean - :group 'muse-journal) - -(defcustom muse-journal-rss-markup-regexps - '((10000 muse-explicit-link-regexp 0 "\\2")) - "List of markup rules for publishing a Muse journal page to RSS 2.0. -For more information on the structure of this list, see -`muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-journal) - -(defcustom muse-journal-rss-markup-functions - '((email . ignore) - (link . ignore) - (url . ignore)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-journal) - -(defun muse-journal-anchorize-title (title) - "This strips tags from TITLE, truncates TITLE at begin parenthesis, -and escapes any remaining non-alphanumeric characters." - (save-match-data - (if (string-match "(" title) - (setq title (substring title 0 (match-beginning 0)))) - (if (string-match "<[^>]+>" title) - (setq title (replace-match "" nil nil title))) - (let (pos code len ch) - (while (setq pos (string-match (concat "[^" muse-regexp-alnum "_]") - title pos)) - (setq ch (aref title pos) - code (format "%%%02X" (cond ((fboundp 'char-to-ucs) - (char-to-ucs ch)) - ((fboundp 'char-to-int) - (char-to-int ch)) - (t ch))) - len (length code) - title (concat (substring title 0 pos) - code - (when (< pos (length title)) - (substring title (1+ pos) nil))) - pos (+ len pos))) - title))) - -(defun muse-journal-sort-entries (&optional direction) - (interactive "P") - (sort-subr - direction - (function - (lambda () - (if (re-search-forward "^\\* [0-9]+" nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max))))) - (function - (lambda () - (if (re-search-forward "^\\* [0-9]+" nil t) - (goto-char (1- (match-beginning 0))) - (goto-char (point-max))))) - (function - (lambda () - (forward-char 2))) - (function - (lambda () - (end-of-line))))) - -(defun muse-journal-qotd-tag (beg end) - (muse-publish-ensure-block beg end) - (muse-insert-markup (muse-markup-text 'begin-quote)) - (muse-insert-markup (muse-markup-text 'begin-quote-item)) - (goto-char end) - (muse-insert-markup (muse-markup-text 'end-quote-item)) - (muse-insert-markup (muse-markup-text 'end-quote))) - -(defun muse-journal-html-munge-buffer () - (goto-char (point-min)) - (let ((heading-regexp muse-journal-html-heading-regexp) - (inhibit-read-only t)) - (while (re-search-forward heading-regexp nil t) - (let* ((date (match-string 1)) - (orig-date date) - (title (match-string 2)) - (clean-title title) - datestamp qotd text) - (delete-region (match-beginning 0) (match-end 0)) - (if clean-title - (save-match-data - (while (string-match "\\(^<[^>]+>\\|<[^>]+>$\\)" clean-title) - (setq clean-title (replace-match "" nil nil clean-title))))) - (save-match-data - (when (and date - (string-match - (concat "\\`\\([1-9][0-9][0-9][0-9]\\)[./]?" - "\\([0-1][0-9]\\)[./]?\\([0-3][0-9]\\)") date)) - (setq datestamp - (encode-time - 0 0 0 - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date)) - (string-to-number (match-string 1 date)) - nil) - date (concat (format-time-string - muse-journal-date-format datestamp) - (substring date (match-end 0)))))) - (save-restriction - (narrow-to-region - (point) (if (re-search-forward - (concat "\\(^<hr>$\\|" - heading-regexp "\\)") nil t) - (match-beginning 0) - (point-max))) - (goto-char (point-max)) - (while (and (not (bobp)) - (eq ?\ (char-syntax (char-before)))) - (delete-char -1)) - (goto-char (point-min)) - (while (and (not (eobp)) - (eq ?\ (char-syntax (char-after)))) - (delete-char 1)) - (save-excursion - (when (search-forward "<qotd>" nil t) - (let ((tag-beg (match-beginning 0)) - (beg (match-end 0)) - end) - (re-search-forward "</qotd>\n*") - (setq end (point-marker)) - (save-restriction - (narrow-to-region beg (match-beginning 0)) - (muse-publish-escape-specials (point-min) (point-max) - nil 'document) - (setq qotd (buffer-substring-no-properties - (point-min) (point-max)))) - (delete-region tag-beg end) - (set-marker end nil)))) - (setq text (buffer-string)) - (delete-region (point-min) (point-max)) - (let ((entry muse-journal-html-entry-template)) - (muse-insert-file-or-string entry) - (muse-publish-mark-read-only (point-min) (point-max)) - (goto-char (point-min)) - (while (search-forward "%date%" nil t) - (remove-text-properties (match-beginning 0) (match-end 0) - '(read-only nil rear-nonsticky nil)) - (replace-match (or date "") nil t)) - (goto-char (point-min)) - (while (search-forward "%title%" nil t) - (remove-text-properties (match-beginning 0) (match-end 0) - '(read-only nil rear-nonsticky nil)) - (replace-match (or title " ") nil t)) - (goto-char (point-min)) - (while (search-forward "%anchor%" nil t) - (replace-match (muse-journal-anchorize-title - (or clean-title orig-date)) - nil t)) - (goto-char (point-min)) - (while (search-forward "%qotd%" nil t) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (when qotd (muse-insert-markup qotd)))) - (goto-char (point-min)) - (while (search-forward "%text%" nil t) - (remove-text-properties (match-beginning 0) (match-end 0) - '(read-only nil rear-nonsticky nil)) - (replace-match text nil t)) - (when (null qotd) - (goto-char (point-min)) - (when (search-forward "<div class=\"entry-qotd\">" nil t) - (let ((beg (match-beginning 0))) - (re-search-forward "</div>\n*" nil t) - (delete-region beg (point)))))))))) - ;; indicate that we are to continue the :before-end processing - nil) - -(defun muse-journal-latex-munge-buffer () - (goto-char (point-min)) - (let ((heading-regexp - (concat "^" (regexp-quote (muse-markup-text 'section)) - muse-journal-heading-regexp - (regexp-quote (muse-markup-text 'section-end)) "$")) - (inhibit-read-only t)) - (when (re-search-forward heading-regexp nil t) - (goto-char (match-beginning 0)) - (sort-subr nil - (function - (lambda () - (if (re-search-forward heading-regexp nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max))))) - (function - (lambda () - (if (re-search-forward heading-regexp nil t) - (goto-char (1- (match-beginning 0))) - (goto-char (point-max))))) - (function - (lambda () - (forward-char 2))) - (function - (lambda () - (end-of-line))))) - (while (re-search-forward heading-regexp nil t) - (let ((date (match-string 1)) - (title (match-string 2)) - ;; FIXME: Nothing is done with qotd - qotd section) - (save-match-data - (when (and date - (string-match - (concat "\\([1-9][0-9][0-9][0-9]\\)[./]?" - "\\([0-1][0-9]\\)[./]?\\([0-3][0-9]\\)") date)) - (setq date (encode-time - 0 0 0 - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date)) - (string-to-number (match-string 1 date)) - nil) - date (format-time-string - muse-journal-date-format date)))) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (muse-insert-markup muse-journal-latex-section) - (goto-char (point-min)) - (while (search-forward "%title%" nil t) - (replace-match (or title "Untitled") nil t)) - (goto-char (point-min)) - (while (search-forward "%date%" nil t) - (replace-match (or date "") nil t)))))) - (goto-char (point-min)) - (let ((subheading-regexp - (concat "^" (regexp-quote (muse-markup-text 'subsection)) - "\\([^\n}]+\\)" - (regexp-quote (muse-markup-text 'subsection-end)) "$")) - (inhibit-read-only t)) - (while (re-search-forward subheading-regexp nil t) - (let ((title (match-string 1))) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (muse-insert-markup muse-journal-latex-subsection) - (goto-char (point-min)) - (while (search-forward "%title%" nil t) - (replace-match title nil t)))))) - ;; indicate that we are to continue the :before-end processing - nil) - -(defun muse-journal-rss-munge-buffer () - (goto-char (point-min)) - (let ((heading-regexp muse-journal-rss-heading-regexp) - (inhibit-read-only t)) - (while (re-search-forward heading-regexp nil t) - (let* ((date (match-string 1)) - (orig-date date) - (title (match-string 2)) - ;; FIXME: Nothing is done with qotd - enclosure qotd desc) - (if title - (save-match-data - (if (string-match muse-explicit-link-regexp title) - (setq enclosure (muse-get-link title) - title (muse-get-link-desc title))))) - (save-match-data - (when (and date - (string-match - (concat "\\([1-9][0-9][0-9][0-9]\\)[./]?" - "\\([0-1][0-9]\\)[./]?\\([0-3][0-9]\\)") date)) - (setq date (encode-time 0 0 0 - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date)) - (string-to-number (match-string 1 date)) - nil) - ;; make sure that date is in a format that RSS - ;; readers can handle - date (let ((system-time-locale "C")) - (format-time-string - (muse-style-element :date-format) date))))) - (save-restriction - (narrow-to-region - (match-beginning 0) - (if (re-search-forward heading-regexp nil t) - (match-beginning 0) - (if (re-search-forward "^Footnotes:" nil t) - (match-beginning 0) - (point-max)))) - (goto-char (point-min)) - (delete-region (point) (muse-line-end-position)) - (re-search-forward "</qotd>\n+" nil t) - (while (and (char-after) - (eq ?\ (char-syntax (char-after)))) - (delete-char 1)) - (let ((beg (point))) - (if (muse-style-element :summarize) - (progn - (forward-sentence 2) - (setq desc (concat (buffer-substring beg (point)) "..."))) - (save-restriction - (muse-publish-markup-buffer "rss-entry" "journal-rss-entry") - (goto-char (point-min)) - (if (re-search-forward "Page published by Emacs Muse" nil t) - (goto-char (muse-line-end-position)) - (muse-display-warning - (concat - "Cannot find 'Page published by Emacs Muse begins here'.\n" - "You will probably need this text in your header.")) - (goto-char (point-min))) - (setq beg (point)) - (if (re-search-forward "Page published by Emacs Muse" nil t) - (goto-char (muse-line-beginning-position)) - (muse-display-warning - (concat - "Cannot find 'Page published by Emacs Muse ends here'.\n" - "You will probably need this text in your footer.")) - (goto-char (point-max))) - (setq desc (buffer-substring beg (point)))))) - (unless (string= desc "") - (setq desc (concat "<![CDATA[" desc "]]>"))) - (delete-region (point-min) (point-max)) - (let ((entry (muse-style-element :entry-template))) - (muse-insert-file-or-string entry) - (goto-char (point-min)) - (while (search-forward "%date%" nil t) - (replace-match (or date "") nil t)) - (goto-char (point-min)) - (while (search-forward "%title%" nil t) - (replace-match "") - (save-restriction - (narrow-to-region (point) (point)) - (insert (or title "Untitled")) - (remove-text-properties (match-beginning 0) (match-end 0) - '(read-only nil rear-nonsticky nil)) - (let ((muse-publishing-current-style (muse-style "html"))) - (muse-publish-escape-specials (point-min) (point-max) - nil 'document)))) - (goto-char (point-min)) - (while (search-forward "%desc%" nil t) - (replace-match desc nil t)) - (goto-char (point-min)) - (while (search-forward "%enclosure%" nil t) - (replace-match - (if (null enclosure) - "" - (save-match-data - (format - "<enclosure url=\"%s\" %stype=\"%s\"/>" - (if (string-match "//" enclosure) - enclosure - (concat (muse-style-element :base-url) - enclosure)) - (let ((file - (expand-file-name enclosure - (muse-style-element :path)))) - (if (file-readable-p file) - (format "length=\"%d\" " - (nth 7 (file-attributes file))) - "")) - (if (string-match "\\.\\([^.]+\\)$" enclosure) - (let* ((ext (match-string 1 enclosure)) - (type - (assoc - ext muse-journal-rss-enclosure-types-alist))) - (if type - (cdr type) - "application/octet-stream")))))) - nil t)) - (goto-char (point-min)) - (while (search-forward "%link%" nil t) - (replace-match - (concat (muse-style-element :base-url) - (concat (muse-page-name) - muse-html-extension)) - nil t)) - (goto-char (point-min)) - (while (search-forward "%anchor%" nil t) - (replace-match - (muse-journal-anchorize-title (or title orig-date)) - nil t)) - (goto-char (point-min)) - (while (search-forward "%maintainer%" nil t) - (replace-match - (or (muse-style-element :maintainer) - (concat "webmaster@" (system-name))) - nil t))))))) - ;; indicate that we are to continue the :before-end processing - nil) - - -;;; Register the Muse Journal Publishers - -(muse-derive-style "journal-html" "html" - :before-end 'muse-journal-html-munge-buffer) - -(muse-derive-style "journal-xhtml" "xhtml" - :before-end 'muse-journal-html-munge-buffer) - -(muse-derive-style "journal-latex" "latex" - :tags 'muse-journal-markup-tags - :before-end 'muse-journal-latex-munge-buffer) - -(muse-derive-style "journal-pdf" "pdf" - :tags 'muse-journal-markup-tags - :before-end 'muse-journal-latex-munge-buffer) - -(muse-derive-style "journal-book-latex" "book-latex" - ;;:nochapters - :tags 'muse-journal-markup-tags - :before-end 'muse-journal-latex-munge-buffer) - -(muse-derive-style "journal-book-pdf" "book-pdf" - ;;:nochapters - :tags 'muse-journal-markup-tags - :before-end 'muse-journal-latex-munge-buffer) - -(muse-define-style "journal-rdf" - :suffix 'muse-journal-rdf-extension - :regexps 'muse-journal-rss-markup-regexps - :functions 'muse-journal-rss-markup-functions - :before 'muse-journal-rss-munge-buffer - :header 'muse-journal-rdf-header - :footer 'muse-journal-rdf-footer - :date-format 'muse-journal-rdf-date-format - :entry-template 'muse-journal-rdf-entry-template - :base-url 'muse-journal-rdf-base-url - :summarize 'muse-journal-rdf-summarize-entries) - -(muse-define-style "journal-rss" - :suffix 'muse-journal-rss-extension - :regexps 'muse-journal-rss-markup-regexps - :functions 'muse-journal-rss-markup-functions - :before 'muse-journal-rss-munge-buffer - :header 'muse-journal-rss-header - :footer 'muse-journal-rss-footer - :date-format 'muse-journal-rss-date-format - :entry-template 'muse-journal-rss-entry-template - :base-url 'muse-journal-rss-base-url - :summarize 'muse-journal-rss-summarize-entries) - -;; Used by `muse-journal-rss-munge-buffer' to mark up individual entries -(muse-derive-style "journal-rss-entry" "html" - :tags 'muse-journal-markup-tags) - -(provide 'muse-journal) - -;;; muse-journal.el ends here diff --git a/emacs.d/elisp/muse/muse-latex.el b/emacs.d/elisp/muse/muse-latex.el deleted file mode 100644 index e416367..0000000 --- a/emacs.d/elisp/muse/muse-latex.el +++ /dev/null @@ -1,669 +0,0 @@ -;;; muse-latex.el --- publish entries in LaTex or PDF format - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Li Daobing (lidaobing AT gmail DOT com) provided CJK support. - -;; Trent Buck (trentbuck AT gmail DOT com) gave valuable advice for -;; how to treat LaTeX specials and the like. - -;; Matthias Kegelmann (mathias DOT kegelmann AT sdm DOT de) provided a -;; scenario where we would need to respect the <contents> tag. - -;; Jean Magnan de Bornier (jean AT bornier DOT net) provided the -;; markup string for link-and-anchor. - -;; Jim Ottaway (j DOT ottaway AT lse DOT ac DOT uk) implemented slides -;; and lecture notes. - -;; Karl Berry (karl AT freefriends DOT org) suggested how to escape -;; additional special characters in image filenames. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse LaTeX Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) - -(defgroup muse-latex nil - "Rules for marking up a Muse file as a LaTeX article." - :group 'muse-publish) - -(defcustom muse-latex-extension ".tex" - "Default file extension for publishing LaTeX files." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-pdf-extension ".pdf" - "Default file extension for publishing LaTeX files to PDF." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-pdf-browser "open %s" - "The program to use when browsing a published PDF file. -This should be a format string." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-pdf-program "pdflatex" - "The program that is called to generate PDF content from LaTeX content." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-pdf-cruft - '(".aux" ".log" ".nav" ".out" ".snm" ".toc" ".vrb") - "Extensions of files to remove after generating PDF output successfully." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-header - "\\documentclass{article} - -\\usepackage[english]{babel} -\\usepackage{ucs} -\\usepackage[utf8x]{inputenc} -\\usepackage[T1]{fontenc} -\\usepackage{hyperref} -\\usepackage[pdftex]{graphicx} - -\\def\\museincludegraphics{% - \\begingroup - \\catcode`\\|=0 - \\catcode`\\\\=12 - \\catcode`\\#=12 - \\includegraphics[width=0.75\\textwidth] -} - -\\begin{document} - -\\title{<lisp>(muse-publish-escape-specials-in-string - (muse-publishing-directive \"title\") 'document)</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\maketitle - -<lisp>(and muse-publish-generate-contents - (not muse-latex-permit-contents-tag) - \"\\\\tableofcontents\n\\\\newpage\")</lisp>\n\n" - "Header used for publishing LaTeX files. This may be text or a filename." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-footer "<lisp>(muse-latex-bibliography)</lisp> -\\end{document}\n" - "Footer used for publishing LaTeX files. This may be text or a filename." - :type 'string - :group 'muse-latex) - -(defcustom muse-latexcjk-header - "\\documentclass{article} - -\\usepackage{CJK} -\\usepackage{indentfirst} -\\usepackage[CJKbookmarks=true]{hyperref} -\\usepackage[pdftex]{graphicx} - -\\begin{document} -\\begin{CJK*}<lisp>(muse-latexcjk-encoding)</lisp> - -\\title{<lisp>(muse-publish-escape-specials-in-string - (muse-publishing-directive \"title\") 'document)</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\maketitle - -<lisp>(and muse-publish-generate-contents - (not muse-latex-permit-contents-tag) - \"\\\\tableofcontents\n\\\\newpage\")</lisp>\n\n" - "Header used for publishing LaTeX files (CJK). This may be text or a -filename." - :type 'string - :group 'muse-latex) - -(defcustom muse-latexcjk-footer - "\n\\end{CJK*} -\\end{document}\n" - "Footer used for publishing LaTeX files (CJK). This may be text or a -filename." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-slides-header - "\\documentclass[ignorenonframetext]{beamer} - -\\usepackage[english]{babel} -\\usepackage{ucs} -\\usepackage[utf8x]{inputenc} -\\usepackage[T1]{fontenc} -\\usepackage{hyperref} - -\\def\\museincludegraphics{% - \\begingroup - \\catcode`\\|=0 - \\catcode`\\\\=12 - \\catcode`\\#=12 - \\includegraphics[width=0.50\\textwidth] -} - -\\title{<lisp>(muse-publish-escape-specials-in-string - (muse-publishing-directive \"title\") 'document)</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\begin{document} - -\\frame{\\titlepage} - -<lisp>(and muse-publish-generate-contents - \"\\\\frame{\\\\tableofcontents}\")</lisp>\n\n" - "Header for publishing of slides using LaTeX. -This may be text or a filename. - -You must have the Beamer extension for LaTeX installed for this to work." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-lecture-notes-header - "\\documentclass{article} -\\usepackage{beamerarticle} - -\\usepackage[english]{babel} -\\usepackage{ucs} -\\usepackage[utf8x]{inputenc} -\\usepackage[T1]{fontenc} -\\usepackage{hyperref} -\\usepackage[pdftex]{graphicx} - -\\def\\museincludegraphics{% - \\begingroup - \\catcode`\\|=0 - \\catcode`\\\\=12 - \\catcode`\\#=12 - \\includegraphics[width=0.50\\textwidth] -} - -\\title{<lisp>(muse-publish-escape-specials-in-string - (muse-publishing-directive \"title\") 'document)</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\begin{document} - -\\frame{\\titlepage} - -<lisp>(and muse-publish-generate-contents - \"\\\\frame{\\\\tableofcontents}\")</lisp>\n\n" - "Header for publishing of lecture notes using LaTeX. -This may be text or a filename. - -You must have the Beamer extension for LaTeX installed for this to work." - :type 'string - :group 'muse-latex) - -(defcustom muse-latex-markup-regexps - `(;; numeric ranges - (10000 "\\([0-9]+\\)-\\([0-9]+\\)" 0 "\\1--\\2") - - ;; be careful of closing quote pairs - (10100 "\"'" 0 "\"\\\\-'")) - "List of markup regexps for identifying regions in a Muse page. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-latex) - -(defcustom muse-latex-markup-functions - '((table . muse-latex-markup-table)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-latex) - -(defcustom muse-latex-markup-strings - '((image-with-desc . "\\begin{figure}[h] -\\centering\\museincludegraphics{%s.%s}|endgroup -\\caption{%s} -\\end{figure}") - (image . "\\begin{figure}[h] -\\centering\\museincludegraphics{%s.%s}|endgroup -\\end{figure}") - (image-link . "%% %s -\\museincludegraphics{%s.%s}|endgroup") - (anchor-ref . "\\ref{%s}") - (url . "\\url{%s}") - (url-and-desc . "\\href{%s}{%s}\\footnote{%1%}") - (link . "\\href{%s}{%s}\\footnote{%1%}") - (link-and-anchor . "\\href{%1%}{%3%}\\footnote{%1%}") - (email-addr . "\\verb|%s|") - (anchor . "\\label{%s}") - (emdash . "---") - (comment-begin . "% ") - (rule . "\\vspace{.5cm}\\hrule\\vspace{.5cm}") - (no-break-space . "~") - (line-break . "\\\\") - (enddots . "\\ldots{}") - (dots . "\\dots{}") - (part . "\\part{") - (part-end . "}") - (chapter . "\\chapter{") - (chapter-end . "}") - (section . "\\section{") - (section-end . "}") - (subsection . "\\subsection{") - (subsection-end . "}") - (subsubsection . "\\subsubsection{") - (subsubsection-end . "}") - (section-other . "\\paragraph{") - (section-other-end . "}") - (footnote . "\\footnote{") - (footnote-end . "}") - (footnotetext . "\\footnotetext[%d]{") - (begin-underline . "\\underline{") - (end-underline . "}") - (begin-literal . "\\texttt{") - (end-literal . "}") - (begin-emph . "\\emph{") - (end-emph . "}") - (begin-more-emph . "\\textbf{") - (end-more-emph . "}") - (begin-most-emph . "\\textbf{\\emph{") - (end-most-emph . "}}") - (begin-verse . "\\begin{verse}\n") - (end-verse-line . " \\\\") - (verse-space . "~~~~") - (end-verse . "\n\\end{verse}") - (begin-example . "\\begin{quote}\n\\begin{verbatim}") - (end-example . "\\end{verbatim}\n\\end{quote}") - (begin-center . "\\begin{center}\n") - (end-center . "\n\\end{center}") - (begin-quote . "\\begin{quote}\n") - (end-quote . "\n\\end{quote}") - (begin-cite . "\\cite{") - (begin-cite-author . "\\citet{") - (begin-cite-year . "\\citet{") - (end-cite . "}") - (begin-uli . "\\begin{itemize}\n") - (end-uli . "\n\\end{itemize}") - (begin-uli-item . "\\item ") - (begin-oli . "\\begin{enumerate}\n") - (end-oli . "\n\\end{enumerate}") - (begin-oli-item . "\\item ") - (begin-dl . "\\begin{description}\n") - (end-dl . "\n\\end{description}") - (begin-ddt . "\\item[") - (end-ddt . "] \\mbox{}\n")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-latex) - -(defcustom muse-latex-slides-markup-tags - '(("slide" t t nil muse-latex-slide-tag)) - "A list of tag specifications, for specially marking up LaTeX slides." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-latex) - -(defcustom muse-latexcjk-encoding-map - '((utf-8 . "{UTF8}{song}") - (japanese-iso-8bit . "[dnp]{JIS}{min}") - (chinese-big5 . "{Bg5}{bsmi}") - (mule-utf-8 . "{UTF8}{song}") - (chinese-iso-8bit . "{GB}{song}") - (chinese-gbk . "{GBK}{song}")) - "An alist mapping emacs coding systems to appropriate CJK codings. -Use the base name of the coding system (ie, without the -unix)." - :type '(alist :key-type coding-system :value-type string) - :group 'muse-latex) - -(defcustom muse-latexcjk-encoding-default "{GB}{song}" - "The default Emacs buffer encoding to use in published files. -This will be used if no special characters are found." - :type 'string - :group 'muse-latex) - -(defun muse-latexcjk-encoding () - (when (boundp 'buffer-file-coding-system) - (muse-latexcjk-transform-content-type buffer-file-coding-system))) - -(defun muse-latexcjk-transform-content-type (content-type) - "Using `muse-cjklatex-encoding-map', try and resolve an emacs coding -system to an associated CJK coding system." - (let ((match (and (fboundp 'coding-system-base) - (assoc (coding-system-base content-type) - muse-latexcjk-encoding-map)))) - (if match - (cdr match) - muse-latexcjk-encoding-default))) - -(defcustom muse-latex-markup-specials-document - '((?\\ . "\\textbackslash{}") - (?\_ . "\\textunderscore{}") - (?\< . "\\textless{}") - (?\> . "\\textgreater{}") - (?^ . "\\^{}") - (?\~ . "\\~{}") - (?\@ . "\\@") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#")) - "A table of characters which must be represented specially. -These are applied to the entire document, sans already-escaped -regions." - :type '(alist :key-type character :value-type string) - :group 'muse-latex) - -(defcustom muse-latex-markup-specials-example - '() - "A table of characters which must be represented specially. -These are applied to <example> regions. - -With the default interpretation of <example> regions, no specials -need to be escaped." - :type '(alist :key-type character :value-type string) - :group 'muse-latex) - -(defcustom muse-latex-markup-specials-literal - '((?\n . "\\\n") - (?\\ . "\\textbackslash{}") - (?_ . "\\textunderscore{}") - (?\< . "\\textless{}") - (?\> . "\\textgreater{}") - (?^ . "\\^{}") - (?\~ . "\\~{}") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#")) - "A table of characters which must be represented specially. -This applies to =monospaced text= and <code> regions." - :type '(alist :key-type character :value-type string) - :group 'muse-latex) - -(defcustom muse-latex-markup-specials-url - '((?\\ . "\\textbackslash{}") - (?\_ . "\\_") - (?\< . "\\<") - (?\> . "\\>") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#")) - "A table of characters which must be represented specially. -These are applied to URLs." - :type '(alist :key-type character :value-type string) - :group 'muse-latex) - -(defcustom muse-latex-markup-specials-image - '((?\\ . "\\\\") - (?\< . "\\<") - (?\> . "\\>") - (?\$ . "\\$") - (?\% . "\\%") - (?\{ . "\\{") - (?\} . "\\}") - (?\& . "\\&") - (?\# . "\\#") - (?\| . "\\|")) - "A table of characters which must be represented specially. -These are applied to image filenames." - :type '(alist :key-type character :value-type string) - :group 'muse-latex) - -(defun muse-latex-decide-specials (context) - "Determine the specials to escape, depending on CONTEXT." - (cond ((memq context '(underline emphasis document url-desc verbatim - footnote)) - muse-latex-markup-specials-document) - ((eq context 'image) - muse-latex-markup-specials-image) - ((memq context '(email url)) - muse-latex-markup-specials-url) - ((eq context 'literal) - muse-latex-markup-specials-literal) - ((eq context 'example) - muse-latex-markup-specials-example) - (t (error "Invalid context '%s' in muse-latex" context)))) - -(defcustom muse-latex-permit-contents-tag nil - "If nil, ignore <contents> tags. Otherwise, insert table of contents. - -Most of the time, it is best to have a table of contents on the -first page, with a new page immediately following. To make this -work with documents published in both HTML and LaTeX, we need to -ignore the <contents> tag. - -If you don't agree with this, then set this option to non-nil, -and it will do what you expect." - :type 'boolean - :group 'muse-latex) - -(defun muse-latex-markup-table () - (let* ((table-info (muse-publish-table-fields (match-beginning 0) - (match-end 0))) - (row-len (car table-info)) - (field-list (cdr table-info))) - (when table-info - (muse-insert-markup "\\begin{tabular}{" (make-string row-len ?l) "}\n") - (dolist (fields field-list) - (let ((type (car fields))) - (setq fields (cdr fields)) - (if (eq type 'hline) - (muse-insert-markup "\\hline\n") - (when (= type 3) - (muse-insert-markup "\\hline\n")) - (insert (car fields)) - (setq fields (cdr fields)) - (dolist (field fields) - (muse-insert-markup " & ") - (insert field)) - (muse-insert-markup " \\\\\n") - (when (= type 2) - (muse-insert-markup "\\hline\n"))))) - (muse-insert-markup "\\end{tabular}")))) - -;;; Tags for LaTeX - -(defun muse-latex-slide-tag (beg end attrs) - "Publish the <slide> tag in LaTeX. -This is used by the slides and lecture-notes publishing styles." - (let ((title (cdr (assoc "title" attrs)))) - (goto-char beg) - (muse-insert-markup "\\begin{frame}[fragile]\n") - (when title - (muse-insert-markup "\\frametitle{") - (insert title) - (muse-insert-markup "}\n")) - (save-excursion - (goto-char end) - (muse-insert-markup "\n\\end{frame}")))) - -;;; Post-publishing functions - -(defun muse-latex-fixup-dquotes () - "Fixup double quotes." - (goto-char (point-min)) - (let ((open t)) - (while (search-forward "\"" nil t) - (unless (get-text-property (match-beginning 0) 'read-only) - (when (or (bobp) - (eq (char-before) ?\n)) - (setq open t)) - (if open - (progn - (replace-match "``") - (setq open nil)) - (replace-match "''") - (setq open t)))))) - -(defun muse-latex-fixup-citations () - "Replace semicolons in multi-head citations with colons." - (goto-char (point-min)) - (while (re-search-forward "\\\\cite.?{" nil t) - (let ((start (point)) - (end (re-search-forward "}"))) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward ";" nil t) - (replace-match ",")))))) - -(defun muse-latex-fixup-headings () - "Remove footnotes in headings, since LaTeX does not permit them to exist. - -This can happen if there is a link in a heading, because by -default Muse will add a footnote for each link." - (goto-char (point-min)) - (while (re-search-forward "^\\\\section.?{" nil t) - (save-restriction - (narrow-to-region (match-beginning 0) (muse-line-end-position)) - (goto-char (point-min)) - (while (re-search-forward "\\\\footnote{[^}\n]+}" nil t) - (replace-match "")) - (forward-line 1)))) - -(defun muse-latex-munge-buffer () - (muse-latex-fixup-dquotes) - (muse-latex-fixup-citations) - (muse-latex-fixup-headings) - (when (and muse-latex-permit-contents-tag - muse-publish-generate-contents) - (goto-char (car muse-publish-generate-contents)) - (muse-insert-markup "\\tableofcontents"))) - -(defun muse-latex-bibliography () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "\\\\cite.?{" nil t) - (concat - "\\bibliography{" - (muse-publishing-directive "bibsource") - "}\n") - ""))) - -(defun muse-latex-pdf-browse-file (file) - (shell-command (format muse-latex-pdf-browser file))) - -(defun muse-latex-pdf-generate (file output-path final-target) - (apply - #'muse-publish-transform-output - file output-path final-target "PDF" - (function - (lambda (file output-path) - (let* ((fnd (file-name-directory output-path)) - (command (format "%s \"%s\"" - muse-latex-pdf-program - (file-relative-name file fnd))) - (times 0) - (default-directory fnd) - result) - ;; XEmacs can sometimes return a non-number result. We'll err - ;; on the side of caution by continuing to attempt to generate - ;; the PDF if this happens and treat the final result as - ;; successful. - (while (and (< times 2) - (or (not (numberp result)) - (not (eq result 0)) - ;; table of contents takes 2 passes - (file-readable-p - (muse-replace-regexp-in-string - "\\.tex\\'" ".toc" file t t)))) - (setq result (shell-command command) - times (1+ times))) - (if (or (not (numberp result)) - (eq result 0)) - t - nil)))) - muse-latex-pdf-cruft)) - -;;; Register the Muse LATEX Publishers - -(muse-define-style "latex" - :suffix 'muse-latex-extension - :regexps 'muse-latex-markup-regexps - :functions 'muse-latex-markup-functions - :strings 'muse-latex-markup-strings - :specials 'muse-latex-decide-specials - :before-end 'muse-latex-munge-buffer - :header 'muse-latex-header - :footer 'muse-latex-footer - :browser 'find-file) - -(muse-derive-style "pdf" "latex" - :final 'muse-latex-pdf-generate - :browser 'muse-latex-pdf-browse-file - :link-suffix 'muse-latex-pdf-extension - :osuffix 'muse-latex-pdf-extension) - -(muse-derive-style "latexcjk" "latex" - :header 'muse-latexcjk-header - :footer 'muse-latexcjk-footer) - -(muse-derive-style "pdfcjk" "latexcjk" - :final 'muse-latex-pdf-generate - :browser 'muse-latex-pdf-browse-file - :link-suffix 'muse-latex-pdf-extension - :osuffix 'muse-latex-pdf-extension) - -(muse-derive-style "slides" "latex" - :header 'muse-latex-slides-header - :tags 'muse-latex-slides-markup-tags) - -(muse-derive-style "slides-pdf" "pdf" - :header 'muse-latex-slides-header - :tags 'muse-latex-slides-markup-tags) - -(muse-derive-style "lecture-notes" "slides" - :header 'muse-latex-lecture-notes-header) - -(muse-derive-style "lecture-notes-pdf" "slides-pdf" - :header 'muse-latex-lecture-notes-header) - -(provide 'muse-latex) - -;;; muse-latex.el ends here diff --git a/emacs.d/elisp/muse/muse-latex2png.el b/emacs.d/elisp/muse/muse-latex2png.el deleted file mode 100644 index 2b4373d..0000000 --- a/emacs.d/elisp/muse/muse-latex2png.el +++ /dev/null @@ -1,277 +0,0 @@ -;; muse-latex2png.el --- generate PNG images from inline LaTeX code - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Michael Olson <mwolson@gnu.org> -;; Created: 12-Oct-2005 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This was taken from latex2png.el, by Ganesh Swami <ganesh AT -;; iamganesh DOT com>, which was made for emacs-wiki. It has since -;; been extensively rewritten for Muse. - -;;; To do - -;; Remove stale image files. This could be done by making a function -;; for `muse-before-publish-hook' that deletes according to -;; (muse-page-name). - -;;; Code - -(require 'muse-publish) - -(defgroup muse-latex2png nil - "Publishing LaTeX formulas as PNG files." - :group 'muse-publish) - -(defcustom muse-latex2png-img-dest "./latex" - "The folder where the generated images will be placed. -This is relative to the current publishing directory." - :type 'string - :group 'muse-latex2png) - -(defcustom muse-latex2png-scale-factor 2.5 - "The scale factor to be used for sizing the resulting LaTeX output." - :type 'number - :group 'muse-latex2png) - -(defcustom muse-latex2png-fg "Black" - "The foreground color." - :type 'string - :group 'muse-latex2png) - -(defcustom muse-latex2png-bg "Transparent" - "The background color." - :type 'string - :group 'muse-latex2png) - -(defcustom muse-latex2png-template - "\\documentclass{article} -\\usepackage{fullpage} -\\usepackage{amssymb} -\\usepackage[usenames]{color} -\\usepackage{amsmath} -\\usepackage{latexsym} -\\usepackage[mathscr]{eucal} -%preamble% -\\pagestyle{empty} -\\begin{document} -{%code%} -\\end{document}\n" - "The LaTeX template to use." - :type 'string - :group 'muse-latex2png) - -(defun muse-latex2png-move2pubdir (file prefix pubdir) - "Move FILE to the PUBDIR folder. - -This is done so that the resulting images do not clutter your -main publishing directory. - -Old files with PREFIX in the name are deleted." - (when file - (if (file-exists-p file) - (progn - (unless (file-directory-p pubdir) - (message "Creating latex directory %s" pubdir) - (make-directory pubdir)) - (copy-file file (expand-file-name (file-name-nondirectory file) - pubdir) - t) - (delete-file file) - (concat muse-latex2png-img-dest "/" (file-name-nondirectory file))) - (message "Cannot find %s!" file)))) - -(defun muse-latex2png (code prefix preamble) - "Convert the LaTeX CODE into a png file beginning with PREFIX. -PREAMBLE indicates extra packages and definitions to include." - (unless preamble - (setq preamble "")) - (unless prefix - (setq prefix "muse-latex2png")) - (let* ((tmpdir (cond ((boundp 'temporary-file-directory) - temporary-file-directory) - ((fboundp 'temp-directory) - (temp-directory)) - (t "/tmp"))) - (texfile (expand-file-name - (concat prefix "__" (format "%d" (abs (sxhash code)))) - tmpdir)) - (defalt-directory default-directory)) - (with-temp-file (concat texfile ".tex") - (insert muse-latex2png-template) - (goto-char (point-min)) - (while (search-forward "%preamble%" nil t) - (replace-match preamble nil t)) - (goto-char (point-min)) - (while (search-forward "%code%" nil t) - (replace-match code nil t))) - (setq default-directory tmpdir) - (call-process "latex" nil nil nil texfile) - (if (file-exists-p (concat texfile ".dvi")) - (progn - (call-process - "dvipng" nil nil nil - "-E" - "-fg" muse-latex2png-fg - "-bg" muse-latex2png-bg - "-T" "tight" - "-x" (format "%s" (* muse-latex2png-scale-factor 1000)) - "-y" (format "%s" (* muse-latex2png-scale-factor 1000)) - "-o" (concat texfile ".png") - (concat texfile ".dvi")) - (if (file-exists-p (concat texfile ".png")) - (progn - (delete-file (concat texfile ".dvi")) - (delete-file (concat texfile ".tex")) - (delete-file (concat texfile ".aux")) - (delete-file (concat texfile ".log")) - (concat texfile ".png")) - (message "Failed to create png file") - nil)) - (message (concat "Failed to create dvi file " texfile)) - nil))) - -(defun muse-latex2png-region (beg end attrs) - "Generate an image for the Latex code between BEG and END. -If a Muse page is currently being published, replace the given -region with the appropriate markup that displays the image. -Otherwise, just return the path of the generated image. - -Valid keys for the ATTRS alist are as follows. - -prefix: The prefix given to the image file. -preamble: Extra text to add to the Latex preamble. -inline: Display image as inline, instead of a block." - (let ((end-marker (set-marker (make-marker) (1+ end))) - (pubdir (expand-file-name - muse-latex2png-img-dest - (file-name-directory muse-publishing-current-output-path)))) - (save-restriction - (narrow-to-region beg end) - (let* ((text (buffer-substring-no-properties beg end)) - ;; the prefix given to the image file. - (prefix (cdr (assoc "prefix" attrs))) - ;; preamble (for extra options) - (preamble (cdr (assoc "preamble" attrs))) - ;; display inline or as a block - (display (car (assoc "inline" attrs)))) - (when muse-publishing-p - (delete-region beg end) - (goto-char (point-min))) - (unless (file-directory-p pubdir) - (make-directory pubdir)) - (let ((path (muse-latex2png-move2pubdir - (muse-latex2png text prefix preamble) - prefix pubdir))) - (when path - (when muse-publishing-p - (muse-insert-markup - (if (muse-style-derived-p "html") - (concat "<img src=\"" path - "\" alt=\"latex2png equation\" " - (if display (concat "class=\"latex-inline\"") - (concat "class=\"latex-display\"")) - (if (muse-style-derived-p "xhtml") - " />" - ">") - (muse-insert-markup "<!-- " text "-->")) - (let ((ext (or (file-name-extension path) "")) - (path (muse-path-sans-extension path))) - (muse-markup-text 'image path ext)))) - (goto-char (point-max))) - path)))))) - -(defun muse-publish-latex-tag (beg end attrs) - "If the current style is not Latex-based, generate an image for the -given Latex code. Otherwise, don't do anything to the region. -See `muse-latex2png-region' for valid keys for ATTRS." - (unless (assoc "prefix" attrs) - (setq attrs (cons (cons "prefix" - (concat "latex2png-" (muse-page-name))) - attrs))) - (if (or (muse-style-derived-p "latex") (muse-style-derived-p "context")) - (muse-publish-mark-read-only beg end) - (muse-latex2png-region beg end attrs))) - -(put 'muse-publish-latex-tag 'muse-dangerous-tag t) - -(defun muse-publish-math-tag (beg end) - "Surround the given region with \"$\" characters. Then, if the -current style is not Latex-based, generate an image for the given -Latex math code. - -If 6 or more spaces come before the tag, and the end of the tag -is at the end of a line, then surround the region with the -equivalent of \"$$\" instead. This causes the region to be -centered in the published output, among other things." - (let* ((centered (and (re-search-backward - (concat "^[" muse-regexp-blank "]\\{6,\\}\\=") - nil t) - (save-excursion - (save-match-data - (goto-char end) - (looking-at (concat "[" muse-regexp-blank "]*$")))) - (prog1 t - (replace-match "") - (when (and (or (muse-style-derived-p "latex") - (muse-style-derived-p "context")) - (not (bobp))) - (backward-char 1) - (if (bolp) - (delete-char 1) - (forward-char 1))) - (setq beg (point))))) - (tag-beg (if centered - (if (muse-style-derived-p "context") - "\\startformula " "\\[ ") - "$")) - (tag-end (if centered - (if (muse-style-derived-p "context") - " \\stopformula" " \\]") - "$")) - (attrs (nconc (list (cons "prefix" - (concat "latex2png-" (muse-page-name)))) - (if centered nil - '(("inline" . t)))))) - (goto-char beg) - (muse-insert-markup tag-beg) - (goto-char end) - (muse-insert-markup tag-end) - (if (or (muse-style-derived-p "latex") (muse-style-derived-p "context")) - (muse-publish-mark-read-only beg (point)) - (muse-latex2png-region beg (point) attrs)))) - -(put 'muse-publish-math-tag 'muse-dangerous-tag t) - -;;; Insinuate with muse-publish - -(add-to-list 'muse-publish-markup-tags - '("latex" t t nil muse-publish-latex-tag) - t) - -(add-to-list 'muse-publish-markup-tags - '("math" t nil nil muse-publish-math-tag) - t) - -(provide 'muse-latex2png) -;;; muse-latex2png.el ends here diff --git a/emacs.d/elisp/muse/muse-mode.el b/emacs.d/elisp/muse/muse-mode.el deleted file mode 100644 index 9659843..0000000 --- a/emacs.d/elisp/muse/muse-mode.el +++ /dev/null @@ -1,1013 +0,0 @@ -;;; muse-mode.el --- mode for editing Muse files; has font-lock support - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; The Emacs Muse major mode is basically a hyped-up text-mode which -;; knows a lot more about the apparent structure of the document. - -;;; Contributors: - -;; Andrea Riciputi (ariciputi AT pito DOT com) gave an initial -;; implementation for tag completion by means of the `muse-insert-tag' -;; function. - -;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the -;; insertion of relative links and list items, backlink searching, and -;; other things as well. - -;; Stefan Schlee (stefan_schlee AT yahoo DOT com) fixed a bug in -;; muse-next-reference and muse-previous-reference involving links -;; that begin at point 1. - -;; Gregory Collins (greg AT gregorycollins DOT net) fixed a bug with -;; paragraph separation and headings when filling. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Emacs Muse Major Mode -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'muse-mode) - -(require 'muse) -(require 'muse-regexps) -(require 'muse-project) - -(autoload 'muse-use-font-lock "muse-colors") -(autoload 'muse-publish-this-file "muse-publish") -(autoload 'muse-publish-get-style "muse-publish") -(autoload 'muse-publish-output-file "muse-publish") - -(require 'derived) -(eval-when-compile - (condition-case nil - (require 'pcomplete) ; load if available - (error nil))) - -;;; Options: - -(defgroup muse-mode nil - "Options controlling the behavior of the Muse editing Mode." - :group 'muse) - -(defcustom muse-mode-highlight-p t - "If non-nil, highlight the content of Muse buffers." - :type 'boolean - :require 'muse-colors - :group 'muse-mode) - -(defcustom muse-mode-auto-p nil - "If non-nil, automagically determine when Muse mode should be activated." - :type 'boolean - :set (function - (lambda (sym value) - (if value - (add-hook 'find-file-hooks 'muse-mode-maybe) - (remove-hook 'find-file-hooks 'muse-mode-maybe)) - (set sym value))) - :group 'muse-mode) - -(defun muse-mode-maybe-after-init () - (when muse-mode-auto-p - (add-hook 'find-file-hooks 'muse-mode-maybe))) - -;; If the user sets this value in their init file, make sure that -;; it takes effect -(add-hook 'after-init-hook 'muse-mode-maybe-after-init) - -(defcustom muse-mode-intangible-links nil - "If non-nil, use the intangible property on links. -This can cause problems with flyspell (and potentially fill-mode), -so only enable this if you don't use either of these." - :type 'boolean - :group 'muse-mode) - -(defcustom muse-mode-hook nil - "A hook that is run when Muse mode is entered." - :type 'hook - :options '(flyspell-mode footnote-mode turn-on-auto-fill - highlight-changes-mode) - :group 'muse-mode) - -(defcustom muse-grep-command - "find %D -type f ! -name '*~' | xargs -I {} echo \\\"{}\\\" | xargs egrep -n -e \"%W\"" - "The command to use when grepping for backlinks and other -searches through the muse projects. The string %D is replaced by -the directories from muse-project-alist, space-separated. The -string %W is replaced with the name of the muse page or whatever -else you are searching for. This command has been modified to -handle spaces in filenames, which were giving egrep a problem. - -Note: We highly recommend using glimpse to search large projects. -To use glimpse, install and edit a file called .glimpse_exclude -in your home directory. Put a list of glob patterns in that file -to exclude Emacs backup files, etc. Then, run the indexer using: - - glimpseindex -o <list of Wiki directories> - -Once that's completed, customize this variable to have the -following value: - - glimpse -nyi \"%W\" - -Your searches will go much, much faster, especially for very -large projects. Don't forget to add a user cronjob to update the -index at intervals." - :type 'string - :group 'muse-mode) - -(defvar muse-insert-map - (let ((map (make-sparse-keymap))) - (define-key map "l" 'muse-insert-relative-link-to-file) - (define-key map "t" 'muse-insert-tag) - (define-key map "u" 'muse-insert-url) - - map)) - -;;; Muse mode - -(defvar muse-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) (control ?a)] 'muse-index) - (define-key map [(control ?c) (control ?e)] 'muse-edit-link-at-point) - (define-key map [(control ?c) (control ?l)] 'font-lock-mode) - (define-key map [(control ?c) (control ?t)] - 'muse-project-publish-this-file) - (define-key map [(control ?c) (control ?T)] 'muse-publish-this-file) - (define-key map [(control ?c) (meta control ?t)] 'muse-publish-this-file) - (define-key map [(control ?c) (control ?v)] 'muse-browse-result) - - (define-key map [(control ?c) ?=] 'muse-what-changed) - - (define-key map [tab] 'muse-next-reference) - (define-key map [(control ?i)] 'muse-next-reference) - - (if (featurep 'xemacs) - (progn - (define-key map [(button2)] 'muse-follow-name-at-mouse) - (define-key map [(shift button2)] - 'muse-follow-name-at-mouse-other-window)) - (define-key map [(shift control ?m)] - 'muse-follow-name-at-point-other-window) - (define-key map [mouse-2] 'muse-follow-name-at-mouse) - (define-key map [(shift mouse-2)] - 'muse-follow-name-at-mouse-other-window)) - - (define-key map [(shift tab)] 'muse-previous-reference) - (unless (featurep 'xemacs) - (define-key map [(shift iso-lefttab)] 'muse-previous-reference) - (define-key map [(shift control ?i)] 'muse-previous-reference)) - - (define-key map [(control ?c) (control ?f)] 'muse-project-find-file) - (define-key map [(control ?c) (control ?p)] 'muse-project-publish) - - (define-key map [(control ?c) (control ?i)] 'muse-insert-thing) - (define-key map [(control ?c) tab] 'muse-insert-thing) - - ;; Searching functions - (define-key map [(control ?c) (control ?b)] 'muse-find-backlinks) - (define-key map [(control ?c) (control ?s)] 'muse-search) - - ;; Enhanced list functions - (define-key map [(meta return)] 'muse-insert-list-item) - (define-key map [(control ?>)] 'muse-increase-list-item-indentation) - (define-key map [(control ?<)] 'muse-decrease-list-item-indentation) - - (when (featurep 'pcomplete) - (define-key map [(meta tab)] 'pcomplete) - (define-key map [(meta control ?i)] 'pcomplete)) - - map) - "Keymap used by Emacs Muse mode.") - -;;;###autoload -(define-derived-mode muse-mode text-mode "Muse" - "Muse is an Emacs mode for authoring and publishing documents. -\\{muse-mode-map}" - ;; Since we're not inheriting from normal-mode, we need to - ;; explicitly run file variables. - (condition-case err - (hack-local-variables) - (error (message "File local-variables error: %s" - (prin1-to-string err)))) - ;; Avoid lock-up caused by use of the 'intangible' text property - ;; with flyspell. - (unless muse-mode-intangible-links - (set (make-local-variable 'inhibit-point-motion-hooks) t)) - (setq muse-current-project (muse-project-of-file)) - (muse-project-set-variables) - ;; Make fill not split up links - (when (boundp 'fill-nobreak-predicate) - (make-local-variable 'fill-nobreak-predicate) - ;; Work around annoying inconsistency in fill handling between - ;; Emacs 21 and 22. - (if (< emacs-major-version 22) - (setq fill-nobreak-predicate 'muse-mode-fill-nobreak-p) - (add-to-list 'fill-nobreak-predicate - 'muse-mode-fill-nobreak-p))) - ;; Make fill work nicely with item lists - (let ((regexp (concat "\\s-+\\(-\\|[0-9]+\\.\\)\\s-+" - "\\|\\[[0-9]+\\]\\s-*" - "\\|.*\\s-*::\\s-+" - "\\|\\*+\\s-+"))) - (set (make-local-variable 'adaptive-fill-regexp) - (concat regexp "\\|\\s-*")) - (set (make-local-variable 'paragraph-start) - (concat paragraph-start "\\|" regexp)) - (set (make-local-variable 'paragraph-separate) - (concat paragraph-separate "\\|\\*+\\s-+"))) - (set (make-local-variable 'fill-paragraph-function) - 'muse-mode-fill-paragraph) - - ;; Comment syntax is `; comment' - (set (make-local-variable 'comment-start) - "; ") - (set (make-local-variable 'comment-start-skip) - "^;\\s-+") - (set (make-local-variable 'indent-line-function) - #'ignore) - ;; If we're using Emacs21, this makes flyspell work like it should - (when (boundp 'flyspell-generic-check-word-p) - (set (make-local-variable 'flyspell-generic-check-word-p) - 'muse-mode-flyspell-p)) - ;; If pcomplete is available, set it up - (when (featurep 'pcomplete) - (set (make-local-variable 'pcomplete-default-completion-function) - 'muse-mode-completions) - (set (make-local-variable 'pcomplete-command-completion-function) - 'muse-mode-completions) - (set (make-local-variable 'pcomplete-parse-arguments-function) - 'muse-mode-current-word)) - ;; Initialize any auto-generated variables - (run-hooks 'muse-update-values-hook) - (when muse-mode-highlight-p - (muse-use-font-lock))) - -(put 'muse-mode - 'flyspell-mode-predicate - 'muse-mode-flyspell-p) - -(defun muse-mode-fill-nobreak-p () - "Return nil if we should allow a fill to occur at point. -Otherwise return non-nil. - -This is used to keep long explicit links from being mangled by -fill mode." - (save-excursion - (save-match-data - (and (re-search-backward "\\[\\[\\|\\]\\]" - (line-beginning-position) t) - (string= (or (match-string 0) "") - "[["))))) - -(defun muse-mode-fill-paragraph (arg) - "If a definition list is at point, use special filling rules for it. -Otherwise return nil to let the normal filling function take care -of things. - -ARG is passed to `fill-paragraph'." - (let ((count 2)) - (and (not (muse-mode-fill-nobreak-p)) - (save-excursion - (beginning-of-line) - (and (looking-at muse-dl-term-regexp) - (prog1 t - ;; Take initial whitespace into account - (when (looking-at (concat "[" muse-regexp-blank "]+")) - (setq count (+ count (length (match-string 0)))))))) - (let ((fill-prefix (make-string count ?\ )) - (fill-paragraph-function nil)) - (prog1 t - (fill-paragraph arg)))))) - -(defun muse-mode-flyspell-p () - "Return non-nil if we should allow spell-checking to occur at point. -Otherwise return nil. - -This is used to keep links from being improperly colorized by flyspell." - (let ((pos (if (bobp) (point) (1- (point))))) - (and (not (get-text-property pos 'muse-no-flyspell)) - (not (get-text-property pos 'muse-link)) - (save-match-data - (null (muse-link-at-point)))))) - -;;;###autoload -(defun muse-mode-choose-mode () - "Turn the proper Emacs Muse related mode on for this file." - (let ((project (muse-project-of-file))) - (funcall (or (and project (muse-get-keyword :major-mode (cadr project) t)) - 'muse-mode)))) - -(defun muse-mode-maybe () - "Maybe turn Emacs Muse mode on for this file." - (let ((project (muse-project-of-file))) - (and project - (funcall (or (muse-get-keyword :major-mode (cadr project) t) - 'muse-mode))))) - -;;; Enhanced list editing - -(defun muse-on-blank-line () - "See if point is on a blank line" - (save-excursion - (beginning-of-line) - (looking-at (concat "[" muse-regexp-blank "]*$")))) - -(defun muse-get-paragraph-start () - "Return the start of the current paragraph. This function will -return nil if there are no prior paragraphs and the beginning of -the line if point is on a blank line." - (let ((para-start (concat "^[" muse-regexp-blank "]*$"))) - ;; search back to start of paragraph - (save-excursion - (save-match-data - (if (not (muse-on-blank-line)) - (re-search-backward para-start nil t) - (line-beginning-position)))))) - -(defun muse-insert-thing () - "Prompt for something to insert into the current buffer." - (interactive) - (message "Insert:\nl link\nt Muse tag\nu URL") - (let (key cmd) - (let ((overriding-local-map muse-insert-map)) - (setq key (read-key-sequence nil))) - (if (commandp (setq cmd (lookup-key muse-insert-map key))) - (progn (message "") - (call-interactively cmd)) - (message "Not inserting anything")))) - -;;;###autoload -(defun muse-insert-list-item () - "Insert a list item at the current point, taking into account -your current list type and indentation level." - (interactive) - (let ((newitem " - ") - (itemno nil) - (pstart (muse-get-paragraph-start)) - (list-item (format muse-list-item-regexp - (concat "[" muse-regexp-blank "]*")))) - ;; search backwards for start of current item - (save-excursion - (when (re-search-backward list-item pstart t) - ;; save the matching item - (setq newitem (match-string 0)) - ;; see what type it is - (if (string-match "::" (match-string 0)) - ;; is a definition, replace the term - (setq newitem (concat " " - (read-string "Term: ") - " :: ")) - ;; see if it's a numbered list - (when (string-match "[0-9]+" newitem) - ;; is numbered, so increment - (setq itemno (1+ - (string-to-number - (match-string 0 newitem)))) - (setq newitem (replace-match - (number-to-string itemno) - nil nil newitem)))))) - ;; insert the new item - (insert (concat "\n" newitem)))) - -(defun muse-alter-list-item-indentation (operation) - "Alter the indentation of the current list item. -Valid values of OPERATION are 'increase and 'decrease." - (let ((pstart (muse-get-paragraph-start)) - (list-item (format muse-list-item-regexp - (concat "[" muse-regexp-blank "]*"))) - beg move-func indent) - ;; search backwards until start of paragraph to see if we are on a - ;; current item - (save-excursion - (if (or (progn (goto-char (muse-line-beginning-position)) - ;; we are on an item - (looking-at list-item)) - ;; not on item, so search backwards - (re-search-backward list-item pstart t)) - (let ((beg (point))) - ;; we are on an item - (setq indent (buffer-substring (match-beginning 0) - (match-beginning 1))) - (muse-forward-list-item (muse-list-item-type (match-string 1)) - (concat "[" muse-regexp-blank "]*") - t) - (save-restriction - (narrow-to-region beg (point)) - (goto-char (point-min)) - (let ((halt nil)) - (while (< (point) (point-max)) - ;; increase or decrease the indentation - (unless halt - (cond ((eq operation 'increase) - (insert " ")) - ((eq operation 'decrease) - (if (looking-at " ") - ;; we have enough space, so delete it - (delete-region (match-beginning 0) - (match-end 0)) - (setq halt t))))) - (forward-line 1))))) - ;; we are not on an item, so warn - (message "You are not on a list item."))))) - -;;;###autoload -(defun muse-increase-list-item-indentation () - "Increase the indentation of the current list item." - (interactive) - (muse-alter-list-item-indentation 'increase)) - -;;;###autoload -(defun muse-decrease-list-item-indentation () - "Decrease the indentation of the current list item." - (interactive) - (muse-alter-list-item-indentation 'decrease)) - -;;; Support page name completion using pcomplete - -(defun muse-mode-completions () - "Return a list of possible completions names for this buffer." - (let ((project (muse-project-of-file))) - (if project - (while (pcomplete-here - (mapcar 'car (muse-project-file-alist project))))))) - -(defun muse-mode-current-word () - (let ((end (point))) - (save-excursion - (save-restriction - (skip-chars-backward (concat "^\\[\n" muse-regexp-blank)) - (narrow-to-region (point) end)) - (pcomplete-parse-buffer-arguments)))) - -;;; Navigate/visit links or URLs. Use TAB, S-TAB and RET (or mouse-2). - -(defun muse-link-at-point (&optional pos) - "Return link text if a URL or link is at point." - (let ((case-fold-search nil) - (inhibit-point-motion-hooks t) - (here (or pos (point)))) - ;; if we are using muse-colors, we can just use link properties to - ;; determine whether we are on a link - (if (featurep 'muse-colors) - (when (get-text-property here 'muse-link) - (save-excursion - (when (and (not (bobp)) - (get-text-property (1- here) 'muse-link)) - (goto-char (or (previous-single-property-change here 'muse-link) - (point-min)))) - (if (looking-at muse-explicit-link-regexp) - (progn - (goto-char (match-beginning 1)) - (muse-handle-explicit-link)) - (muse-handle-implicit-link)))) - ;; use fallback method to find a link - (when (or (null pos) - (and (char-after pos) - (not (eq (char-syntax (char-after pos)) ?\ )))) - (save-excursion - (goto-char here) - ;; check for explicit link here or before point - (if (or (looking-at muse-explicit-link-regexp) - (and - (re-search-backward "\\[\\[\\|\\]\\]" - (muse-line-beginning-position) - t) - (string= (or (match-string 0) "") "[[") - (looking-at muse-explicit-link-regexp))) - (progn - (goto-char (match-beginning 1)) - (muse-handle-explicit-link)) - (goto-char here) - ;; check for bare URL or other link type - (skip-chars-backward (concat "^'\"<>{}(\n" muse-regexp-blank)) - (and (looking-at muse-implicit-link-regexp) - (muse-handle-implicit-link)))))))) - -(defun muse-make-link (link &optional desc) - "Return a link to LINK with DESC as the description." - (when (string-match muse-explicit-link-regexp link) - (unless desc (setq desc (muse-get-link-desc link))) - (setq link (muse-get-link link))) - (if (and desc - link - (not (string= desc "")) - (not (string= link desc))) - (concat "[[" (muse-link-escape link) "][" (muse-link-escape desc) "]]") - (concat "[[" (or (muse-link-escape link) "") "]]"))) - -;;;###autoload -(defun muse-insert-relative-link-to-file () - "Insert a relative link to a file, with optional description, at point." - ;; Perhaps the relative location should be configurable, so that the - ;; file search would start in the publishing directory and then - ;; insert the link relative to the publishing directory - (interactive) - (insert - (muse-make-link (file-relative-name (read-file-name "Link: ")) - (read-string "Text: ")))) - -(defcustom muse-insert-url-initial-input "http://" - "The string to insert before reading a URL interactively. -This is used by the `muse-insert-url' command." - :type 'string - :group 'muse-mode) - -(defun muse-insert-url () - "Insert a URL, with optional description, at point." - (interactive) - (insert - (muse-make-link (read-string "URL: " muse-insert-url-initial-input) - (read-string "Text: ")))) - -;;;###autoload -(defun muse-edit-link-at-point () - "Edit the current link. -Do not rename the page originally referred to." - (interactive) - (if (muse-link-at-point) - (let ((link (muse-link-unescape (muse-get-link))) - (desc (muse-link-unescape (muse-get-link-desc)))) - (replace-match - (save-match-data - (muse-make-link - (read-string "Link: " link) - (read-string "Text: " desc))) - t t)) - (error "There is no valid link at point"))) - -(defun muse-visit-link-default (link &optional other-window) - "Visit the URL or link named by LINK. -If ANCHOR is specified, search for it after opening LINK. - -This is the default function to call when visiting links; it is -used by `muse-visit-link' if you have not specified :visit-link -in `muse-project-alist'." - (if (string-match muse-url-regexp link) - (muse-browse-url link) - (let (anchor - base-buffer) - (when (string-match "#" link) - (setq anchor (substring link (match-beginning 0)) - link (if (= (match-beginning 0) 0) - ;; If there is an anchor but no link, default - ;; to the current page. - nil - (substring link 0 (match-beginning 0))))) - (when link - (setq base-buffer (get-buffer link)) - (if (and base-buffer (not (buffer-file-name base-buffer))) - ;; If file is temporary (no associated file), just switch to - ;; the buffer - (if other-window - (switch-to-buffer-other-window base-buffer) - (switch-to-buffer base-buffer)) - (let ((project (muse-project-of-file))) - (if project - (muse-project-find-file link project - (and other-window - 'find-file-other-window)) - (if other-window - (find-file-other-window link) - (find-file link)))))) - (when anchor - (let ((pos (point)) - (regexp (concat "^\\W*" (regexp-quote anchor) "\\b")) - last) - (goto-char (point-min)) - (while (and (setq last (re-search-forward regexp nil t)) - (muse-link-at-point))) - (unless last - (goto-char pos) - (message "Could not find anchor `%s'" anchor))))))) - -(defun muse-visit-link (link &optional other-window) - "Visit the URL or link named by LINK." - (let ((visit-link-function - (muse-get-keyword :visit-link (cadr (muse-project-of-file)) t))) - (if visit-link-function - (funcall visit-link-function link other-window) - (muse-visit-link-default link other-window)))) - -;;;###autoload -(defun muse-browse-result (style &optional other-window) - "Visit the current page's published result." - (interactive - (list (muse-project-get-applicable-style buffer-file-name - (cddr muse-current-project)) - current-prefix-arg)) - (setq style (muse-style style)) - (muse-project-publish-this-file nil style) - (let* ((output-dir (muse-style-element :path style)) - (output-suffix (muse-style-element :osuffix style)) - (output-path (muse-publish-output-file buffer-file-name output-dir - style)) - (target (if output-suffix - (concat (muse-path-sans-extension output-path) - output-suffix) - output-path)) - (muse-current-output-style (list :base (car style) - :path output-dir))) - (if (not (file-readable-p target)) - (error "Cannot open output file '%s'" target) - (if other-window - (find-file-other-window target) - (let ((func (muse-style-element :browser style t))) - (if func - (funcall func target) - (message "The %s publishing style does not support browsing." - style))))))) - -;;;###autoload -(defun muse-follow-name-at-point (&optional other-window) - "Visit the link at point." - (interactive "P") - (let ((link (muse-link-at-point))) - (if link - (muse-visit-link link other-window) - (error "There is no valid link at point")))) - -;;;###autoload -(defun muse-follow-name-at-point-other-window () - "Visit the link at point in other window." - (interactive) - (muse-follow-name-at-point t)) - -(defun muse-follow-name-at-mouse (event &optional other-window) - "Visit the link at point, or yank text if none is found." - (interactive "eN") - (unless - (save-excursion - (cond ((fboundp 'event-window) ; XEmacs - (set-buffer (window-buffer (event-window event))) - (and (funcall (symbol-function 'event-point) event) - (goto-char (funcall (symbol-function 'event-point) - event)))) - ((fboundp 'posn-window) ; Emacs - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - (let ((link (muse-link-at-point))) - (when link - (muse-visit-link link other-window) - t))) - ;; Fall back to normal binding for this event - (call-interactively - (lookup-key (current-global-map) (this-command-keys))))) - -(defun muse-follow-name-at-mouse-other-window (event) - "Visit the link at point" - (interactive "e") - ;; throw away the old window position, since other-window will - ;; change it anyway - (select-window (car (cadr event))) - (muse-follow-name-at-mouse event t)) - -;;;###autoload -(defun muse-next-reference () - "Move forward to next Muse link or URL, cycling if necessary." - (interactive) - (let ((pos)) - (save-excursion - (when (get-text-property (point) 'muse-link) - (goto-char (or (next-single-property-change (point) 'muse-link) - (point-max)))) - - (setq pos (next-single-property-change (point) 'muse-link)) - - (when (not pos) - (if (get-text-property (point-min) 'muse-link) - (setq pos (point-min)) - (setq pos (next-single-property-change (point-min) 'muse-link))))) - - (when pos - (goto-char pos)))) - -;;;###autoload -(defun muse-previous-reference () - "Move backward to the next Muse link or URL, cycling if necessary. -In case of Emacs x <= 21 and ignoring of intangible properties (see -`muse-mode-intangible-links'). - -This function is not entirely accurate, but it's close enough." - (interactive) - (let ((pos)) - (save-excursion - - ;; Hack: The user perceives the two cases of point ("|") - ;; position (1) "|[[" and (2) "[[|" or "][|" as "point is at - ;; start of link". But in the sense of the function - ;; "previous-single-property-change" these two cases are - ;; different. The following code aligns these two cases. Emacs - ;; 21: If the intangible property is ignored case (2) is more - ;; complicate and this hack only solves the problem partially. - ;; - (when (and (get-text-property (point) 'muse-link) - (muse-looking-back "\\[\\|\\]")) - (goto-char (or (previous-single-property-change (point) 'muse-link) - (point-min)))) - - (when (eq (point) (point-min)) - (goto-char (point-max))) - - (setq pos (previous-single-property-change (point) 'muse-link)) - - (when (not pos) - (if (get-text-property (point-min) 'muse-link) - (setq pos (point-min)) - (setq pos (previous-single-property-change (point-max) - 'muse-link))))) - - (when pos - (if (get-text-property pos 'muse-link) - (goto-char pos) - (goto-char (or (previous-single-property-change pos 'muse-link) - (point-min))))))) - -;;;###autoload -(defun muse-what-changed () - "Show the unsaved changes that have been made to the current file." - (interactive) - (diff-backup buffer-file-name)) - - -;;; Find text in project pages, or pages referring to the current page - -(defvar muse-search-history nil) - -(defun muse-grep (string &optional grep-command-no-shadow) - "Grep for STRING in the project directories. -GREP-COMMAND if passed will supplant `muse-grep-command'." - ;; careful - grep-command leaks into compile, so we call it - ;; -no-shadow instead - (require 'compile) - (let* ((str (or grep-command-no-shadow muse-grep-command)) - (muse-directories (mapcar - (lambda (thing) - (car (cadr thing))) - muse-project-alist)) - (dirs (mapconcat (lambda (dir) - (shell-quote-argument - (expand-file-name dir))) - muse-directories " "))) - (if (string= dirs "") - (muse-display-warning - "No directories were found in the current project; aborting search") - (while (string-match "%W" str) - (setq str (replace-match string t t str))) - (while (string-match "%D" str) - (setq str (replace-match dirs t t str))) - (if (fboundp 'compilation-start) - (compilation-start str nil (lambda (&rest args) "*search*") - grep-regexp-alist) - (and (fboundp 'compile-internal) - (compile-internal str "No more search hits" "search" - nil grep-regexp-alist)))))) - -;;;###autoload -(defun muse-search-with-command (text) - "Search for the given TEXT string in the project directories -using the specified command." - (interactive - (list (let ((str (concat muse-grep-command)) pos) - (when (string-match "%W" str) - (setq pos (match-beginning 0)) - (unless (featurep 'xemacs) - (setq pos (1+ pos))) - (setq str (replace-match "" t t str))) - (read-from-minibuffer "Search command: " - (cons str pos) nil nil - 'muse-search-history)))) - (muse-grep nil text)) - -;;;###autoload -(defun muse-search () - "Search for the given TEXT using the default grep command." - (interactive) - (muse-grep (read-string "Search: "))) - -;;;###autoload -(defun muse-find-backlinks () - "Grep for the current pagename in all the project directories." - (interactive) - (muse-grep (muse-page-name))) - - -;;; Generate an index of all known Muse pages - -(defun muse-generate-index (&optional as-list exclude-private) - "Generate an index of all Muse pages." - (let ((index (muse-index-as-string as-list exclude-private))) - (with-current-buffer (get-buffer-create "*Muse Index*") - (erase-buffer) - (insert index) - (current-buffer)))) - -;;;###autoload -(defun muse-index () - "Display an index of all known Muse pages." - (interactive) - (message "Generating Muse index...") - (let ((project (muse-project))) - (with-current-buffer (muse-generate-index) - (goto-char (point-min)) - (muse-mode) - (setq muse-current-project project) - (pop-to-buffer (current-buffer)))) - (message "Generating Muse index...done")) - -(defun muse-index-as-string (&optional as-list exclude-private exclude-current) - "Generate an index of all Muse pages. -If AS-LIST is non-nil, insert a dash and spaces before each item. -If EXCLUDE-PRIVATE is non-nil, exclude files that have private permissions. -If EXCLUDE-CURRENT is non-nil, exclude the current file from the output." - (let ((files (sort (copy-alist (muse-project-file-alist)) - (function - (lambda (l r) - (string-lessp (car l) (car r))))))) - (when (and exclude-current (muse-page-name)) - (setq files (delete (assoc (muse-page-name) files) files))) - (with-temp-buffer - (while files - (unless (and exclude-private - (muse-project-private-p (cdar files))) - (insert (if as-list " - " "") "[[" (caar files) "]]\n")) - (setq files (cdr files))) - (buffer-string)))) - -;;; Insert tags interactively on C-c TAB t - -(defvar muse-tag-history nil - "List of recently-entered tags; used by `muse-insert-tag'. -If you want a tag to start as the default, you may manually set -this variable to a list.") - -(defvar muse-custom-tags nil - "Keep track of any new tags entered in `muse-insert-tag'. -If there are (X)HTML tags that you use frequently with that -function, you might want to set this manually.") - -;;;###autoload -(defun muse-insert-tag (tag) - "Insert a tag interactively with a blank line after it." - (interactive - (list - (funcall - muse-completing-read-function - (concat "Tag: " - (when muse-tag-history - (concat "(default: " (car muse-tag-history) ") "))) - (progn - (require 'muse-publish) - (mapcar 'list (nconc (mapcar 'car muse-publish-markup-tags) - muse-custom-tags))) - nil nil nil 'muse-tag-history - (car muse-tag-history)))) - (when (equal tag "") - (setq tag (car muse-tag-history))) - (unless (interactive-p) - (require 'muse-publish)) - (let ((tag-entry (assoc tag muse-publish-markup-tags)) - (options "")) - ;; Add to custom list if no entry exists - (unless tag-entry - (add-to-list 'muse-custom-tags tag)) - ;; Get option - (when (nth 2 tag-entry) - (setq options (read-string "Option: "))) - (unless (equal options "") - (setq options (concat " " options))) - ;; Insert the tag, closing if necessary - (when tag (insert (concat "<" tag options ">"))) - (when (nth 1 tag-entry) - (insert (concat "\n\n</" tag ">\n")) - (forward-line -2)))) - -;;; Muse list edit minor mode - -(defvar muse-list-edit-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(meta return)] 'muse-l-e-m-m-insert-list-item) - (define-key map [(control ?>)] 'muse-l-e-m-m-increase-list-item-indent) - (define-key map [(control ?<)] 'muse-l-e-m-m-decrease-list-item-indent) - - map) - "Keymap used by Muse list edit minor mode.") - -(defvar muse-l-e-m-m-list-item-regexp - (concat "^%s\\(\\([^\n" muse-regexp-blank "].*?\\)?::" - "\\(?:[" muse-regexp-blank "]+\\|$\\)" - "\\|[" muse-regexp-blank "]?[-*+][" muse-regexp-blank "]*" - "\\|[" muse-regexp-blank "][0-9]+\\.[" muse-regexp-blank "]*\\)") - "Regexp used to match the beginning of a list item. -This is used by `muse-list-edit-minor-mode'. -The '%s' will be replaced with a whitespace regexp when publishing.") - -(defun muse-l-e-m-m-insert-list-item () - "Insert a list item at the current point, taking into account -your current list type and indentation level." - (interactive) - (let ((muse-list-item-regexp muse-l-e-m-m-list-item-regexp)) - (call-interactively 'muse-insert-list-item))) - -(defun muse-l-e-m-m-increase-list-item-indent () - "Increase the indentation of the current list item." - (interactive) - (let ((muse-list-item-regexp muse-l-e-m-m-list-item-regexp)) - (call-interactively 'muse-increase-list-item-indentation))) - -(defun muse-l-e-m-m-decrease-list-item-indent () - "Decrease the indentation of the current list item." - (interactive) - (let ((muse-list-item-regexp muse-l-e-m-m-list-item-regexp)) - (call-interactively 'muse-decrease-list-item-indentation))) - -(defvar muse-l-e-m-m-data nil - "A list of data that was changed by Muse list edit minor mode.") -(make-variable-buffer-local 'muse-l-e-m-m-data) - -;;;###autoload -(define-minor-mode muse-list-edit-minor-mode - "This is a global minor mode for editing files with lists. -It is meant to be used with other major modes, and not with Muse mode. - -Interactively, with no prefix argument, toggle the mode. -With universal prefix ARG turn mode on. -With zero or negative ARG turn mode off. - -This minor mode provides the Muse keybindings for editing lists, -and support for filling lists properly. - -It recognizes not only Muse-style lists, which use the \"-\" -character or numbers, but also lists that use asterisks or plus -signs. This should make the minor mode generally useful. - -Definition lists and footnotes are also recognized. - -Note that list items may omit leading spaces, for compatibility -with modes that set `left-margin', such as -`debian-changelog-mode'. - -\\{muse-list-edit-minor-mode-map}" - :init-value nil - :lighter "" - :keymap muse-list-edit-minor-mode-map - :global nil - :group 'muse-mode - (if (not muse-list-edit-minor-mode) - ;; deactivate - (when muse-l-e-m-m-data - (setq adaptive-fill-regexp (cdr (assoc "a-f-r" muse-l-e-m-m-data)) - paragraph-start (cdr (assoc "p-s" muse-l-e-m-m-data)) - fill-prefix (cdr (assoc "f-p" muse-l-e-m-m-data))) - (setq muse-l-e-m-m-data nil)) - ;; activate - (unless muse-l-e-m-m-data - ;; save previous fill-related data so we can restore it later - (setq muse-l-e-m-m-data - (list (cons "a-f-r" adaptive-fill-regexp) - (cons "p-s" paragraph-start) - (cons "f-p" fill-prefix)))) - ;; make fill work nicely with item lists - (let ((regexp (concat "\\s-*\\([-*+]\\|[0-9]+\\.\\)\\s-+" - "\\|\\[[0-9]+\\]\\s-*" - "\\|.*\\s-*::\\s-+"))) - (set (make-local-variable 'adaptive-fill-regexp) - (concat regexp "\\|\\s-*")) - (set (make-local-variable 'paragraph-start) - (concat paragraph-start "\\|" regexp))) - ;; force fill-prefix to be nil, because if it is a string that has - ;; initial spaces, it messes up fill-paragraph's algorithm - (set (make-local-variable 'fill-prefix) nil))) - -(defun turn-on-muse-list-edit-minor-mode () - "Unconditionally turn on Muse list edit minor mode." - (muse-list-edit-minor-mode 1)) - -(defun turn-off-muse-list-edit-minor-mode () - "Unconditionally turn off Muse list edit minor mode." - (muse-list-edit-minor-mode -1)) - -;;; muse-mode.el ends here diff --git a/emacs.d/elisp/muse/muse-poem.el b/emacs.d/elisp/muse/muse-poem.el deleted file mode 100644 index bd08b7e..0000000 --- a/emacs.d/elisp/muse/muse-poem.el +++ /dev/null @@ -1,263 +0,0 @@ -;;; muse-poem.el --- publish a poem to LaTex or PDF - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This file specifies a form for recording poetry. It is as follows. -;; -;; Title -;; -;; -;; Body of poem -;; -;; -;; Annotations, history, notes, etc. -;; -;; The `muse-poem' module makes it easy to attractively publish and -;; reference poems in this format, using the "memoir" module for LaTeX -;; publishing. It will also markup poems for every other output -;; style, though none are nearly as pretty. -;; -;; Once a poem is written in this format, just publish it to PDF using -;; the "poem-pdf" style. To make an inlined reference to a poem that -;; you've written -- for example, from a blog page -- there is a -;; "poem" tag defined by this module: -;; -;; <poem title="name.of.poem.page"> -;; -;; Let's assume the template above was called "name.of.poem.page"; -;; then the above tag would result in this inclusion: -;; -;; ** Title -;; -;; > Body of poem -;; -;; I use this module for publishing all of the poems on my website, -;; which are at: http://www.newartisans.com/johnw/poems.html. - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Poem Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-latex) -(require 'muse-project) - -(defgroup muse-poem nil - "Rules for marking up a Muse file as a LaTeX article." - :group 'muse-latex) - -(defcustom muse-poem-latex-header - "\\documentclass[14pt,oneside]{memoir} - -\\usepackage[english]{babel} -\\usepackage[latin1]{inputenc} -\\usepackage[T1]{fontenc} - -\\setlength{\\beforepoemtitleskip}{-5.0ex} - -\\begin{document} - -\\pagestyle{empty} - -\\renewcommand{\\poemtoc}{section} -\\settocdepth{section} - -\\mbox{} -\\vfill - -\\poemtitle{<lisp>(muse-publishing-directive \"title\")</lisp>} - -\\settowidth{\\versewidth}{<lisp>muse-poem-longest-line</lisp>}\n\n" - "Header used for publishing LaTeX poems. This may be text or a filename." - :type 'string - :group 'muse-poem) - -(defcustom muse-poem-latex-footer "\n\\vfill -\\mbox{} - -\\end{document}" - "Footer used for publishing LaTeX files. This may be text or a filename." - :type 'string - :group 'muse-poem) - -(defcustom muse-poem-markup-strings - '((begin-verse . "\\begin{verse}[\\versewidth]\n") - (verse-space . "\\vin ")) - "Strings used for marking up poems. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-poem) - -(defcustom muse-chapbook-latex-header - "\\documentclass{book} - -\\usepackage[english]{babel} -\\usepackage[latin1]{inputenc} -\\usepackage[T1]{fontenc} - -\\setlength{\\beforepoemtitleskip}{-5.0ex} - -\\begin{document} - -\\title{<lisp>(muse-publishing-directive \"title\")</lisp>} -\\author{<lisp>(muse-publishing-directive \"author\")</lisp>} -\\date{<lisp>(muse-publishing-directive \"date\")</lisp>} - -\\maketitle - -\\tableofcontents - -\\renewcommand{\\poemtoc}{section} -\\settocdepth{section}\n" - "Header used for publishing a book of poems in LaTeX form. -This may be text or a filename." - :type 'string - :group 'muse-poem) - -(defcustom muse-chapbook-latex-footer "\n\\end{document}" - "Footer used for publishing a book of poems in LaTeX form. -This may be text or a filename." - :type 'string - :group 'muse-poem) - -(defvar muse-poem-longest-line "") - -(defcustom muse-poem-chapbook-strings - '((begin-verse . "\\newpage -\\mbox{} -\\vfill - -\\poemtitle{<lisp>(muse-publishing-directive \"title\")</lisp>} - -\\settowidth{\\versewidth}{<lisp>muse-poem-longest-line</lisp>} - -\\begin{verse}[\\versewidth]\n") - (end-verse . "\n\\end{verse}\n\\vfill\n\\mbox{}") - (verse-space . "\\vin ")) - "Strings used for marking up books of poems. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-poem) - -(defun muse-poem-prepare-buffer () - (goto-char (point-min)) - (insert "#title ") - (forward-line 1) - (delete-region (point) (1+ (muse-line-end-position))) - (insert "\n<verse>") - (let ((beg (point)) end line) - (if (search-forward "\n\n\n" nil t) - (progn - (setq end (copy-marker (match-beginning 0) t)) - (replace-match "\n</verse>\n") - (delete-region (point) (point-max))) - (goto-char (point-max)) - (setq end (point)) - (insert "</verse>\n")) - (goto-char (1+ beg)) - (set (make-local-variable 'muse-poem-longest-line) "") - (while (< (point) end) - (setq line (buffer-substring-no-properties (point) - (muse-line-end-position))) - (if (> (length line) (length muse-poem-longest-line)) - (setq muse-poem-longest-line line)) - (forward-line 1)) - nil)) - -(defvar muse-poem-tag '("poem" nil t nil muse-poem-markup-tag)) - -(defun muse-poem-markup-tag (beg end attrs) - "This markup tag allows a poem to be included from another project page. -The form of usage is: - <poem title=\"page.name\">" - (let ((page (cdr (assoc (cdr (assoc "title" attrs)) - (muse-project-file-alist)))) - beg end) - (if (null page) - (insert " *Reference to\n unknown poem \"" - (cdr (assoc "title" attrs)) "\".*\n") - (setq beg (point)) - (insert - (muse-with-temp-buffer - (muse-insert-file-contents page) - (goto-char (point-min)) - (if (assoc "nohead" attrs) - (progn - (forward-line 3) - (delete-region (point-min) (point))) - (insert "** ") - (search-forward "\n\n\n") - (replace-match "\n\n")) - (if (search-forward "\n\n\n" nil t) - (setq end (match-beginning 0)) - (setq end (point-max))) - (buffer-substring-no-properties (point-min) end))) - (setq end (point-marker)) - (goto-char beg) - (unless (assoc "nohead" attrs) - (forward-line 2)) - (while (< (point) end) - (insert "> ") - (forward-line 1)) - (set-marker end nil)))) - -(put 'muse-poem-markup-tag 'muse-dangerous-tag t) - -(add-to-list 'muse-publish-markup-tags muse-poem-tag) - -;;; Register the Muse POEM Publishers - -(muse-derive-style "poem-latex" "latex" - :before 'muse-poem-prepare-buffer - :strings 'muse-poem-markup-strings - :header 'muse-poem-latex-header - :footer 'muse-poem-latex-footer) - -(muse-derive-style "poem-pdf" "pdf" - :before 'muse-poem-prepare-buffer - :strings 'muse-poem-markup-strings - :header 'muse-poem-latex-header - :footer 'muse-poem-latex-footer) - -(muse-derive-style "chapbook-latex" "latex" - :before 'muse-poem-prepare-buffer - :strings 'muse-poem-chapbook-strings - :header 'muse-chapbook-latex-header - :footer 'muse-chapbook-latex-footer) - -(muse-derive-style "chapbook-pdf" "pdf" - :before 'muse-poem-prepare-buffer - :strings 'muse-poem-chapbook-strings - :header 'muse-chapbook-latex-header - :footer 'muse-chapbook-latex-footer) - -(provide 'muse-poem) - -;;; muse-poem.el ends here diff --git a/emacs.d/elisp/muse/muse-project.el b/emacs.d/elisp/muse/muse-project.el deleted file mode 100644 index 7489706..0000000 --- a/emacs.d/elisp/muse/muse-project.el +++ /dev/null @@ -1,973 +0,0 @@ -;;; muse-project.el --- handle Muse projects - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Project Maintainance -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'muse-project) - -(require 'muse) -(require 'muse-publish) -(require 'cus-edit) - -(defgroup muse-project nil - "Options controlling the behavior of Muse project handling." - :group 'muse) - -(defcustom muse-before-project-publish-hook nil - "A hook run before a project is published. -Each function is passed the project object, a cons with the format - (PROJNAME . SETTINGS)" - :type 'hook - :group 'muse-project) - -(defcustom muse-after-project-publish-hook nil - "A hook run after a project is published. -Each function is passed the project object, a cons with the format - (PROJNAME . SETTINGS)" - :type 'hook - :group 'muse-project) - -(defvar muse-project-alist-using-customize nil - "Used internally by Muse to indicate whether `muse-project-alist' -has been modified via the customize interface.") -(make-variable-buffer-local 'muse-project-alist-using-customize) - -(defmacro with-muse-project (project &rest body) - `(progn - (unless (muse-project ,project) - (error "Can't find project %s" ,project)) - (with-temp-buffer - (muse-mode) - (setq muse-current-project (muse-project ,project)) - (muse-project-set-variables) - ,@body))) - -(put 'with-muse-project 'lisp-indent-function 0) -(put 'with-muse-project 'edebug-form-spec '(sexp body)) - -(defun muse-project-alist-get (sym) - "Turn `muse-project-alist' into something we can customize easily." - (when (boundp sym) - (setq muse-project-alist-using-customize t) - (let* ((val (copy-alist (symbol-value sym))) - (head val)) - (while val - (let ((head (car (cdar val))) - res) - ;; Turn settings of first part into cons cells, symbol->string - (while head - (cond ((stringp (car head)) - (add-to-list 'res (car head) t) - (setq head (cdr head))) - ((symbolp (car head)) - (add-to-list 'res (list (symbol-name (car head)) - (cadr head)) t) - (setq head (cddr head))) - (t - (setq head (cdr head))))) - (setcdr (car val) (cons res (cdr (cdar val))))) - (let ((styles (cdar val))) - ;; Symbol->string in every style - (while (cdr styles) - (let ((head (cadr styles)) - res) - (while (consp head) - (setq res (plist-put res (symbol-name (car head)) - (cadr head))) - (setq head (cddr head))) - (setcdr styles (cons res (cddr styles)))) - (setq styles (cdr styles)))) - (setq val (cdr val))) - head))) - -(defun muse-project-alist-set (sym val) - "Turn customized version of `muse-project-alist' into something -Muse can make use of." - (set sym val) - (when muse-project-alist-using-customize - ;; Make sure the unescaped version is written to .emacs - (put sym 'saved-value (list (custom-quote val))) - ;; Perform unescaping - (while val - (let ((head (car (cdar val))) - res) - ;; Turn cons cells into flat list, string->symbol - (while head - (cond ((stringp (car head)) - (add-to-list 'res (car head) t)) - ((consp (car head)) - (add-to-list 'res (intern (caar head)) t) - (add-to-list 'res (car (cdar head)) t))) - (setq head (cdr head))) - (setcdr (car val) (cons res (cdr (cdar val))))) - (let ((styles (cdar val))) - ;; String->symbol in every style - (while (cdr styles) - (let ((head (cadr styles)) - res) - (while (consp head) - (setq res (plist-put res (intern (car head)) - (cadr head))) - (setq head (cddr head))) - (setcdr styles (cons res (cddr styles)))) - (setq styles (cdr styles)))) - (setq val (cdr val))))) - -(define-widget 'muse-project 'default - "A widget that defines a Muse project." - :format "\n%v" - :value-create 'muse-widget-type-value-create - :value-get 'muse-widget-child-value-get - :value-delete 'ignore - :match 'muse-widget-type-match - :type '(cons :format " %v" - (repeat :tag "Settings" :format "%{%t%}:\n%v%i\n\n" - (choice - (string :tag "Directory") - (list :tag "Book function" - (const :tag ":book-funcall" ":book-funcall") - (choice (function) - (sexp :tag "Unknown"))) - (list :tag "Book part" - (const :tag ":book-part" ":book-part") - (string :tag "Name")) - (list :tag "Book style" - (const :tag ":book-style" ":book-style") - (string :tag "Style")) - (list :tag "Default file" - (const :tag ":default" ":default") - (string :tag "File")) - (list :tag "End of book" - (const :tag ":book-end" ":book-end") - (const t)) - (list :tag "Force publishing" - (const :tag ":force-publish" ":force-publish") - (repeat (string :tag "File"))) - (list :tag "Major mode" - (const :tag ":major-mode" ":major-mode") - (choice (function :tag "Mode") - (sexp :tag "Unknown"))) - (list :tag "New chapter" - (const :tag ":book-chapter" ":book-chapter") - (string :tag "Name")) - (list :tag "No chapters" - (const :tag ":nochapters" ":nochapters") - (const t)) - (list :tag "Project-level publishing function" - (const :tag ":publish-project" - ":publish-project") - (choice (function :tag "Function") - (sexp :tag "Unknown"))) - (list :tag "Set variables" - (const :tag ":set" ":set") - (repeat (list :inline t - (symbol :tag "Variable") - (sexp :tag "Setting")))) - (list :tag "Visit links using" - (const :tag ":visit-link" ":visit-link") - (choice (function) - (sexp :tag "Unknown"))))) - (repeat :tag "Output styles" :format "%{%t%}:\n%v%i\n\n" - (set :tag "Style" - (list :inline t - :tag "Publishing style" - (const :tag ":base" ":base") - (string :tag "Style")) - (list :inline t - :tag "Base URL" - (const :tag ":base-url" ":base-url") - (string :tag "URL")) - (list :inline t - :tag "Exclude matching" - (const :tag ":exclude" ":exclude") - (regexp)) - (list :inline t - :tag "Include matching" - (const :tag ":include" ":include") - (regexp)) - (list :inline t - :tag "Timestamps file" - (const :tag ":timestamps" ":timestamps") - (file)) - (list :inline t - :tag "Path" - (const :tag ":path" ":path") - (string :tag "Path")))))) - -(defcustom muse-project-alist nil - "An alist of Muse projects. -A project defines a fileset, and a list of custom attributes for use -when publishing files in that project." - :type '(choice (const :tag "No projects defined." nil) - (repeat (cons :format "%{%t%}:\n\n%v" - :tag "Project" :indent 4 - (string :tag "Project name") - muse-project)) - (sexp :tag "Cannot parse expression")) - :get 'muse-project-alist-get - :set 'muse-project-alist-set - :group 'muse-project) - -;; Make it easier to specify a muse-project-alist entry - -(defcustom muse-project-ignore-regexp - (concat "\\`\\(#.*#\\|.*,v\\|.*~\\|\\.\\.?\\|\\.#.*\\|,.*\\)\\'\\|" - "/\\(CVS\\|RCS\\|\\.arch-ids\\|{arch}\\|,.*\\|\\.svn\\|" - "\\.hg\\|\\.git\\|\\.bzr\\|_darcs\\)\\(/\\|\\'\\)") - "A regexp matching files to be ignored in Muse directories. - -You should set `case-fold-search' to nil before using this regexp -in code." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-project-publish-private-files t - "If this is non-nil, files will be published even if their permissions -are set so that no one else on the filesystem can read them. - -Set this to nil if you would like to indicate that some files -should not be published by manually doing \"chmod o-rwx\" on -them. - -This setting has no effect under Windows (that is, all files are -published regardless of permissions) because Windows lacks the -needed filesystem attributes." - :type 'boolean - :group 'muse-project) - -(defun muse-project-recurse-directory (base) - "Recusively retrieve all of the directories underneath BASE. -A list of these directories is returned. - -Directories starting with \".\" will be ignored, as well as those -which match `muse-project-ignore-regexp'." - (let ((case-fold-search nil) - list dir) - (when (and (file-directory-p base) - (not (string-match muse-project-ignore-regexp base))) - (dolist (file (directory-files base t "^[^.]")) - (when (and (file-directory-p file) - (not (string-match muse-project-ignore-regexp file))) - (setq dir (file-name-nondirectory file)) - (push dir list) - (nconc list (mapcar #'(lambda (item) - (concat dir "/" item)) - (muse-project-recurse-directory file))))) - list))) - -(defun muse-project-alist-styles (entry-dir output-dir style &rest other) - "Return a list of styles to use in a `muse-project-alist' entry. -ENTRY-DIR is the top-level directory of the project. -OUTPUT-DIR is where Muse files are published, keeping directory structure. -STYLE is the publishing style to use. - -OTHER contains other definitions to add to each style. It is optional. - -For an example of the use of this function, see -`examples/mwolson/muse-init.el' from the Muse distribution." - (let ((fnd (file-name-nondirectory entry-dir))) - (when (string= fnd "") - ;; deal with cases like "foo/" that have a trailing slash - (setq fnd (file-name-nondirectory (substring entry-dir 0 -1)))) - (cons `(:base ,style :path ,(if (muse-file-remote-p output-dir) - output-dir - (expand-file-name output-dir)) - :include ,(concat "/" fnd "/[^/]+$") - ,@other) - (mapcar (lambda (dir) - `(:base ,style - :path ,(expand-file-name dir output-dir) - :include ,(concat "/" dir "/[^/]+$") - ,@other)) - (muse-project-recurse-directory entry-dir))))) - -(defun muse-project-alist-dirs (entry-dir) - "Return a list of directories to use in a `muse-project-alist' entry. -ENTRY-DIR is the top-level directory of the project. - -For an example of the use of this function, see -`examples/mwolson/muse-init.el' from the Muse distribution." - (cons (expand-file-name entry-dir) - (mapcar (lambda (dir) (expand-file-name dir entry-dir)) - (muse-project-recurse-directory entry-dir)))) - -;; Constructing the file-alist - -(defvar muse-project-file-alist nil - "This variable is automagically constructed as needed.") - -(defvar muse-project-file-alist-hook nil - "Functions that are to be exectuted immediately after updating -`muse-project-file-alist'.") - -(defvar muse-current-project nil - "Project we are currently visiting.") -(make-variable-buffer-local 'muse-current-project) -(defvar muse-current-project-global nil - "Project we are currently visiting. This is used to propagate the value -of `muse-current-project' into a new buffer during publishing.") - -(defvar muse-current-output-style nil - "The output style that we are currently using for publishing files.") - -(defsubst muse-project (&optional project) - "Resolve the given PROJECT into a full Muse project, if it is a string." - (if (null project) - (or muse-current-project - (muse-project-of-file)) - (if (stringp project) - (assoc project muse-project-alist) - (muse-assert (consp project)) - project))) - -(defun muse-project-page-file (page project &optional no-check-p) - "Return a filename if PAGE exists within the given Muse PROJECT." - (setq project (muse-project project)) - (if (null page) - ;; if not given a page, return the first directory instead - (let ((pats (cadr project))) - (catch 'done - (while pats - (if (symbolp (car pats)) - (setq pats (cddr pats)) - (throw 'done (file-name-as-directory (car pats))))))) - (let ((dir (file-name-directory page)) - (expanded-path nil)) - (when dir - (setq expanded-path (concat (expand-file-name - page - (file-name-directory (muse-current-file))) - (when muse-file-extension - (concat "." muse-file-extension)))) - (setq page (file-name-nondirectory page))) - (let ((files (muse-collect-alist - (muse-project-file-alist project no-check-p) - page)) - (matches nil)) - (if dir - (catch 'done - (save-match-data - (dolist (file files) - (if (and expanded-path - (string= expanded-path (cdr file))) - (throw 'done (cdr file)) - (let ((pos (string-match (concat (regexp-quote dir) "\\'") - (file-name-directory - (cdr file))))) - (when pos - (setq matches (cons (cons pos (cdr file)) - matches))))))) - ;; if we haven't found an exact match, pick a candidate - (car (muse-sort-by-rating matches))) - (dolist (file files) - (setq matches (cons (cons (length (cdr file)) (cdr file)) - matches))) - (car (muse-sort-by-rating matches '<))))))) - -(defun muse-project-private-p (file) - "Return non-nil if NAME is a private page with PROJECT." - (unless (or muse-under-windows-p - muse-project-publish-private-files) - (setq file (file-truename file)) - (if (file-attributes file) ; don't publish if no attributes exist - (or (when (eq ?- (aref (nth 8 (file-attributes - (file-name-directory file))) 7)) - (message (concat - "The " (file-name-directory file) - " directory must be readable by others" - " in order for its contents to be published."))) - (eq ?- (aref (nth 8 (file-attributes file)) 7))) - t))) - -(defun muse-project-file-entries (path) - (let* ((names (list t)) - (lnames names) - (case-fold-search nil)) - (cond - ((file-directory-p path) - (dolist (file (directory-files - path t (when (and muse-file-extension - (not (string= muse-file-extension ""))) - (concat "." muse-file-extension "\\'")))) - (unless (or (string-match muse-project-ignore-regexp file) - (string-match muse-project-ignore-regexp - (file-name-nondirectory file)) - (file-directory-p file)) - (setcdr lnames - (cons (cons (muse-page-name file) file) nil)) - (setq lnames (cdr lnames))))) - ((file-readable-p path) - (setcdr lnames - (cons (cons (muse-page-name path) path) nil)) - (setq lnames (cdr lnames))) - (t ; regexp - (muse-assert (file-name-directory path)) - (dolist (file (directory-files - (file-name-directory path) t - (file-name-nondirectory path))) - (unless (or (string-match muse-project-ignore-regexp file) - (string-match muse-project-ignore-regexp - (file-name-nondirectory file))) - (setcdr lnames - (cons (cons (muse-page-name file) file) nil)) - (setq lnames (cdr lnames)))))) - (cdr names))) - -(defvar muse-updating-file-alist-p nil - "Make sure that recursive calls to `muse-project-file-alist' are bounded.") - -(defun muse-project-determine-last-mod (project &optional no-check-p) - "Return the most recent last-modified timestamp of dirs in PROJECT." - (let ((last-mod nil)) - (unless (or muse-under-windows-p no-check-p) - (let ((pats (cadr project))) - (while pats - (if (symbolp (car pats)) - (setq pats (cddr pats)) - (let* ((fnd (file-name-directory (car pats))) - (dir (cond ((file-directory-p (car pats)) - (car pats)) - ((and (not (file-readable-p (car pats))) - fnd - (file-directory-p fnd)) - fnd)))) - (when dir - (let ((mod-time (nth 5 (file-attributes dir)))) - (when (or (null last-mod) - (and mod-time - (muse-time-less-p last-mod mod-time))) - (setq last-mod mod-time))))) - (setq pats (cdr pats)))))) - last-mod)) - -(defun muse-project-file-alist (&optional project no-check-p) - "Return member filenames for the given Muse PROJECT. -Also, update the `muse-project-file-alist' variable. - -On UNIX, this alist is only updated if one of the directories' -contents have changed. On Windows, it is always reread from -disk. - -If NO-CHECK-P is non-nil, do not update the alist, just return -the current one." - (setq project (muse-project project)) - (when (and project muse-project-alist) - (let* ((file-alist (assoc (car project) muse-project-file-alist)) - (last-mod (muse-project-determine-last-mod project no-check-p))) - ;; Either return the currently known list, or read it again from - ;; disk - (if (or (and no-check-p (cadr file-alist)) - muse-updating-file-alist-p - (not (or muse-under-windows-p - (null (cddr file-alist)) - (null last-mod) - (muse-time-less-p (cddr file-alist) last-mod)))) - (cadr file-alist) - (if file-alist - (setcdr (cdr file-alist) last-mod) - (setq file-alist (cons (car project) (cons nil last-mod)) - muse-project-file-alist - (cons file-alist muse-project-file-alist))) - ;; Read in all of the file entries - (let ((muse-updating-file-alist-p t)) - (prog1 - (save-match-data - (setcar - (cdr file-alist) - (let* ((names (list t)) - (pats (cadr project))) - (while pats - (if (symbolp (car pats)) - (setq pats (cddr pats)) - (nconc names (muse-project-file-entries (car pats))) - (setq pats (cdr pats)))) - (cdr names)))) - (run-hooks 'muse-project-file-alist-hook))))))) - -(defun muse-project-add-to-alist (file &optional project) - "Make sure FILE is added to `muse-project-file-alist'. - -It works by either calling the `muse-project-file-alist' function -if a directory has been modified since we last checked, or -manually forcing the file entry to exist in the alist. This -works around an issue where if several files being saved at the -same time, only the first one will make it into the alist. It is -meant to be called by `muse-project-after-save-hook'. - -The project of the file is determined by either the PROJECT -argument, or `muse-project-of-file' if PROJECT is not specified." - (setq project (or (muse-project project) (muse-project-of-file file))) - (when (and project muse-project-alist) - (let* ((file-alist (assoc (car project) muse-project-file-alist)) - (last-mod (muse-project-determine-last-mod project))) - ;; Determine whether we need to call this - (if (or (null (cddr file-alist)) - (null last-mod) - (muse-time-less-p (cddr file-alist) last-mod)) - ;; The directory will show up as modified, so go ahead and - ;; call `muse-project-file-alist' - (muse-project-file-alist project) - ;; It is not showing as modified, so forcefully add the - ;; current file to the project file-alist - (let ((muse-updating-file-alist-p t)) - (prog1 - (save-match-data - (setcar (cdr file-alist) - (nconc (muse-project-file-entries file) - (cadr file-alist)))) - (run-hooks 'muse-project-file-alist-hook))))))) - -(defun muse-project-of-file (&optional pathname) - "Determine which project the given PATHNAME relates to. -If PATHNAME is nil, the current buffer's filename is used." - (if (and (null pathname) muse-current-project) - muse-current-project - (unless pathname (setq pathname (muse-current-file))) - (save-match-data - (when (and (stringp pathname) - muse-project-alist - (not (string= pathname "")) - (not (let ((case-fold-search nil)) - (or (string-match muse-project-ignore-regexp - pathname) - (string-match muse-project-ignore-regexp - (file-name-nondirectory - pathname)))))) - (let* ((file (file-truename pathname)) - (dir (file-name-directory file)) - found rating matches) - (catch 'found - (dolist (project-entry muse-project-alist) - (let ((pats (cadr project-entry))) - (while pats - (if (symbolp (car pats)) - (setq pats (cddr pats)) - (let ((tname (file-truename (car pats)))) - (cond ((or (string= tname file) - (string= (file-name-as-directory tname) dir)) - (throw 'found project-entry)) - ((string-match (concat "\\`" (regexp-quote tname)) - file) - (setq matches (cons (cons (match-end 0) - project-entry) - matches))))) - (setq pats (cdr pats)))))) - ;; if we haven't found an exact match, pick a candidate - (car (muse-sort-by-rating matches)))))))) - -(defun muse-project-after-save-hook () - "Update Muse's file-alist if we are saving a Muse file." - (let ((project (muse-project-of-file))) - (when project - (muse-project-add-to-alist (buffer-file-name) project)))) - -(add-hook 'after-save-hook 'muse-project-after-save-hook) - -(defun muse-read-project (prompt &optional no-check-p no-assume) - "Read a project name from the minibuffer, if it can't be figured - out." - (if (null muse-project-alist) - (error "There are no Muse projects defined; see `muse-project-alist'") - (or (unless no-check-p - (muse-project-of-file)) - (if (and (not no-assume) - (= 1 (length muse-project-alist))) - (car muse-project-alist) - (assoc (funcall muse-completing-read-function - prompt muse-project-alist) - muse-project-alist))))) - -(defvar muse-project-page-history nil) - -(defun muse-read-project-file (project prompt &optional default) - (let* ((file-list (muse-delete-dups - (mapcar #'(lambda (a) (list (car a))) - (muse-project-file-alist project)))) - (name (funcall muse-completing-read-function - prompt file-list nil nil nil - 'muse-project-page-history default))) - (cons name (muse-project-page-file name project)))) - -;;;###autoload -(defun muse-project-find-file (name project &optional command directory) - "Open the Muse page given by NAME in PROJECT. -If COMMAND is non-nil, it is the function used to visit the file. -If DIRECTORY is non-nil, it is the directory in which the page -will be created if it does not already exist. Otherwise, the -first directory within the project's fileset is used." - (interactive - (let* ((project (muse-read-project "Find in project: " - current-prefix-arg)) - (default (muse-get-keyword :default (cadr project))) - (entry (muse-read-project-file - project (if default - (format "Find page: (default: %s) " - default) - "Find page: ") - default))) - (list entry project))) - (setq project (muse-project project)) - (let ((project-name (car project))) - (unless (interactive-p) - (setq project (muse-project project) - name (cons name (muse-project-page-file name project)))) - ;; If we're given a relative or absolute filename, open it as-is - (if (and (car name) - (save-match-data - (or (string-match "\\`\\.+/" (car name)) - (string-match muse-file-regexp (car name)) - (string-match muse-image-regexp (car name))))) - (setcdr name (car name)) - ;; At this point, name is (PAGE . FILE). - (unless (cdr name) - (let ((pats (cadr project))) - (while (and pats (null directory)) - (if (symbolp (car pats)) - (setq pats (cddr pats)) - (if (file-directory-p (car pats)) - (setq directory (car pats) pats nil) - (setq pats (cdr pats)))))) - (when directory - (let ((filename (expand-file-name (car name) directory))) - (when (and muse-file-extension - (not (string= muse-file-extension "")) - (not (file-exists-p (car name)))) - (setq filename (concat filename "." muse-file-extension))) - (unless (file-exists-p directory) - (make-directory directory t)) - (setcdr name filename))))) - ;; Open the file - (if (cdr name) - (funcall (or command 'find-file) (cdr name)) - (error "There is no page %s in project %s" - (car name) project-name)))) - -(defun muse-project-choose-style (closure test styles) - "Run TEST on STYLES and return first style where TEST yields non-nil. -TEST should take two arguments. The first is CLOSURE, which is -passed verbatim. The second if the current style to consider. - -If no style passes TEST, return the first style." - (or (catch 'winner - (dolist (style styles) - (when (funcall test closure style) - (throw 'winner style)))) - (car styles))) - -(defun muse-project-choose-style-by-link-suffix (given-suffix style) - "If the given STYLE has a link-suffix that equals GIVEN-SUFFIX, -return non-nil." - (let ((link-suffix (or (muse-style-element :link-suffix style) - (muse-style-element :suffix style)))) - (and (stringp link-suffix) - (string= given-suffix link-suffix)))) - -(defun muse-project-applicable-styles (file styles) - "Given STYLES, return a list of the ones that are considered for FILE. -The name of a project may be used for STYLES." - (when (stringp styles) - (setq styles (cddr (muse-project styles)))) - (when (and file styles) - (let ((used-styles nil)) - (dolist (style styles) - (let ((include-regexp (muse-style-element :include style)) - (exclude-regexp (muse-style-element :exclude style)) - (rating nil)) - (when (and (or (and (null include-regexp) - (null exclude-regexp)) - (if include-regexp - (setq rating (string-match include-regexp file)) - (not (string-match exclude-regexp file)))) - (file-exists-p file) - (not (muse-project-private-p file))) - (setq used-styles (cons (cons rating style) used-styles))))) - (muse-sort-by-rating (nreverse used-styles))))) - -(defun muse-project-get-applicable-style (file styles) - "Choose a style from the STYLES that FILE can publish to. -The user is prompted if several styles are found." - (muse-publish-get-style - (mapcar (lambda (style) - (cons (muse-get-keyword :base style) style)) - (muse-project-applicable-styles file styles)))) - -(defun muse-project-resolve-directory (page local-style remote-style) - "Figure out the directory part of the path that provides a link to PAGE. -LOCAL-STYLE is the style of the current Muse file, and -REMOTE-STYLE is the style associated with PAGE. - -If REMOTE-STYLE has a :base-url element, concatenate it and PAGE. -Otherwise, return a relative link." - (let ((prefix (muse-style-element :base-url remote-style))) - (if prefix - (concat prefix page) - (file-relative-name (expand-file-name - (file-name-nondirectory page) - (muse-style-element :path remote-style)) - (expand-file-name - (muse-style-element :path local-style)))))) - -(defun muse-project-resolve-link (page local-style remote-styles) - "Return a published link from the output path of one file to another file. - -The best match for PAGE is determined by comparing the link -suffix of the given local style and that of the remote styles. - -The remote styles are usually populated by -`muse-project-applicable-styles'. - -If no remote style is found, return PAGE verbatim - -If PAGE has a :base-url associated with it, return the -concatenation of the :base-url value and PAGE. - -Otherwise, return a relative path from the directory of -LOCAL-STYLE to the best directory among REMOTE-STYLES." - (let ((link-suffix (or (muse-style-element :link-suffix local-style) - (muse-style-element :suffix local-style))) - remote-style) - (if (not (stringp link-suffix)) - (setq remote-style (car remote-styles)) - (setq remote-style (muse-project-choose-style - link-suffix - #'muse-project-choose-style-by-link-suffix - remote-styles))) - (if (null remote-style) - page - (setq page (muse-project-resolve-directory - page local-style remote-style)) - (concat (file-name-directory page) - (muse-publish-link-name page remote-style))))) - -(defun muse-project-current-output-style (&optional file project) - (or muse-current-output-style - (progn - (unless file (setq file (muse-current-file))) - (unless project (setq project (muse-project-of-file file))) - (car (muse-project-applicable-styles file (cddr project)))))) - -(defun muse-project-link-page (page) - (let ((project (muse-project-of-file))) - (muse-project-resolve-link page - (muse-project-current-output-style) - (muse-project-applicable-styles - (muse-project-page-file page project) - (cddr project))))) - -(defun muse-project-publish-file-default (file style output-dir force) - ;; ensure the publishing location is available - (unless (file-exists-p output-dir) - (message "Creating publishing directory %s" output-dir) - (make-directory output-dir t)) - ;; publish the member file! - (muse-publish-file file style output-dir force)) - -(defun muse-project-publish-file (file styles &optional force) - (setq styles (muse-project-applicable-styles file styles)) - (let (published) - (dolist (style styles) - (if (or (not (listp style)) - (not (cdr style))) - (muse-display-warning - (concat "Skipping malformed muse-project-alist style." - "\nPlease double-check your configuration,")) - (let ((output-dir (muse-style-element :path style)) - (muse-current-output-style style) - (fun (or (muse-style-element :publish style t) - 'muse-project-publish-file-default))) - (when (funcall fun file style output-dir force) - (setq published t))))) - published)) - -;;;###autoload -(defun muse-project-publish-this-file (&optional force style) - "Publish the currently-visited file according to `muse-project-alist', -prompting if more than one style applies. - -If FORCE is given, publish the file even if it is up-to-date. - -If STYLE is given, use that publishing style rather than -prompting for one." - (interactive (list current-prefix-arg)) - (let ((muse-current-project (muse-project-of-file))) - (if (not muse-current-project) - ;; file is not part of a project, so fall back to muse-publish - (if (interactive-p) (call-interactively 'muse-publish-this-file) - (muse-publish-this-file style nil force)) - (unless style - (setq style (muse-project-get-applicable-style - buffer-file-name (cddr muse-current-project)))) - (let* ((output-dir (muse-style-element :path style)) - (muse-current-project-global muse-current-project) - (muse-current-output-style (list :base (car style) - :path output-dir)) - (fun (or (muse-style-element :publish style t) - 'muse-project-publish-file-default))) - (unless (funcall fun buffer-file-name style output-dir force) - (message (concat "The published version is up-to-date; use" - " C-u C-c C-t to force an update."))))))) - -(defun muse-project-save-buffers (&optional project) - (setq project (muse-project project)) - (when project - (save-excursion - (map-y-or-n-p - (function - (lambda (buffer) - (and (buffer-modified-p buffer) - (not (buffer-base-buffer buffer)) - (or (buffer-file-name buffer) - (progn - (set-buffer buffer) - (and buffer-offer-save - (> (buffer-size) 0)))) - (with-current-buffer buffer - (let ((proj (muse-project-of-file))) - (and proj (string= (car proj) - (car project))))) - (if (buffer-file-name buffer) - (format "Save file %s? " - (buffer-file-name buffer)) - (format "Save buffer %s? " - (buffer-name buffer)))))) - (function - (lambda (buffer) - (set-buffer buffer) - (save-buffer))) - (buffer-list) - '("buffer" "buffers" "save") - (if (boundp 'save-some-buffers-action-alist) - save-some-buffers-action-alist))))) - -(defun muse-project-publish-default (project styles &optional force) - "Publish the pages of PROJECT that need publishing." - (setq project (muse-project project)) - (let ((published nil)) - ;; publish all files in the project, for each style; the actual - ;; publishing will only happen if the files are newer than the - ;; last published output, or if the file is listed in - ;; :force-publish. Files in :force-publish will not trigger the - ;; "All pages need to be published" message. - (let ((forced-files (muse-get-keyword :force-publish (cadr project))) - (file-alist (muse-project-file-alist project))) - (dolist (pair file-alist) - (when (muse-project-publish-file (cdr pair) styles force) - (setq forced-files (delete (car pair) forced-files)) - (setq published t))) - (dolist (file forced-files) - (muse-project-publish-file (cdr (assoc file file-alist)) styles t))) - ;; run hook after publishing ends - (run-hook-with-args 'muse-after-project-publish-hook project) - ;; notify the user that everything is now done - (if published - (message "All pages in %s have been published." (car project)) - (message "No pages in %s need publishing at this time." - (car project))))) - -;;;###autoload -(defun muse-project-publish (project &optional force) - "Publish the pages of PROJECT that need publishing." - (interactive (list (muse-read-project "Publish project: " nil t) - current-prefix-arg)) - (setq project (muse-project project)) - (let ((styles (cddr project)) - (muse-current-project project) - (muse-current-project-global project)) - ;; determine the style from the project, or else ask - (unless styles - (setq styles (list (muse-publish-get-style)))) - (unless project - (error "Cannot find a project to publish")) - ;; prompt to save any buffers related to this project - (muse-project-save-buffers project) - ;; run hook before publishing begins - (run-hook-with-args 'muse-before-project-publish-hook project) - ;; run the project-level publisher - (let ((fun (or (muse-get-keyword :publish-project (cadr project) t) - 'muse-project-publish-default))) - (funcall fun project styles force)))) - -(defun muse-project-batch-publish () - "Publish Muse files in batch mode." - (let ((muse-batch-publishing-p t) - force) - (if (string= "--force" (or (car command-line-args-left) "")) - (setq force t - command-line-args-left (cdr command-line-args-left))) - (if command-line-args-left - (dolist (project command-line-args-left) - (message "Publishing project %s ..." project) - (muse-project-publish project force)) - (message "No projects specified.")))) - -(eval-when-compile - (put 'make-local-hook 'byte-compile nil)) - -(defun muse-project-set-variables () - "Load project-specific variables." - (when (and muse-current-project-global (null muse-current-project)) - (setq muse-current-project muse-current-project-global)) - (let ((vars (muse-get-keyword :set (cadr muse-current-project))) - sym custom-set var) - (while vars - (setq sym (car vars)) - (setq custom-set (or (get sym 'custom-set) 'set)) - (setq var (if (eq (get sym 'custom-type) 'hook) - (make-local-hook sym) - (make-local-variable sym))) - (funcall custom-set var (car (cdr vars))) - (setq vars (cdr (cdr vars)))))) - -(custom-add-option 'muse-before-publish-hook 'muse-project-set-variables) -(add-to-list 'muse-before-publish-hook 'muse-project-set-variables) - -(defun muse-project-delete-output-files (project) - (interactive - (list (muse-read-project "Remove all output files for project: " nil t))) - (setq project (muse-project project)) - (let ((file-alist (muse-project-file-alist project)) - (styles (cddr project)) - output-file path) - (dolist (entry file-alist) - (dolist (style styles) - (setq output-file - (and (setq path (muse-style-element :path style)) - (expand-file-name - (concat (muse-style-element :prefix style) - (car entry) - (or (muse-style-element :osuffix style) - (muse-style-element :suffix style))) - path))) - (if output-file - (muse-delete-file-if-exists output-file)))))) - -;;; muse-project.el ends here diff --git a/emacs.d/elisp/muse/muse-protocols.el b/emacs.d/elisp/muse/muse-protocols.el deleted file mode 100644 index 5e1061c..0000000 --- a/emacs.d/elisp/muse/muse-protocols.el +++ /dev/null @@ -1,251 +0,0 @@ -;;; muse-protocols.el --- URL protocols that Muse recognizes - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Brad Collins (brad AT chenla DOT org) - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Here's an example for adding a protocol for the site yubnub, a Web -;; Command line service. -;; -;; (add-to-list 'muse-url-protocols '("yubnub://" muse-browse-url-yubnub -;; muse-resolve-url-yubnub)) -;; -;; (defun muse-resolve-url-yubnub (url) -;; "Resolve a yubnub URL." -;; ;; Remove the yubnub:// -;; (when (string-match "\\`yubnub://\\(.+\\)" url) -;; (match-string 1))) -;; -;; (defun muse-browse-url-yubnub (url) -;; "If this is a yubnub URL-command, jump to it." -;; (setq url (muse-resolve-url-yubnub url)) -;; (browse-url (concat "http://yubnub.org/parser/parse?command=" -;; url))) - -;;; Contributors: - -;; Phillip Lord (Phillip.Lord AT newcastle DOT ac DOT uk) provided a -;; handler for DOI URLs. - -;; Stefan Schlee fixed a bug with handling of colons at the end of -;; URLs. - -;; Valery V. Vorotyntsev contribued the woman:// protocol handler and -;; simplified `muse-browse-url-man'. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse URL Protocols -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'info) -(require 'muse-regexps) - -(defvar muse-url-regexp nil - "A regexp used to match URLs within a Muse page. -This is autogenerated from `muse-url-protocols'.") - -(defun muse-update-url-regexp (sym value) - (setq muse-url-regexp - (concat "\\<\\(" (mapconcat 'car value "\\|") "\\)" - "[^][" muse-regexp-blank "\"'()<>^`{}\n]*" - "[^][" muse-regexp-blank "\"'()<>^`{}.,;:\n]+")) - (set sym value)) - -(defcustom muse-url-protocols - '(("[uU][rR][lL]:" muse-browse-url-url identity) - ("info://" muse-browse-url-info nil) - ("man://" muse-browse-url-man nil) - ("woman://" muse-browse-url-woman nil) - ("google://" muse-browse-url-google muse-resolve-url-google) - ("http:/?/?" browse-url identity) - ("https:/?/?" browse-url identity) - ("ftp:/?/?" browse-url identity) - ("gopher://" browse-url identity) - ("telnet://" browse-url identity) - ("wais://" browse-url identity) - ("file://?" browse-url identity) - ("dict:" muse-browse-url-dict muse-resolve-url-dict) - ("doi:" muse-browse-url-doi muse-resolve-url-doi) - ("news:" browse-url identity) - ("snews:" browse-url identity) - ("mailto:" browse-url identity)) - "A list of (PROTOCOL BROWSE-FUN RESOLVE-FUN) used to match URL protocols. -PROTOCOL describes the first part of the URL, including the -\"://\" part. This may be a regexp. - -BROWSE-FUN should accept URL as an argument and open the URL in -the current window. - -RESOLVE-FUN should accept URL as an argument and return the final -URL, or nil if no URL should be included." - :type '(repeat (list :tag "Protocol" - (string :tag "Regexp") - (function :tag "Browse") - (choice (function :tag "Resolve") - (const :tag "Don't resolve" nil)))) - :set 'muse-update-url-regexp - :group 'muse) - -(add-hook 'muse-update-values-hook - (lambda () - (muse-update-url-regexp 'muse-url-protocols muse-url-protocols))) - -(defcustom muse-wikipedia-country "en" - "Indicate the 2-digit country code that we use for Wikipedia -queries." - :type 'string - :options '("de" "en" "es" "fr" "it" "pl" "pt" "ja" "nl" "sv") - :group 'muse) - -(defun muse-protocol-find (proto list) - "Return the first element of LIST whose car matches the regexp PROTO." - (catch 'found - (dolist (item list) - (when (string-match (concat "\\`" (car item)) proto) - (throw 'found item))))) - -;;;###autoload -(defun muse-browse-url (url &optional other-window) - "Handle URL with the function specified in `muse-url-protocols'. -If OTHER-WINDOW is non-nil, open in a different window." - (interactive (list (read-string "URL: ") - current-prefix-arg)) - ;; Strip text properties - (when (fboundp 'set-text-properties) - (set-text-properties 0 (length url) nil url)) - (when other-window - (switch-to-buffer-other-window (current-buffer))) - (when (string-match muse-url-regexp url) - (let* ((proto (match-string 1 url)) - (entry (muse-protocol-find proto muse-url-protocols))) - (when entry - (funcall (cadr entry) url))))) - -(defun muse-resolve-url (url &rest ignored) - "Resolve URL with the function specified in `muse-url-protocols'." - (when (string-match muse-url-regexp url) - (let* ((proto (match-string 1 url)) - (entry (muse-protocol-find proto muse-url-protocols))) - (when entry - (let ((func (car (cddr entry)))) - (if func - (setq url (funcall func url)) - (setq url nil)))))) - url) - -(defun muse-protocol-add (protocol browse-function resolve-function) - "Add PROTOCOL to `muse-url-protocols'. PROTOCOL may be a regexp. - -BROWSE-FUNCTION should be a function that visits a URL in the -current buffer. - -RESOLVE-FUNCTION should be a function that transforms a URL for -publishing or returns nil if not linked." - (add-to-list 'muse-url-protocols - (list protocol browse-function resolve-function)) - (muse-update-url-regexp 'muse-url-protocols - muse-url-protocols)) - -(defun muse-browse-url-url (url) - "Call `muse-protocol-browse-url' to browse URL. -This is used when we are given something like -\"URL:http://example.org/\". - -If you're looking for a good example for how to make a custom URL -handler, look at `muse-browse-url-dict' instead." - (when (string-match "\\`[uU][rR][lL]:\\(.+\\)" url) - (muse-browse-url (match-string 1 url)))) - -(defun muse-resolve-url-dict (url) - "Return the Wikipedia link corresponding with the given URL." - (when (string-match "\\`dict:\\(.+\\)" url) - (concat "http://" muse-wikipedia-country ".wikipedia.org/" - "wiki/Special:Search?search=" (match-string 1 url)))) - -(defun muse-browse-url-dict (url) - "If this is a Wikipedia URL, browse it." - (let ((dict-url (muse-resolve-url-dict url))) - (when dict-url - (browse-url dict-url)))) - -(defun muse-resolve-url-doi (url) - "Return the URL through DOI proxy server." - (when (string-match "\\`doi:\\(.+\\)" url) - (concat "http://dx.doi.org/" - (match-string 1 url)))) - -(defun muse-browse-url-doi (url) - "If this is a DOI URL, browse it. - -DOI's (digitial object identifiers) are a standard identifier -used in the publishing industry." - (let ((doi-url (muse-resolve-url-doi url))) - (when doi-url - (browse-url doi-url)))) - -(defun muse-resolve-url-google (url) - "Return the correct Google search string." - (when (string-match "\\`google:/?/?\\(.+\\)" url) - (concat "http://www.google.com/search?q=" - (match-string 1 url)))) - -(defun muse-browse-url-google (url) - "If this is a Google URL, jump to it." - (let ((google-url (muse-resolve-url-google url))) - (when google-url - (browse-url google-url)))) - -(defun muse-browse-url-info (url) - "If this in an Info URL, jump to it." - (require 'info) - (cond - ((string-match "\\`info://\\([^#\n]+\\)#\\(.+\\)" url) - (Info-find-node (match-string 1 url) - (match-string 2 url))) - ((string-match "\\`info://\\([^#\n]+\\)" url) - (Info-find-node (match-string 1 url) - "Top")) - ((string-match "\\`info://(\\([^)\n]+\\))\\(.+\\)" url) - (Info-find-node (match-string 1 url) (match-string 2 url))) - ((string-match "\\`info://\\(.+\\)" url) - (Info-find-node (match-string 1 url) "Top")))) - -(defun muse-browse-url-man (url) - "If this in a manpage URL, jump to it." - (require 'man) - (when (string-match "\\`man://\\([^(]+\\(([^)]+)\\)?\\)" url) - (man (match-string 1 url)))) - -(defun muse-browse-url-woman (url) - "If this is a WoMan URL, jump to it." - (require 'woman) - (when (string-match "\\`woman://\\(.+\\)" url) - (woman (match-string 1 url)))) - -(provide 'muse-protocols) - -;;; muse-protocols.el ends here diff --git a/emacs.d/elisp/muse/muse-publish.el b/emacs.d/elisp/muse/muse-publish.el deleted file mode 100644 index ec6e176..0000000 --- a/emacs.d/elisp/muse/muse-publish.el +++ /dev/null @@ -1,2193 +0,0 @@ -;;; muse-publish.el --- base publishing implementation - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Yann Hodique (yann DOT hodique AT gmail DOT com) fixed an -;; unnecessary URL description transform in `muse-publish-url'. - -;; Peter K. Lee (saint AT corenova DOT com) provided the -;; `muse-style-elements-list' function. - -;; Jim Ottaway (j DOT ottaway AT lse DOT ac DOT uk) provided a -;; reference implementation for nested lists, as well as some code for -;; the "style" element of the <literal> tag. - -;; Deus Max (deusmax AT gmail DOT com) provided the <php> tag. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'muse-publish) - -(require 'muse) -(require 'muse-regexps) - -(defgroup muse-publish nil - "Options controlling the general behavior of Muse publishing." - :group 'muse) - -(defcustom muse-before-publish-hook nil - "A hook run in the buffer to be published, before it is done." - :type 'hook - :group 'muse-publish) - -(defcustom muse-after-publish-hook nil - "A hook run in the buffer to be published, after it is done." - :type 'hook - :group 'muse-publish) - -(defcustom muse-publish-url-transforms - '(muse-resolve-url) - "A list of functions used to prepare URLs for publication. -Each is passed the URL. The transformed URL should be returned." - :type 'hook - :options '(muse-resolve-url) - :group 'muse-publish) - -(defcustom muse-publish-desc-transforms - '(muse-publish-strip-URL) - "A list of functions used to prepare URL desciptions for publication. -Each is passed the description. The modified description should -be returned." - :type 'hook - :options '(muse-publish-strip-URL) - :group 'muse-publish) - -(defcustom muse-publish-date-format "%B %e, %Y" - "Format string for the date, used by `muse-publish-markup-buffer'. -See `format-time-string' for details on the format options." - :type 'string - :group 'muse-publish) - -(defcustom muse-publish-comments-p nil - "If nil, remove comments before publishing. -If non-nil, publish comments using the markup of the current style." - :type 'boolean - :group 'muse-publish) - -(defcustom muse-publish-report-threshhold 100000 - "If a file is this size or larger, report publishing progress." - :type 'integer - :group 'muse-publish) - -(defcustom muse-publish-markup-regexps - `(;; Remove leading and trailing whitespace from the file - (1000 "\\(\\`\n+\\|\n+\\'\\)" 0 "") - - ;; Remove trailing whitespace from all lines - (1100 ,(concat "[" muse-regexp-blank "]+$") 0 "") - - ;; Handle any leading #directives - (1200 "\\`#\\([a-zA-Z-]+\\)\\s-+\\(.+\\)\n+" 0 directive) - - ;; commented lines - (1250 ,(concat "^;\\(?:[" muse-regexp-blank "]+\\(.+\\)\\|$\\|'\\)") - 0 comment) - - ;; markup tags - (1300 muse-tag-regexp 0 tag) - - ;; prevent emphasis characters in explicit links from being marked - (1400 muse-explicit-link-regexp 0 muse-publish-mark-link) - - ;; emphasized or literal text - (1600 ,(concat "\\(^\\|[-[" muse-regexp-blank - "<('`\"\n]\\)\\(=[^=" muse-regexp-blank - "\n]\\|_[^_" muse-regexp-blank - "\n]\\|\\*+[^*" muse-regexp-blank - "\n]\\)") - 2 word) - - ;; headings, outline-mode style - (1700 "^\\(\\*+\\)\\s-+" 0 heading) - - ;; ellipses - (1800 "\\.\\.\\.\\." 0 enddots) - (1850 "\\.\\.\\." 0 dots) - - ;; horizontal rule, or section separator - (1900 "^----+" 0 rule) - - ;; non-breaking space - (1950 "~~" 0 no-break-space) - - ;; beginning of footnotes section - (2000 "^Footnotes:?\\s-*" 0 fn-sep) - ;; footnote definition/reference (def if at beginning of line) - (2100 "\\[\\([1-9][0-9]*\\)\\]" 0 footnote) - - ;; unnumbered List items begin with a -. numbered list items - ;; begin with number and a period. definition lists have a - ;; leading term separated from the body with ::. centered - ;; paragraphs begin with at least six columns of whitespace; any - ;; other whitespace at the beginning indicates a blockquote. The - ;; reason all of these rules are handled here, is so that - ;; blockquote detection doesn't interfere with indented list - ;; members. - (2200 ,(format muse-list-item-regexp (concat "[" muse-regexp-blank "]*")) - 0 list) - - ;; support table.el style tables - (2300 ,(concat "^" muse-table-el-border-regexp "\n" - "\\(\\(" muse-table-el-line-regexp "\n\\)+" - "\\(" muse-table-el-border-regexp "\\)" - "\\(\n\\|\\'\\)\\)+") - 0 table-el) - - ;; simple table markup is supported, nothing fancy. use | to - ;; separate cells, || to separate header cells, and ||| for footer - ;; cells - (2350 ,(concat "\\(\\([" muse-regexp-blank "]*\n\\)?" - "\\(\\(?:" muse-table-line-regexp "\\|" - muse-table-hline-regexp "\\)\\(?:\n\\|\\'\\)\\)\\)+") - 0 table) - - ;; blockquote and centered text - (2400 ,(concat "^\\([" muse-regexp-blank "]+\\).+") 0 quote) - - ;; the emdash ("--" or "---") - (2500 ,(concat "\\(^\\|[" muse-regexp-blank "]*\\)---?\\($\\|[" - muse-regexp-blank "]*\\)") - 0 emdash) - - ;; "verse" text is indicated the same way as a quoted e-mail - ;; response: "> text", where text may contain initial whitespace - ;; (see below). - (2600 ,(concat "^[" muse-regexp-blank "]*> ") 0 verse) - - ;; define anchor points - (2700 "^\\(\\W*\\)#\\(\\S-+\\)\\s-*" 0 anchor) - - ;; replace links in the buffer (links to other pages) - (2900 muse-explicit-link-regexp 0 link) - - ;; bare URLs - (3000 muse-url-regexp 0 url) - - ;; bare email addresses - (3500 - "\\([^[]\\)[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" 0 email) - ) - "List of markup rules for publishing a page with Muse. -The rules given in this variable are invoked first, followed by -whatever rules are specified by the current style. - -Each member of the list is either a function, or a list of the form: - - (REGEXP/SYMBOL TEXT-BEGIN-GROUP REPLACEMENT-TEXT/FUNCTION/SYMBOL) - -REGEXP is a regular expression, or symbol whose value is a regular -expression, which is searched for using `re-search-forward'. -TEXT-BEGIN-GROUP is the matching group within that regexp which -denotes the beginning of the actual text to be marked up. -REPLACEMENT-TEXT is a string that will be passed to `replace-match'. -If it is not a string, but a function, it will be called to determine -what the replacement text should be (it must return a string). If it -is a symbol, the value of that symbol should be a string. - -The replacements are done in order, one rule at a time. Writing -the regular expressions can be a tricky business. Note that case -is never ignored. `case-fold-search' is always bound to nil -while processing the markup rules." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-publish) - -(defcustom muse-publish-markup-functions - '((directive . muse-publish-markup-directive) - (comment . muse-publish-markup-comment) - (anchor . muse-publish-markup-anchor) - (tag . muse-publish-markup-tag) - (word . muse-publish-markup-word) - (emdash . muse-publish-markup-emdash) - (enddots . muse-publish-markup-enddots) - (dots . muse-publish-markup-dots) - (rule . muse-publish-markup-rule) - (no-break-space . muse-publish-markup-no-break-space) - (heading . muse-publish-markup-heading) - (footnote . muse-publish-markup-footnote) - (fn-sep . muse-publish-markup-fn-sep) - (list . muse-publish-markup-list) - (quote . muse-publish-markup-quote) - (verse . muse-publish-markup-verse) - (table . muse-publish-markup-table) - (table-el . muse-publish-markup-table-el) - (email . muse-publish-markup-email) - (link . muse-publish-markup-link) - (url . muse-publish-markup-url)) - "An alist of style types to custom functions for that kind of text. - -Each member of the list is of the form: - - (SYMBOL FUNCTION) - -SYMBOL describes the type of text to associate with this rule. -`muse-publish-markup-regexps' maps regexps to these symbols. - -FUNCTION is the function to use to mark up this kind of rule if -no suitable function is found through the :functions tag of the -current style." - :type '(alist :key-type symbol :value-type function) - :group 'muse-publish) - -(defcustom muse-publish-markup-tags - '(("contents" nil t nil muse-publish-contents-tag) - ("verse" t nil nil muse-publish-verse-tag) - ("example" t nil nil muse-publish-example-tag) - ("src" t t nil muse-publish-src-tag) - ("code" t nil nil muse-publish-code-tag) - ("quote" t nil t muse-publish-quote-tag) - ("literal" t t nil muse-publish-literal-tag) - ("verbatim" t nil nil muse-publish-verbatim-tag) - ("br" nil nil nil muse-publish-br-tag) - ("lisp" t t nil muse-publish-lisp-tag) - ("class" t t nil muse-publish-class-tag) - ("div" t t nil muse-publish-div-tag) - ("command" t t nil muse-publish-command-tag) - ("perl" t t nil muse-publish-perl-tag) - ("php" t t nil muse-publish-php-tag) - ("python" t t nil muse-publish-python-tag) - ("ruby" t t nil muse-publish-ruby-tag) - ("comment" t nil nil muse-publish-comment-tag) - ("include" nil t nil muse-publish-include-tag) - ("markup" t t nil muse-publish-mark-up-tag) - ("cite" t t nil muse-publish-cite-tag)) - "A list of tag specifications, for specially marking up text. -XML-style tags are the best way to add custom markup to Muse. -This is easily accomplished by customizing this list of markup tags. - -For each entry, the name of the tag is given, whether it expects -a closing tag, whether it takes an optional set of attributes, -whether it is nestable, and a function that performs whatever -action is desired within the delimited region. - -The tags themselves are deleted during publishing, before the -function is called. The function is called with three arguments, -the beginning and end of the region surrounded by the tags. If -properties are allowed, they are passed as a third argument in -the form of an alist. The `end' argument to the function is -always a marker. - -Point is always at the beginning of the region within the tags, when -the function is called. Wherever point is when the function finishes -is where tag markup will resume. - -These tag rules are processed once at the beginning of markup, and -once at the end, to catch any tags which may have been inserted -in-between." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-publish) - -(defcustom muse-publish-markup-header-footer-tags - '(("lisp" t t nil muse-publish-lisp-tag) - ("markup" t t nil muse-publish-mark-up-tag)) - "Tags used when publishing headers and footers. -See `muse-publish-markup-tags' for details." - :type '(repeat (list (string :tag "Markup tag") - (boolean :tag "Expect closing tag" :value t) - (boolean :tag "Parse attributes" :value nil) - (boolean :tag "Nestable" :value nil) - function)) - :group 'muse-publish) - -(defcustom muse-publish-markup-specials nil - "A table of characters which must be represented specially." - :type '(alist :key-type character :value-type string) - :group 'muse-publish) - -(defcustom muse-publish-enable-local-variables nil - "If non-nil, interpret local variables in a file when publishing." - :type 'boolean - :group 'muse-publish) - -(defcustom muse-publish-enable-dangerous-tags t - "If non-nil, publish tags like <lisp> and <command> that can -call external programs or expose sensitive information. -Otherwise, ignore tags like this. - -This is useful to set to nil when the file to publish is coming -from an untrusted source." - :type 'boolean - :group 'muse-publish) - -(defvar muse-publishing-p nil - "This is set to t while a page is being published.") -(defvar muse-batch-publishing-p nil - "This is set to t while a page is being batch published.") -(defvar muse-inhibit-before-publish-hook nil - "This is set to t when publishing a file rather than just a buffer. -It is used by `muse-publish-markup-buffer'.") -(defvar muse-publishing-styles nil - "The publishing styles that Muse recognizes. -This is automatically generated when loading publishing styles.") -(defvar muse-publishing-current-file nil - "The file that is currently being published.") -(defvar muse-publishing-current-output-path nil - "The path where the current file will be published to.") -(defvar muse-publishing-current-style nil - "The style of the file that is currently being published.") -(defvar muse-publishing-directives nil - "An alist of publishing directives from the top of a file.") -(defvar muse-publish-generate-contents nil - "Non-nil if a table of contents should be generated. -If non-nil, it is a cons cell specifying (MARKER . DEPTH), to -tell where the <contents> was seen, and to what depth the -contents were requested.") -(defvar muse-publishing-last-position nil - "Last position of the point when publishing. -This is used to make sure that publishing doesn't get stalled.") - -(defvar muse-publish-inhibit-style-hooks nil - "If non-nil, do not call the :before or :before-end hooks when publishing.") - -(defvar muse-publish-use-header-footer-tags nil - "If non-nil, use `muse-publish-markup-header-footer-tags' for looking up -tags. Otherwise, use `muse-publish-markup-tags'.") - -(defvar muse-inhibit-style-tags nil - "If non-nil, do not search for style-specific tags. -This is used when publishing headers and footers.") - -;; Functions for handling style information - -(defsubst muse-style (&optional style) - "Resolve the given STYLE into a Muse style, if it is a string." - (if (null style) - muse-publishing-current-style - (if (stringp style) - (assoc style muse-publishing-styles) - (muse-assert (consp style)) - style))) - -(defun muse-define-style (name &rest elements) - (let ((entry (assoc name muse-publishing-styles))) - (if entry - (setcdr entry elements) - (setq muse-publishing-styles - (cons (append (list name) elements) - muse-publishing-styles))))) - -(defun muse-derive-style (new-name base-name &rest elements) - (apply 'muse-define-style new-name - (append elements (list :base base-name)))) - -(defsubst muse-get-keyword (keyword list &optional direct) - (let ((value (cadr (memq keyword list)))) - (if (and (not direct) (symbolp value)) - (symbol-value value) - value))) - -(defun muse-style-elements-list (elem &optional style) - "Return a list all references to ELEM in STYLE, including base styles. -If STYLE is not specified, use current style." - (let (base elements) - (while style - (setq style (muse-style style)) - (setq elements (append elements - (muse-get-keyword elem style))) - (setq style (muse-get-keyword :base style))) - elements)) - -(defun muse-style-element (elem &optional style direct) - "Search for ELEM in STYLE, including base styles. -If STYLE is not specified, use current style." - (setq style (muse-style style)) - (let ((value (muse-get-keyword elem style direct))) - (if value - value - (let ((base (muse-get-keyword :base style))) - (if base - (muse-style-element elem base direct)))))) - -(defun muse-style-derived-p-1 (base style) - "Internal function used by `muse-style-derived-p'." - (if (and (stringp style) - (string= style base)) - t - (setq style (muse-style style)) - (let ((value (muse-get-keyword :base style))) - (when value - (muse-style-derived-p base value))))) - -(defun muse-style-derived-p (base &optional style) - "Return non-nil if STYLE is equal to or derived from BASE, -non-nil otherwise. - -BASE should be a string." - (unless style - (setq style (muse-style))) - (when (and (consp style) - (stringp (car style))) - (setq style (car style))) - (muse-style-derived-p-1 base style)) - -(defun muse-find-markup-element (keyword ident style) - (let ((def (assq ident (muse-style-element keyword style)))) - (if def - (cdr def) - (let ((base (muse-style-element :base style))) - (if base - (muse-find-markup-element keyword ident base)))))) - -(defun muse-markup-text (ident &rest args) - "Insert ARGS into the text markup associated with IDENT. -If the markup text has sections like %N%, this will be replaced -with the N-1th argument in ARGS. After that, `format' is applied -to the text with ARGS as parameters." - (let ((text (muse-find-markup-element :strings ident (muse-style)))) - (if (and text args) - (progn - (let (start repl-text) - (while (setq start (string-match "%\\([1-9][0-9]*\\)%" text start)) - ;; escape '%' in the argument text, since we will be - ;; using format on it - (setq repl-text (muse-replace-regexp-in-string - "%" "%%" - (nth (1- (string-to-number - (match-string 1 text))) args) - t t) - start (+ start (length repl-text)) - text (replace-match repl-text t t text)))) - (apply 'format text args)) - (or text "")))) - -(defun muse-insert-markup (&rest args) - (let ((beg (point))) - (apply 'insert args) - (muse-publish-mark-read-only beg (point)))) - -(defun muse-find-markup-tag (keyword tagname style) - (let ((def (assoc tagname (muse-style-element keyword style)))) - (or def - (let ((base (muse-style-element :base style))) - (if base - (muse-find-markup-tag keyword tagname base)))))) - -(defun muse-markup-tag-info (tagname &rest args) - (let ((tag-info (and (not muse-inhibit-style-tags) - (muse-find-markup-tag :tags tagname (muse-style))))) - (or tag-info - (assoc tagname - (if muse-publish-use-header-footer-tags - muse-publish-markup-header-footer-tags - muse-publish-markup-tags))))) - -(defsubst muse-markup-function (category) - (let ((func (muse-find-markup-element :functions category (muse-style)))) - (or func - (cdr (assq category muse-publish-markup-functions))))) - -;; Publishing routines - -(defun muse-publish-markup (name rules) - (let* ((case-fold-search nil) - (inhibit-read-only t) - (limit (* (length rules) (point-max))) - (verbose (and muse-publish-report-threshhold - (> (point-max) muse-publish-report-threshhold))) - (base 0)) - (while rules - (goto-char (point-min)) - (let ((regexp (nth 1 (car rules))) - (group (nth 2 (car rules))) - (repl (nth 3 (car rules))) - pos) - (setq muse-publishing-last-position nil) - (if (symbolp regexp) - (setq regexp (symbol-value regexp))) - (if (and verbose (not muse-batch-publishing-p)) - (message "Publishing %s...%d%%" name - (* (/ (float (+ (point) base)) limit) 100))) - (while (and regexp (progn - (when (and (get-text-property (point) 'read-only) - (> (point) (point-min))) - (goto-char (or (next-single-property-change - (point) 'read-only) - (point-max)))) - (setq pos (re-search-forward regexp nil t)))) - (if (and verbose (not muse-batch-publishing-p)) - (message "Publishing %s...%d%%" name - (* (/ (float (+ (point) base)) limit) 100))) - (unless (and (> (- (match-end 0) (match-beginning 0)) 0) - (match-beginning group) - (get-text-property (match-beginning group) 'read-only)) - (let* (func - (text (cond - ((and (symbolp repl) - (setq func (muse-markup-function repl))) - (funcall func)) - ((functionp repl) - (funcall repl)) - ((symbolp repl) - (symbol-value repl)) - (t repl)))) - (if (stringp text) - (replace-match text t)))) - (if (and muse-publishing-last-position - (= pos muse-publishing-last-position)) - (if (eobp) - (setq regexp nil) - (forward-char 1))) - (setq muse-publishing-last-position pos))) - (setq rules (cdr rules) - base (+ base (point-max)))) - (if (and verbose (not muse-batch-publishing-p)) - (message "Publishing %s...done" name)))) - -(defun muse-insert-file-or-string (file-or-string &optional title) - (let ((beg (point)) end) - (if (and (not (string-equal file-or-string "")) - (not (string-match "\n" file-or-string)) - (file-readable-p file-or-string)) - (setq end (+ beg - (cadr (muse-insert-file-contents file-or-string)))) - (insert file-or-string) - (setq end (point))) - (save-restriction - (narrow-to-region beg end) - (remove-text-properties (point-min) (point-max) - '(read-only nil rear-nonsticky nil)) - (goto-char (point-min)) - (let ((muse-inhibit-style-tags t) - (muse-publish-use-header-footer-tags t)) - (muse-publish-markup (or title "") - '((100 muse-tag-regexp 0 - muse-publish-markup-tag))))))) - -(defun muse-style-run-hooks (keyword style &rest args) - (catch 'handled - (let ((cache nil)) - (while (and style - (setq style (muse-style style))) - (let ((func (muse-style-element keyword style t))) - (when (and func - (not (member func cache))) - (setq cache (cons func cache)) - (when (apply func args) - (throw 'handled t)))) - (setq style (muse-style-element :base style)))))) - -(defun muse-publish-markup-region (beg end &optional title style) - "Apply the given STYLE's markup rules to the given region. -TITLE is used when indicating the publishing progress; it may be nil. - -The point is guaranteed to be at END if the routine terminates -normally." - (unless title (setq title "")) - (unless style - (or (setq style muse-publishing-current-style) - (error "Cannot find any publishing styles to use"))) - (save-restriction - (narrow-to-region beg end) - (let ((muse-publish-generate-contents nil)) - (unless muse-publish-inhibit-style-hooks - (muse-style-run-hooks :before style)) - (muse-publish-markup - title - (sort (copy-alist (append muse-publish-markup-regexps - (muse-style-elements-list :regexps style))) - (function - (lambda (l r) - (< (car l) (car r)))))) - (unless muse-publish-inhibit-style-hooks - (muse-style-run-hooks :before-end style)) - (muse-publish-escape-specials (point-min) (point-max) nil 'document)) - (goto-char (point-max)))) - -(defun muse-publish-markup-buffer (title style) - "Apply the given STYLE's markup rules to the current buffer." - (setq style (muse-style style)) - (let ((style-header (muse-style-element :header style)) - (style-footer (muse-style-element :footer style)) - (muse-publishing-current-style style) - (muse-publishing-directives - (list (cons "title" title) - (cons "author" (user-full-name)) - (cons "date" (format-time-string - muse-publish-date-format - (if muse-publishing-current-file - (nth 5 (file-attributes - muse-publishing-current-file)) - (current-time)))))) - (muse-publishing-p t) - (inhibit-read-only t)) - (run-hooks 'muse-update-values-hook) - (unless muse-inhibit-before-publish-hook - (run-hooks 'muse-before-publish-hook)) - (muse-publish-markup-region (point-min) (point-max) title style) - (goto-char (point-min)) - (when style-header - (muse-insert-file-or-string style-header title)) - (goto-char (point-max)) - (when style-footer - (muse-insert-file-or-string style-footer title)) - (muse-style-run-hooks :after style) - (run-hooks 'muse-after-publish-hook))) - -(defun muse-publish-markup-string (string &optional style) - "Markup STRING using the given STYLE's markup rules." - (setq style (muse-style style)) - (muse-with-temp-buffer - (insert string) - (let ((muse-publishing-current-style style) - (muse-publishing-p t)) - (muse-publish-markup "*string*" (muse-style-element :rules style))) - (buffer-string))) - -;; Commands for publishing files - -(defun muse-publish-get-style (&optional styles) - (unless styles (setq styles muse-publishing-styles)) - (if (= 1 (length styles)) - (car styles) - (when (catch 'different - (let ((first (car (car styles)))) - (dolist (style (cdr styles)) - (unless (equal first (car style)) - (throw 'different t))))) - (setq styles (muse-collect-alist - styles - (funcall muse-completing-read-function - "Publish with style: " styles nil t)))) - (if (or (= 1 (length styles)) - (not (muse-get-keyword :path (car styles)))) - (car styles) - (setq styles (mapcar (lambda (style) - (cons (muse-get-keyword :path style) - style)) - styles)) - (cdr (assoc (funcall muse-completing-read-function - "Publish to directory: " styles nil t) - styles))))) - -(defsubst muse-publish-get-output-dir (style) - (let ((default-directory (or (muse-style-element :path style) - default-directory))) - (muse-read-directory-name "Publish to directory: " nil default-directory))) - -(defsubst muse-publish-get-info () - (let ((style (muse-publish-get-style))) - (list style (muse-publish-get-output-dir style) - current-prefix-arg))) - -(defsubst muse-publish-output-name (&optional file style) - (setq style (muse-style style)) - (concat (muse-style-element :prefix style) - (muse-page-name file) - (muse-style-element :suffix style))) - -(defsubst muse-publish-output-file (file &optional output-dir style) - (setq style (muse-style style)) - (if output-dir - (expand-file-name (muse-publish-output-name file style) output-dir) - (concat (file-name-directory file) - (muse-publish-output-name file style)))) - -(defsubst muse-publish-link-name (&optional file style) - "Take FILE and add :prefix and either :link-suffix or :suffix from STYLE. -We assume that FILE is a Muse file. - -We call `muse-page-name' on FILE to remove the directory part of -FILE and any extensions that are in `muse-ignored-extensions'." - (setq style (muse-style style)) - (concat (muse-style-element :prefix style) - (muse-page-name file) - (or (muse-style-element :link-suffix style) - (muse-style-element :suffix style)))) - -(defsubst muse-publish-link-file (file &optional style) - "Turn FILE into a URL. - -If FILE exists on the system as-is, return it without -modification. In the case of wanting to link to Muse files when -`muse-file-extension' is nil, you should load muse-project.el. - -Otherwise, assume that it is a Muse file and call -`muse-publish-link-name' to add :prefix, :link-suffix, :suffix, -and removing ignored file extensions, but preserving the -directory part of FILE." - (setq style (muse-style style)) - (if (file-exists-p file) - file - (concat (file-name-directory file) - (muse-publish-link-name file style)))) - -(defsubst muse-publish-link-page (page) - "Turn PAGE into a URL. - -This is called by `muse-publish-classify-url' to figure out what -a link to another file or Muse page should look like. - -If muse-project.el is loaded, call `muse-project-link-page' for this. -Otherwise, call `muse-publish-link-file'." - (if (fboundp 'muse-project-link-page) - (muse-project-link-page page) - (muse-publish-link-file page))) - -(defmacro muse-publish-ensure-block (beg &optional end) - "Ensure that block-level markup at BEG is published with at least one -preceding blank line. BEG must be an unquoted symbol that contains a -position or marker. BEG is modified to be the new position. -The point is left at the new value of BEG. - -Additionally, make sure that BEG is placed on a blank line. - -If END is given, make sure that it is placed on a blank line. In -order to achieve this, END must be an unquoted symbol that -contains a marker. This is the case with Muse tag functions." - `(progn - (goto-char ,beg) - (cond ((not (bolp)) (insert "\n\n")) - ((eq (point) (point-min)) nil) - ((prog2 (backward-char) (bolp) (forward-char)) nil) - (t (insert "\n"))) - (unless (and (bolp) (eolp)) - (insert "\n") - (backward-char)) - (setq ,beg (point)) - (when (markerp ,end) - (goto-char ,end) - (unless (and (bolp) (eolp)) - (insert-before-markers "\n"))) - (goto-char ,beg))) - -;;;###autoload -(defun muse-publish-region (beg end &optional title style) - "Apply the given STYLE's markup rules to the given region. -The result is placed in a new buffer that includes TITLE in its name." - (interactive "r") - (when (interactive-p) - (unless title (setq title (read-string "Title: "))) - (unless style (setq style (muse-publish-get-style)))) - (let ((text (buffer-substring beg end)) - (buf (generate-new-buffer (concat "*Muse: " title "*")))) - (with-current-buffer buf - (insert text) - (muse-publish-markup-buffer title style) - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) - '(rear-nonsticky nil read-only nil)))) - (pop-to-buffer buf))) - -;;;###autoload -(defun muse-publish-file (file style &optional output-dir force) - "Publish the given FILE in a particular STYLE to OUTPUT-DIR. -If the argument FORCE is nil, each file is only published if it is -newer than the published version. If the argument FORCE is non-nil, -the file is published no matter what." - (interactive (cons (read-file-name "Publish file: ") - (muse-publish-get-info))) - (let ((style-name style)) - (setq style (muse-style style)) - (unless style - (error "There is no style '%s' defined" style-name))) - (let* ((output-path (muse-publish-output-file file output-dir style)) - (output-suffix (muse-style-element :osuffix style)) - (muse-publishing-current-file file) - (muse-publishing-current-output-path output-path) - (target (if output-suffix - (concat (muse-path-sans-extension output-path) - output-suffix) - output-path)) - (threshhold (nth 7 (file-attributes file)))) - (if (not threshhold) - (message "Please save %s before publishing" file) - (when (or force (file-newer-than-file-p file target)) - (if (and muse-publish-report-threshhold - (> threshhold - muse-publish-report-threshhold)) - (message "Publishing %s ..." file)) - (muse-with-temp-buffer - (muse-insert-file-contents file) - (run-hooks 'muse-before-publish-hook) - (when muse-publish-enable-local-variables - (hack-local-variables)) - (let ((muse-inhibit-before-publish-hook t)) - (muse-publish-markup-buffer (muse-page-name file) style)) - (when (muse-write-file output-path) - (muse-style-run-hooks :final style file output-path target))) - t)))) - -;;;###autoload -(defun muse-publish-this-file (style output-dir &optional force) - "Publish the currently-visited file. -Prompt for both the STYLE and OUTPUT-DIR if they are not -supplied." - (interactive (muse-publish-get-info)) - (setq style (muse-style style)) - (if buffer-file-name - (let ((muse-current-output-style (list :base (car style) - :path output-dir))) - (unless (muse-publish-file buffer-file-name style output-dir force) - (message (concat "The published version is up-to-date; use" - " C-u C-c C-T to force an update.")))) - (message "This buffer is not associated with any file"))) - -(defun muse-batch-publish-files () - "Publish Muse files in batch mode." - (let ((muse-batch-publishing-p t) - (font-lock-verbose nil) - muse-current-output-style - style output-dir) - ;; don't activate VC when publishing files - (setq vc-handled-backends nil) - (setq style (car command-line-args-left) - command-line-args-left (cdr command-line-args-left) - output-dir (car command-line-args-left) - output-dir - (if (string-match "\\`--output-dir=" output-dir) - (prog1 - (substring output-dir (match-end 0)) - (setq command-line-args-left (cdr command-line-args-left)))) - muse-current-output-style (list :base style :path output-dir)) - (setq auto-mode-alist - (delete (cons (concat "\\." muse-file-extension "\\'") - 'muse-mode-choose-mode) - auto-mode-alist)) - (dolist (file command-line-args-left) - (muse-publish-file file style output-dir t)))) - -;; Default publishing rules - -(defun muse-publish-section-close (depth) - "Seach forward for the closing tag of given DEPTH." - (let (not-end) - (save-excursion - (while (and (setq not-end (re-search-forward - (concat "^\\*\\{1," (number-to-string depth) - "\\}\\s-+") - nil t)) - (get-text-property (match-beginning 0) 'read-only))) - (if not-end - (forward-line 0) - (goto-char (point-max))) - (cond ((not (eq (char-before) ?\n)) - (insert "\n\n")) - ((not (eq (char-before (1- (point))) ?\n)) - (insert "\n"))) - (muse-insert-markup (muse-markup-text 'section-close depth)) - (insert "\n")))) - -(defun muse-publish-markup-directive (&optional name value) - (unless name (setq name (match-string 1))) - (unless value (setq value (match-string 2))) - (let ((elem (assoc name muse-publishing-directives))) - (if elem - (setcdr elem value) - (setq muse-publishing-directives - (cons (cons name value) - muse-publishing-directives)))) - ;; Make sure we don't ever try to move the point forward (past the - ;; beginning of buffer) while we're still searching for directives. - (setq muse-publishing-last-position nil) - (delete-region (match-beginning 0) (match-end 0))) - -(defsubst muse-publishing-directive (name) - (cdr (assoc name muse-publishing-directives))) - -(defmacro muse-publish-get-and-delete-attr (attr attrs) - "Delete attribute ATTR from ATTRS only once, destructively. - -This function returns the matching attribute value, if found." - (let ((last (make-symbol "last")) - (found (make-symbol "found")) - (vals (make-symbol "vals"))) - `(let ((,vals ,attrs)) - (if (string= (caar ,vals) ,attr) - (prog1 (cdar ,vals) - (setq ,attrs (cdr ,vals))) - (let ((,last ,vals) - (,found nil)) - (while ,vals - (setq ,vals (cdr ,vals)) - (when (string= (caar ,vals) ,attr) - (setq ,found (cdar ,vals)) - (setcdr ,last (cdr ,vals)) - (setq ,vals nil)) - (setq ,last ,vals)) - ,found))))) - -(defun muse-publish-markup-anchor () - (unless (get-text-property (match-end 1) 'muse-link) - (let ((text (muse-markup-text 'anchor (match-string 2)))) - (unless (string= text "") - (save-match-data - (skip-chars-forward (concat muse-regexp-blank "\n")) - (muse-insert-markup text))) - (match-string 1)))) - -(defun muse-publish-markup-comment () - (if (null muse-publish-comments-p) - "" - (goto-char (match-end 0)) - (muse-insert-markup (muse-markup-text 'comment-end)) - (if (match-beginning 1) - (progn - (muse-publish-mark-read-only (match-beginning 1) (match-end 1)) - (delete-region (match-beginning 0) (match-beginning 1))) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (match-beginning 0)) - (muse-insert-markup (muse-markup-text 'comment-begin)))) - -(defun muse-publish-markup-tag () - (let ((tag-info (muse-markup-tag-info (match-string 1)))) - (when (and tag-info - (not (get-text-property (match-beginning 0) 'read-only)) - (nth 4 tag-info) - (or muse-publish-enable-dangerous-tags - (not (get (nth 4 tag-info) 'muse-dangerous-tag)))) - (let ((closed-tag (match-string 3)) - (start (match-beginning 0)) - (beg (point)) - end attrs) - (when (nth 2 tag-info) - (let ((attrstr (match-string 2))) - (while (and attrstr - (string-match (concat "\\([^" - muse-regexp-blank - "=\n]+\\)\\(=\"\\" - "([^\"]+\\)\"\\)?") - attrstr)) - (let ((attr (cons (downcase - (muse-match-string-no-properties 1 attrstr)) - (muse-match-string-no-properties 3 attrstr)))) - (setq attrstr (replace-match "" t t attrstr)) - (if attrs - (nconc attrs (list attr)) - (setq attrs (list attr))))))) - (if (and (cadr tag-info) (not closed-tag)) - (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info)) - (delete-region (match-beginning 0) (point)) - (setq tag-info nil))) - (when tag-info - (setq end (point-marker)) - (delete-region start beg) - (goto-char start) - (let ((args (list start end))) - (if (nth 2 tag-info) - (nconc args (list attrs))) - (let ((muse-inhibit-style-tags nil)) - ;; remove the inhibition - (apply (nth 4 tag-info) args))) - (set-marker end nil))))) - nil) - -(defun muse-publish-escape-specials (beg end &optional ignore-read-only context) - "Escape specials from BEG to END using style-specific :specials. -If IGNORE-READ-ONLY is non-nil, ignore the read-only property. -CONTEXT is used to figure out what kind of specials to escape. - -The following contexts exist in Muse. -'underline _underlined text_ -'literal =monospaced text= or <code> region (monospaced, escaped) -'emphasis *emphasized text* -'email email@example.com -'url http://example.com -'url-desc [[...][description of an explicit link]] -'image [[image.png]] -'example <example> region (monospaced, block context, escaped) -'verbatim <verbatim> region (escaped) -'footnote footnote text -'document normal text" - (let ((specials (muse-style-element :specials nil t))) - (cond ((functionp specials) - (setq specials (funcall specials context))) - ((symbolp specials) - (setq specials (symbol-value specials)))) - (if (functionp specials) - (funcall specials beg end ignore-read-only) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (< (point) (point-max)) - (if (and (not ignore-read-only) - (get-text-property (point) 'read-only)) - (goto-char (or (next-single-property-change (point) 'read-only) - (point-max))) - (let ((repl (or (assoc (char-after) specials) - (assoc (char-after) - muse-publish-markup-specials)))) - (if (null repl) - (forward-char 1) - (delete-char 1) - (insert-before-markers (cdr repl))))))))))) - -(defun muse-publish-markup-word () - (let* ((beg (match-beginning 2)) - (end (1- (match-end 2))) - (leader (buffer-substring-no-properties beg end)) - open-tag close-tag mark-read-only loc context) - (cond - ((string= leader "_") - (setq context 'underline - open-tag (muse-markup-text 'begin-underline) - close-tag (muse-markup-text 'end-underline))) - ((string= leader "=") - (setq context 'literal - open-tag (muse-markup-text 'begin-literal) - close-tag (muse-markup-text 'end-literal)) - (setq mark-read-only t)) - (t - (let ((l (length leader))) - (setq context 'emphasis) - (cond - ((= l 1) (setq open-tag (muse-markup-text 'begin-emph) - close-tag (muse-markup-text 'end-emph))) - ((= l 2) (setq open-tag (muse-markup-text 'begin-more-emph) - close-tag (muse-markup-text 'end-more-emph))) - ((= l 3) (setq open-tag (muse-markup-text 'begin-most-emph) - close-tag (muse-markup-text 'end-most-emph))) - (t (setq context nil)))))) - (if (and context - (not (get-text-property beg 'muse-link)) - (setq loc (search-forward leader nil t)) - (or (eobp) (not (eq (char-syntax (char-after loc)) ?w))) - (not (eq (char-syntax (char-before (point))) ?\ )) - (not (get-text-property (point) 'muse-link))) - (progn - (replace-match "") - (delete-region beg end) - (setq end (point-marker)) - (muse-insert-markup close-tag) - (goto-char beg) - (muse-insert-markup open-tag) - (setq beg (point)) - (when mark-read-only - (muse-publish-escape-specials beg end t context) - (muse-publish-mark-read-only beg end)) - (set-marker end nil)) - (backward-char)) - nil)) - -(defun muse-publish-markup-emdash () - (unless (get-text-property (match-beginning 0) 'muse-link) - (let ((prespace (match-string 1)) - (postspace (match-string 2))) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'emdash prespace postspace)) - (when (eq (char-after) ?\<) - (insert ?\n))))) - -(defun muse-publish-markup-enddots () - (unless (get-text-property (match-beginning 0) 'muse-link) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'enddots)))) - -(defun muse-publish-markup-dots () - (unless (get-text-property (match-beginning 0) 'muse-link) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'dots)))) - -(defun muse-publish-markup-rule () - (unless (get-text-property (match-beginning 0) 'muse-link) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'rule)))) - -(defun muse-publish-markup-no-break-space () - (unless (get-text-property (match-beginning 0) 'muse-link) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'no-break-space)))) - -(defun muse-publish-markup-heading () - (let* ((len (length (match-string 1))) - (start (muse-markup-text - (cond ((= len 1) 'section) - ((= len 2) 'subsection) - ((= len 3) 'subsubsection) - (t 'section-other)) - len)) - (end (muse-markup-text - (cond ((= len 1) 'section-end) - ((= len 2) 'subsection-end) - ((= len 3) 'subsubsection-end) - (t 'section-other-end)) - len))) - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup start) - (end-of-line) - (when end - (muse-insert-markup end)) - (forward-line 1) - (unless (eq (char-after) ?\n) - (insert "\n")) - (muse-publish-section-close len))) - -(defvar muse-publish-footnotes nil) - -(defun muse-publish-markup-footnote () - "Scan ahead and snarf up the footnote body." - (cond - ((get-text-property (match-beginning 0) 'muse-link) - nil) - ((= (muse-line-beginning-position) (match-beginning 0)) - "") - (t - (let ((footnote (save-match-data - (string-to-number (match-string 1)))) - (oldtext (match-string 0)) - footnotemark) - (delete-region (match-beginning 0) (match-end 0)) - (save-excursion - (when (re-search-forward (format "^\\[%d\\]\\s-+" footnote) nil t) - (let* ((start (match-beginning 0)) - (beg (goto-char (match-end 0))) - (end (save-excursion - (if (search-forward "\n\n" nil t) - (copy-marker (match-beginning 0)) - (goto-char (point-max)) - (skip-chars-backward "\n") - (point-marker))))) - (while (re-search-forward - (concat "^[" muse-regexp-blank "]+\\([^\n]\\)") - end t) - (replace-match "\\1" t)) - (let ((footnotemark-cmd (muse-markup-text 'footnotemark)) - (footnotemark-end-cmd (muse-markup-text 'footnotemark-end))) - (if (string= "" footnotemark-cmd) - (setq footnotemark - (concat (muse-markup-text 'footnote) - (muse-publish-escape-specials-in-string - (buffer-substring-no-properties beg end) - 'footnote) - (muse-markup-text 'footnote-end))) - (setq footnotemark (format footnotemark-cmd footnote - footnotemark-end-cmd)) - (unless muse-publish-footnotes - (set (make-local-variable 'muse-publish-footnotes) - (make-vector 256 nil))) - (unless (aref muse-publish-footnotes footnote) - (setq footnotemark - (concat - footnotemark - (concat (format (muse-markup-text 'footnotetext) - footnote) - (buffer-substring-no-properties beg end) - (muse-markup-text 'footnotetext-end)))) - (aset muse-publish-footnotes footnote footnotemark)))) - (goto-char end) - (skip-chars-forward "\n") - (delete-region start (point)) - (set-marker end nil)))) - (if footnotemark - (muse-insert-markup footnotemark) - (insert oldtext)))))) - -(defun muse-publish-markup-fn-sep () - (delete-region (match-beginning 0) (match-end 0)) - (muse-insert-markup (muse-markup-text 'fn-sep))) - -(defun muse-insert-markup-end-list (&rest args) - (let ((beg (point))) - (apply 'insert args) - (add-text-properties beg (point) '(muse-end-list t)) - (muse-publish-mark-read-only beg (point)))) - -(defun muse-publish-determine-dl-indent (continue indent-sym determine-sym) - ;; If the caller doesn't know how much indentation to use, figure it - ;; out ourselves. It is assumed that `muse-forward-list-item' has - ;; been called just before this to set the match data. - (when (and continue - (symbol-value determine-sym)) - (save-match-data - ;; snarf all leading whitespace - (let ((indent (and (match-beginning 2) - (buffer-substring (match-beginning 1) - (match-beginning 2))))) - (when (and indent - (not (string= indent ""))) - (set indent-sym indent) - (set determine-sym nil)))))) - -(defun muse-publish-surround-dl (indent post-indent) - (let* ((beg-item (muse-markup-text 'begin-dl-item)) - (end-item (muse-markup-text 'end-dl-item)) - (beg-ddt (muse-markup-text 'begin-ddt)) ;; term - (end-ddt (muse-markup-text 'end-ddt)) - (beg-dde (muse-markup-text 'begin-dde)) ;; definition - (end-dde (muse-markup-text 'end-dde)) - (continue t) - (no-terms t) - beg) - (while continue - ;; envelope this as one term+definitions unit -- HTML does not - ;; need this, but DocBook and Muse's custom XML format do - (muse-insert-markup beg-item) - (when (looking-at muse-dl-term-regexp) - ;; find the term and wrap it with published markup - (setq beg (point) - no-terms nil) - (goto-char (match-end 1)) - (delete-region (point) (match-end 0)) - (muse-insert-markup-end-list end-ddt) - ;; if definition is immediately after term, move to next line - (unless (eq (char-after) ?\n) - (insert ?\n)) - (save-excursion - (goto-char beg) - (delete-region (point) (match-beginning 1)) - (muse-insert-markup beg-ddt))) - ;; handle pathological edge case where there is no term -- I - ;; would prefer to just disallow this, but people seem to want - ;; this behavior - (when (and no-terms - (looking-at (concat "[" muse-regexp-blank "]*::" - "[" muse-regexp-blank "]*"))) - (delete-region (point) (match-end 0)) - ;; but only do this once - (setq no-terms nil)) - (setq beg (point) - ;; move past current item - continue (muse-forward-list-item 'dl-term indent)) - (save-restriction - (narrow-to-region beg (point)) - (goto-char (point-min)) - ;; publish each definition that we find, defaulting to an - ;; empty definition if none are found - (muse-publish-surround-text beg-dde end-dde - (lambda (indent) - (muse-forward-list-item 'dl-entry indent)) - indent post-indent - #'muse-publish-determine-dl-indent) - (goto-char (point-max)) - (skip-chars-backward (concat muse-regexp-blank "\n")) - (muse-insert-markup-end-list end-item) - (when continue - (goto-char (point-max))))))) - -(defun muse-publish-strip-list-indentation (list-item empty-line indent post-indent) - (let ((list-nested nil) - (indent-found nil)) - (while (< (point) (point-max)) - (when (and (looking-at list-item) - (not (or (get-text-property - (muse-list-item-critical-point) 'read-only) - (get-text-property - (muse-list-item-critical-point) 'muse-link)))) - ;; if we encounter a list item, allow no post-indent space - (setq list-nested t)) - (when (and (not (looking-at empty-line)) - (looking-at (concat indent "\\(" - (or (and list-nested "") - post-indent) - "\\)"))) - ;; if list is not nested, remove indentation - (unless indent-found - (setq post-indent (match-string 1) - indent-found t)) - (replace-match "")) - (forward-line 1)))) - -(defun muse-publish-surround-text (beg-tag end-tag move-func &optional indent post-indent determine-indent-func list-item) - (unless list-item - (setq list-item (format muse-list-item-regexp - (concat "[" muse-regexp-blank "]*")))) - (let ((continue t) - (empty-line (concat "^[" muse-regexp-blank "]*\n")) - (determine-indent (if determine-indent-func t nil)) - (new-indent indent) - (first t) - beg) - (unless indent - (setq indent (concat "[" muse-regexp-blank "]+"))) - (if post-indent - (setq post-indent (concat " \\{0," (number-to-string post-indent) - "\\}")) - (setq post-indent "")) - (while continue - (if (or (not end-tag) (string= end-tag "")) - ;; if no end of list item markup exists, treat the beginning - ;; of list item markup as it if it were the end -- this - ;; prevents multiple-level lists from being confused - (muse-insert-markup-end-list beg-tag) - (muse-insert-markup beg-tag)) - (setq beg (point) - ;; move past current item; continue is non-nil if there - ;; are more like items to be processed - continue (if (and determine-indent-func first) - (funcall move-func (concat indent post-indent)) - (funcall move-func indent))) - (when determine-indent-func - (funcall determine-indent-func continue 'new-indent 'determine-indent)) - (when continue - ;; remove list markup if we encountered another item of the - ;; same type - (replace-match "" t t nil 1)) - (save-restriction - ;; narrow to current item - (narrow-to-region beg (point)) - (goto-char (point-min)) - (if (looking-at empty-line) - ;; if initial line is blank, move to first non-blank line - (while (progn (forward-line 1) - (and (< (point) (point-max)) - (looking-at empty-line)))) - ;; otherwise, move to second line of text - (forward-line 1)) - ;; strip list indentation - (muse-publish-strip-list-indentation list-item empty-line - indent post-indent) - (skip-chars-backward (concat muse-regexp-blank "\n")) - (muse-insert-markup-end-list end-tag) - (when determine-indent-func - (setq indent new-indent)) - (when first - (setq first nil)) - (when continue - (goto-char (point-max))))))) - -(defun muse-publish-ensure-blank-line () - "Make sure that a blank line exists on the line before point." - (let ((pt (point-marker))) - (beginning-of-line) - (cond ((eq (point) (point-min)) nil) - ((prog2 (backward-char) (bolp) (forward-char)) nil) - (t (insert-before-markers "\n"))) - (goto-char pt) - (set-marker pt nil))) - -(defun muse-publish-markup-list () - "Markup a list entry. -This function works by marking up items of the same list level -and type, respecting the end-of-list property." - (let* ((str (match-string 1)) - (type (muse-list-item-type str)) - (indent (buffer-substring (muse-line-beginning-position) - (match-beginning 1))) - (post-indent (length str))) - (cond - ((or (get-text-property (muse-list-item-critical-point) 'read-only) - (get-text-property (muse-list-item-critical-point) 'muse-link)) - nil) - ((eq type 'ul) - (unless (eq (char-after (match-end 1)) ?-) - (delete-region (match-beginning 0) (match-end 0)) - (muse-publish-ensure-blank-line) - (muse-insert-markup (muse-markup-text 'begin-uli)) - (save-excursion - (muse-publish-surround-text - (muse-markup-text 'begin-uli-item) - (muse-markup-text 'end-uli-item) - (lambda (indent) - (muse-forward-list-item 'ul indent)) - indent post-indent) - (muse-insert-markup-end-list (muse-markup-text 'end-uli))) - (forward-line 1))) - ((eq type 'ol) - (delete-region (match-beginning 0) (match-end 0)) - (muse-publish-ensure-blank-line) - (muse-insert-markup (muse-markup-text 'begin-oli)) - (save-excursion - (muse-publish-surround-text - (muse-markup-text 'begin-oli-item) - (muse-markup-text 'end-oli-item) - (lambda (indent) - (muse-forward-list-item 'ol indent)) - indent post-indent) - (muse-insert-markup-end-list (muse-markup-text 'end-oli))) - (forward-line 1)) - (t - (goto-char (match-beginning 0)) - (muse-publish-ensure-blank-line) - (muse-insert-markup (muse-markup-text 'begin-dl)) - (save-excursion - (muse-publish-surround-dl indent post-indent) - (muse-insert-markup-end-list (muse-markup-text 'end-dl))) - (forward-line 1)))) - nil) - -(defun muse-publish-markup-quote () - "Markup a quoted paragraph. -The reason this function is so funky, is to prevent text properties -like read-only from being inadvertently deleted." - (let* ((ws (match-string 1)) - (centered (>= (string-width ws) 6)) - (begin-elem (if centered 'begin-center 'begin-quote-item)) - (end-elem (if centered 'end-center 'end-quote-item))) - (replace-match "" t t nil 1) - (unless centered - (muse-insert-markup (muse-markup-text 'begin-quote))) - (muse-publish-surround-text (muse-markup-text begin-elem) - (muse-markup-text end-elem) - (function (lambda (indent) - (muse-forward-paragraph) - nil))) - (unless centered - (muse-insert-markup (muse-markup-text 'end-quote))))) - -(defun muse-publish-markup-leading-space (markup-space multiple) - (let (count) - (when (and markup-space - (>= (setq count (skip-chars-forward " ")) 0)) - (delete-region (muse-line-beginning-position) (point)) - (while (> count 0) - (muse-insert-markup markup-space) - (setq count (- count multiple)))))) - -(defun muse-publish-markup-verse () - (let ((leader (match-string 0))) - (goto-char (match-beginning 0)) - (muse-insert-markup (muse-markup-text 'begin-verse)) - (while (looking-at leader) - (replace-match "") - (muse-publish-markup-leading-space (muse-markup-text 'verse-space) 2) - (let ((beg (point))) - (end-of-line) - (cond - ((bolp) - (let ((text (muse-markup-text 'empty-verse-line))) - (when text (muse-insert-markup text)))) - ((save-excursion - (save-match-data - (forward-line 1) - (or (looking-at (concat leader "[" - muse-regexp-blank - "]*$")) - (not (looking-at leader))))) - (let ((begin-text (muse-markup-text 'begin-last-stanza-line)) - (end-text (muse-markup-text 'end-last-stanza-line))) - (when end-text (muse-insert-markup end-text)) - (goto-char beg) - (when begin-text (muse-insert-markup begin-text)) - (end-of-line))) - (t - (let ((begin-text (muse-markup-text 'begin-verse-line)) - (end-text (muse-markup-text 'end-verse-line))) - (when end-text (muse-insert-markup end-text)) - (goto-char beg) - (when begin-text (muse-insert-markup begin-text)) - (end-of-line)))) - (forward-line 1)))) - (muse-insert-markup (muse-markup-text 'end-verse)) - (insert ?\n)) - -(defun muse-publish-trim-table (table) - "Remove completely blank columns from table, if at start or end of row." - ;; remove first - (catch 'found - (dolist (row (cdr table)) - (let ((el (cadr row))) - (when (and (stringp el) (not (string= el ""))) - (throw 'found t)))) - (dolist (row (cdr table)) - (setcdr row (cddr row))) - (setcar table (1- (car table)))) - ;; remove last - (catch 'found - (dolist (row (cdr table)) - (let ((el (car (last row)))) - (when (and (stringp el) (not (string= el ""))) - (throw 'found t)))) - (dolist (row (cdr table)) - (setcdr (last row 2) nil)) - (setcar table (1- (car table)))) - table) - -(defun muse-publish-table-fields (beg end) - "Parse given region as a table, returning a cons cell. -The car is the length of the longest row. - -The cdr is a list of the fields of the table, with the first -element indicating the type of the row: - 1: body, 2: header, 3: footer, hline: separator. - -The existing region will be removed, except for initial blank lines." - (unless (muse-publishing-directive "disable-tables") - (let ((longest 0) - (left 0) - (seen-hline nil) - fields field-list) - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (looking-at (concat "^[" muse-regexp-blank "]*$")) - (forward-line 1)) - (setq beg (point)) - (while (= left 0) - (cond - ((looking-at muse-table-hline-regexp) - (when field-list ; skip if at the beginning of table - (if seen-hline - (setq field-list (cons (cons 'hline nil) field-list)) - (dolist (field field-list) - ;; the preceding fields are header lines - (setcar field 2)) - (setq seen-hline t)))) - ((looking-at muse-table-line-regexp) - (setq fields (cons (length (match-string 1)) - (mapcar #'muse-trim-whitespace - (split-string (match-string 0) - muse-table-field-regexp))) - field-list (cons fields field-list) - longest (max (length fields) longest)) - ;; strip initial bars, if they exist - (let ((first (cadr fields))) - (when (and first (string-match "\\`|+\\s-*" first)) - (setcar (cdr fields) (replace-match "" t t first)))))) - (setq left (forward-line 1)))) - (delete-region beg end) - (if (= longest 0) - (cons 0 nil) - ;; if the last line was an hline, remove it - (when (eq (caar field-list) 'hline) - (setq field-list (cdr field-list))) - (muse-publish-trim-table (cons (1- longest) (nreverse field-list))))))) - -(defun muse-publish-markup-table () - "Style does not support tables.\n") - -(defun muse-publish-table-el-table (variant) - "Publish table.el-style tables in the format given by VARIANT." - (when (condition-case nil - (progn (require 'table) - t) - (error nil)) - (let ((muse-buf (current-buffer))) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (goto-char (point-min)) - (forward-line 1) - (when (search-forward "|" nil t) - (with-temp-buffer - (let ((temp-buf (current-buffer))) - (with-current-buffer muse-buf - (table-generate-source variant temp-buf)) - (with-current-buffer muse-buf - (delete-region (point-min) (point-max)) - (insert-buffer-substring temp-buf) - (muse-publish-mark-read-only (point-min) (point-max)))))))))) - -(defun muse-publish-markup-table-el () - "Mark up table.el-style tables." - (cond ((muse-style-derived-p 'html) - (muse-publish-table-el-table 'html)) - ((muse-style-derived-p 'latex) - (muse-publish-table-el-table 'latex)) - ((muse-style-derived-p 'docbook) - (muse-publish-table-el-table 'cals)) - (t "Style does not support table.el tables.\n"))) - -(defun muse-publish-escape-specials-in-string (string &optional context) - "Escape specials in STRING using style-specific :specials. -CONTEXT is used to figure out what kind of specials to escape. - -See the documentation of the `muse-publish-escape-specials' -function for the list of available contexts." - (unless string - (setq string "")) - (let ((specials (muse-style-element :specials nil t))) - (cond ((functionp specials) - (setq specials (funcall specials context))) - ((symbolp specials) - (setq specials (symbol-value specials)))) - (if (functionp specials) - (funcall specials string) - (apply (function concat) - (mapcar - (lambda (ch) - (let ((repl (or (assoc ch specials) - (assoc ch muse-publish-markup-specials)))) - (if (null repl) - (char-to-string ch) - (cdr repl)))) - (append string nil)))))) - -(defun muse-publish-markup-email () - (let* ((beg (match-end 1)) - (addr (buffer-substring-no-properties beg (match-end 0)))) - (setq addr (muse-publish-escape-specials-in-string addr 'email)) - (goto-char beg) - (delete-region beg (match-end 0)) - (if (or (eq (char-before (match-beginning 0)) ?\") - (eq (char-after (match-end 0)) ?\")) - (insert addr) - (insert (format (muse-markup-text 'email-addr) addr addr))) - (muse-publish-mark-read-only beg (point)))) - -(defun muse-publish-classify-url (target) - "Transform anchors and get published name, if TARGET is a page. -The return value is two linked cons cells. The car is the type -of link, the cadr is the page name, and the cddr is the anchor." - (save-match-data - (cond ((or (null target) (string= target "")) - nil) - ((string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" target) - (cons 'url (cons (match-string 1 target) nil))) - ((string-match muse-image-regexp target) - (cons 'image (cons target nil))) - ((string-match muse-url-regexp target) - (cons 'url (cons target nil))) - ((string-match muse-file-regexp target) - (cons 'file (cons target nil))) - ((string-match "#" target) - (if (eq (aref target 0) ?\#) - (cons 'anchor-ref (cons nil (substring target 1))) - (cons 'link-and-anchor - ;; match-data is changed by - ;; `muse-publish-link-page' or descendants. - (cons (save-match-data - (muse-publish-link-page - (substring target 0 (match-beginning 0)))) - (substring target (match-end 0)))))) - (t - (cons 'link (cons (muse-publish-link-page target) nil)))))) - -(defun muse-publish-url-desc (desc explicit) - (when desc - (dolist (transform muse-publish-desc-transforms) - (setq desc (save-match-data - (when desc (funcall transform desc explicit))))) - (setq desc (muse-link-unescape desc)) - (muse-publish-escape-specials-in-string desc 'url-desc))) - -(defun muse-publish-url (url &optional desc orig-url explicit) - "Resolve a URL into its final <a href> form." - (let ((unesc-url url) - (unesc-orig-url orig-url) - (unesc-desc desc) - type anchor) - ;; Transform URL - (dolist (transform muse-publish-url-transforms) - (setq url (save-match-data (when url (funcall transform url explicit))))) - ;; Classify URL - (let ((target (muse-publish-classify-url url))) - (setq type (car target) - url (if (eq type 'image) - (muse-publish-escape-specials-in-string (cadr target) - 'image) - (muse-publish-escape-specials-in-string (cadr target) 'url)) - anchor (muse-publish-escape-specials-in-string - (cddr target) 'url))) - ;; Transform description - (if desc - (setq desc (muse-publish-url-desc desc explicit)) - (when orig-url - (setq orig-url (muse-publish-url-desc orig-url explicit)))) - ;; Act on URL classification - (cond ((eq type 'anchor-ref) - (muse-markup-text 'anchor-ref anchor (or desc orig-url))) - ((and unesc-desc (string-match muse-image-regexp unesc-desc)) - (let ((ext (or (file-name-extension desc) ""))) - (setq desc (muse-publish-escape-specials-in-string unesc-desc - 'image)) - (setq desc (muse-path-sans-extension desc)) - (muse-markup-text 'image-link url desc ext))) - ((string= url "") - desc) - ((eq type 'image) - (let ((ext (or (file-name-extension url) ""))) - (setq url (muse-path-sans-extension url)) - (if desc - (muse-markup-text 'image-with-desc url ext desc) - (muse-markup-text 'image url ext)))) - ((eq type 'link-and-anchor) - (muse-markup-text 'link-and-anchor url anchor - (or desc orig-url) - (muse-path-sans-extension url))) - ((eq type 'link) - (muse-markup-text 'link url (or desc orig-url))) - (t - (or (and (or desc - ;; compare the not-escaped versions of url and - ;; orig-url - (not (string= unesc-url unesc-orig-url))) - (let ((text (muse-markup-text 'url-and-desc url - (or desc orig-url)))) - (and (not (string= text "")) - text))) - (muse-markup-text 'url url (or desc orig-url))))))) - -(defun muse-publish-insert-url (url &optional desc orig-url explicit) - "Resolve a URL into its final <a href> form." - (delete-region (match-beginning 0) (match-end 0)) - (let ((text (muse-publish-url url desc orig-url explicit))) - (when text - (muse-insert-markup text)))) - -(defun muse-publish-markup-link () - (let (desc explicit orig-link link) - (setq explicit (save-match-data - (if (string-match muse-explicit-link-regexp - (match-string 0)) - t nil))) - (setq orig-link (if explicit (match-string 1) (match-string 0))) - (setq desc (when explicit (match-string 2))) - (setq link (if explicit - (muse-handle-explicit-link orig-link) - (muse-handle-implicit-link orig-link))) - (when (and link - (or explicit - (not (or (eq (char-before (match-beginning 0)) ?\") - (eq (char-after (match-end 0)) ?\"))))) - ;; if explicit link has no user-provided description, treat it - ;; as if it were an implicit link - (when (and explicit (not desc)) - (setq explicit nil)) - (muse-publish-insert-url link desc orig-link explicit)))) - -(defun muse-publish-markup-url () - (unless (or (eq (char-before (match-beginning 0)) ?\") - (eq (char-after (match-end 0)) ?\")) - (let ((url (match-string 0))) - (muse-publish-insert-url url nil url)))) - -;; Default publishing tags - -(defcustom muse-publish-contents-depth 2 - "The number of heading levels to include with <contents> tags." - :type 'integer - :group 'muse-publish) - -(defun muse-publish-contents-tag (beg end attrs) - (set (make-local-variable 'muse-publish-generate-contents) - (cons (copy-marker (point) t) - (let ((depth (cdr (assoc "depth" attrs)))) - (or (and depth (string-to-number depth)) - muse-publish-contents-depth))))) - -(defun muse-publish-verse-tag (beg end) - (muse-publish-ensure-block beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (delete-char 1) - (while (< (point) (point-max)) - (insert "> ") - (forward-line)) - (if (eq ?\ (char-syntax (char-before))) - (delete-char -1))))) - -(defun muse-publish-mark-read-only (beg end) - "Add read-only properties to the given region." - (add-text-properties beg end '(rear-nonsticky (read-only) read-only t)) - nil) - -(defun muse-publish-mark-link (&optional beg end) - "Indicate that the given region is a Muse link, so that other -markup elements respect it. If a region is not specified, use -the 0th match data to determine it. - -This is usually applied to explicit links." - (unless beg (setq beg (match-beginning 0))) - (unless end (setq end (match-end 0))) - (add-text-properties beg end '(muse-link t)) - nil) - -(defun muse-publish-quote-tag (beg end) - (muse-publish-ensure-block beg) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((quote-regexp "^\\(<\\(/?\\)quote>\\)")) - (muse-insert-markup (muse-markup-text 'begin-quote)) - (while (progn - (unless (looking-at (concat "[" muse-regexp-blank "\n]*" - "<quote>")) - (muse-publish-surround-text - (muse-markup-text 'begin-quote-item) - (muse-markup-text 'end-quote-item) - (function - (lambda (indent) - (muse-forward-paragraph) - (goto-char (match-end 0)) - (and (< (point) (point-max)) - (not (looking-at quote-regexp))))) - nil nil nil - quote-regexp)) - (if (>= (point) (point-max)) - t - (and (search-forward "<quote>" nil t) - (muse-goto-tag-end "quote" t) - (progn (forward-line 1) t) - (< (point) (point-max)))))) - (goto-char (point-max)) - (muse-insert-markup (muse-markup-text 'end-quote)))))) - -(defun muse-publish-code-tag (beg end) - (muse-publish-escape-specials beg end nil 'literal) - (goto-char beg) - (insert (muse-markup-text 'begin-literal)) - (goto-char end) - (insert (muse-markup-text 'end-literal)) - (muse-publish-mark-read-only beg (point))) - -(defun muse-publish-cite-tag (beg end attrs) - (let* ((type (muse-publish-get-and-delete-attr "type" attrs)) - (citetag (cond ((string-equal type "author") - 'begin-cite-author) - ((string-equal type "year") - 'begin-cite-year) - (t - 'begin-cite)))) - (goto-char beg) - (insert (muse-markup-text citetag (muse-publishing-directive "bibsource"))) - (goto-char end) - (insert (muse-markup-text 'end-cite)) - (muse-publish-mark-read-only beg (point)))) - -(defun muse-publish-src-tag (beg end attrs) - (muse-publish-example-tag beg end)) - -(defun muse-publish-example-tag (beg end) - (muse-publish-ensure-block beg end) - (muse-publish-escape-specials beg end nil 'example) - (goto-char beg) - (insert (muse-markup-text 'begin-example)) - (goto-char end) - (insert (muse-markup-text 'end-example)) - (muse-publish-mark-read-only beg (point))) - -(defun muse-publish-literal-tag (beg end attrs) - "Ensure that the text between BEG and END is not interpreted later on. - -ATTRS is an alist of attributes. - -If it contains a \"style\" element, delete the region if the -current style is neither derived from nor equal to this style. - -If it contains both a \"style\" element and an \"exact\" element -with the value \"t\", delete the region only if the current style -is exactly this style." - (let* ((style (cdr (assoc "style" attrs))) - (exact (cdr (assoc "exact" attrs))) - (exactp (and (stringp exact) (string= exact "t")))) - (if (or (not style) - (and exactp (equal (muse-style style) - muse-publishing-current-style)) - (and (not exactp) (muse-style-derived-p style))) - (muse-publish-mark-read-only beg end) - (delete-region beg end) - (when (and (bolp) (eolp) (not (eobp))) - (delete-char 1))))) - -(put 'muse-publish-literal-tag 'muse-dangerous-tag t) - -(defun muse-publish-verbatim-tag (beg end) - (muse-publish-escape-specials beg end nil 'verbatim) - (muse-publish-mark-read-only beg end)) - -(defun muse-publish-br-tag (beg end) - "Insert a line break." - (delete-region beg end) - (muse-insert-markup (muse-markup-text 'line-break))) - -(defalias 'muse-publish-class-tag 'ignore) -(defalias 'muse-publish-div-tag 'ignore) - -(defun muse-publish-call-tag-on-buffer (tag &optional attrs) - "Transform the current buffer as if it were surrounded by the tag TAG. -If attributes ATTRS are given, pass them to the tag function." - (let ((tag-info (muse-markup-tag-info tag))) - (when tag-info - (let* ((end (progn (goto-char (point-max)) (point-marker))) - (args (list (point-min) end)) - (muse-inhibit-style-tags nil)) - (when (nth 2 tag-info) - (nconc args (list attrs))) - (apply (nth 4 tag-info) args) - (set-marker end nil))))) - -(defun muse-publish-examplify-buffer (&optional attrs) - "Transform the current buffer as if it were an <example> region." - (muse-publish-call-tag-on-buffer "example" attrs)) - -(defun muse-publish-srcify-buffer (&optional attrs) - "Transform the current buffer as if it were a <src> region." - (muse-publish-call-tag-on-buffer "src" attrs)) - -(defun muse-publish-versify-buffer (&optional attrs) - "Transform the current buffer as if it were a <verse> region." - (muse-publish-call-tag-on-buffer "verse" attrs) - (muse-publish-markup "" - `((100 ,(concat "^[" muse-regexp-blank "]*> ") 0 - muse-publish-markup-verse))) - (goto-char (point-min))) - -(defmacro muse-publish-markup-attribute (beg end attrs reinterp &rest body) - "Evaluate BODY within the bounds of BEG and END. -ATTRS is an alist. Only the \"markup\" element of ATTRS is acted -on. - -If it is omitted, publish the region with the normal Muse rules. -If RE-INTERP is specified, this is done immediately in a new -publishing process. Currently, RE-INTERP is specified only by -the <include> tag. - -If \"nil\", do not mark up the region at all, but prevent it from -being further interpreted by Muse. - -If \"example\", treat the region as if it was surrounded by the -<example> tag. - -If \"src\", treat the region as if it was surrounded by the -<src> tag. - -If \"verse\", treat the region as if it was surrounded by the -<verse> tag, to preserve newlines. - -Otherwise, it should be the name of a function to call in the -narrowed region after evaluating BODY. The function should -take the ATTRS parameter. - -BEG is modified to be the start of the published markup." - (let ((attrs-sym (make-symbol "attrs")) - (markup (make-symbol "markup")) - (markup-function (make-symbol "markup-function"))) - `(let* ((,attrs-sym ,attrs) - (,markup (muse-publish-get-and-delete-attr "markup" ,attrs-sym))) - (save-restriction - (narrow-to-region ,beg ,end) - (goto-char (point-min)) - ,@body - (if (not ,markup) - (when ,reinterp - (muse-publish-markup-region (point-min) (point-max)) - (muse-publish-mark-read-only (point-min) (point-max)) - (goto-char (point-max))) - (let ((,markup-function (read ,markup))) - (cond ((eq ,markup-function 'example) - (setq ,markup-function #'muse-publish-examplify-buffer)) - ((eq ,markup-function 'src) - (setq ,markup-function #'muse-publish-srcify-buffer)) - ((eq ,markup-function 'verse) - (setq ,markup-function #'muse-publish-versify-buffer)) - ((and ,markup-function (not (functionp ,markup-function))) - (error "Invalid markup function `%s'" ,markup)) - (t nil)) - (if ,markup-function - (funcall ,markup-function ,attrs-sym) - (muse-publish-mark-read-only (point-min) (point-max)) - (goto-char (point-max))))))))) - -(put 'muse-publish-markup-attribute 'lisp-indent-function 4) -(put 'muse-publish-markup-attribute 'edebug-form-spec - '(sexp sexp sexp sexp body)) - -(defun muse-publish-lisp-tag (beg end attrs) - (muse-publish-markup-attribute beg end attrs nil - (save-excursion - (save-restriction - (let ((str (muse-eval-lisp - (prog1 - (concat "(progn " - (buffer-substring-no-properties (point-min) - (point-max)) - ")") - (delete-region (point-min) (point-max)) - (widen))))) - (set-text-properties 0 (length str) nil str) - (insert str)))))) - -(put 'muse-publish-lisp-tag 'muse-dangerous-tag t) - -(defun muse-publish-command-tag (beg end attrs) - (muse-publish-markup-attribute beg end attrs nil - (while (looking-at "\\s-*$") - (forward-line)) - (let ((interp (muse-publish-get-and-delete-attr "interp" attrs))) - (if interp - (shell-command-on-region (point) (point-max) interp t t) - (shell-command - (prog1 - (buffer-substring-no-properties (point) (point-max)) - (delete-region (point-min) (point-max))) - t))) - ;; make sure there is a newline at end - (goto-char (point-max)) - (forward-line 0) - (unless (looking-at "\\s-*$") - (goto-char (point-max)) - (insert ?\n)) - (goto-char (point-min)))) - -(put 'muse-publish-command-tag 'muse-dangerous-tag t) - -(defun muse-publish-perl-tag (beg end attrs) - (muse-publish-command-tag beg end - (cons (cons "interp" (executable-find "perl")) - attrs))) - -(put 'muse-publish-perl-tag 'muse-dangerous-tag t) - -(defun muse-publish-php-tag (beg end attrs) - (muse-publish-command-tag beg end - (cons (cons "interp" (executable-find "php")) - attrs))) - -(put 'muse-publish-php-tag 'muse-dangerous-tag t) - -(defun muse-publish-python-tag (beg end attrs) - (muse-publish-command-tag beg end - (cons (cons "interp" (executable-find "python")) - attrs))) - -(put 'muse-publish-python-tag 'muse-dangerous-tag t) - -(defun muse-publish-ruby-tag (beg end attrs) - (muse-publish-command-tag beg end - (cons (cons "interp" (executable-find "ruby")) - attrs))) - -(put 'muse-publish-ruby-tag 'muse-dangerous-tag t) - -(defun muse-publish-comment-tag (beg end) - (if (null muse-publish-comments-p) - (delete-region beg end) - (goto-char end) - (muse-insert-markup (muse-markup-text 'comment-end)) - (muse-publish-mark-read-only beg end) - (goto-char beg) - (muse-insert-markup (muse-markup-text 'comment-begin)))) - -(defun muse-publish-include-tag (beg end attrs) - "Include the named file at the current location during publishing. - -<include file=\"...\" markup=\"...\"> - -The `markup' attribute controls how this file is marked up after -being inserted. See `muse-publish-markup-attribute' for an -explanation of how it works." - (let ((filename (muse-publish-get-and-delete-attr "file" attrs)) - (muse-publishing-directives (copy-alist muse-publishing-directives))) - (if filename - (setq filename (expand-file-name - filename - (file-name-directory muse-publishing-current-file))) - (error "No file attribute specified in <include> tag")) - (muse-publish-markup-attribute beg end attrs t - (muse-insert-file-contents filename)))) - -(put 'muse-publish-include-tag 'muse-dangerous-tag t) - -(defun muse-publish-mark-up-tag (beg end attrs) - "Run an Emacs Lisp function on the region delimted by this tag. - -<markup function=\"...\" style=\"...\" exact=\"...\"> - -The optional \"function\" attribute controls how this section is -marked up. If used, it should be the name of a function to call -with the buffer narrowed to the delimited region. Note that no -further marking-up will be performed on this region. - -If \"function\" is omitted, use the standard Muse markup function. -This is useful for marking up content in headers and footers. - -The optional \"style\" attribute causes the region to be deleted -if the current style is neither derived from nor equal to this -style. - -If both a \"style\" attribute and an \"exact\" attribute are -provided, and \"exact\" is \"t\", delete the region only if the -current style is exactly this style." - (let* ((style (cdr (assoc "style" attrs))) - (exact (cdr (assoc "exact" attrs))) - (exactp (and (stringp exact) (string= exact "t")))) - (if (or (not style) - (and exactp (equal (muse-style style) - muse-publishing-current-style)) - (and (not exactp) (muse-style-derived-p style))) - (let* ((function (cdr (assoc "function" attrs))) - (muse-publish-use-header-footer-tags nil) - (markup-function (and function (intern-soft function)))) - (if (and markup-function (functionp markup-function)) - (save-restriction - (narrow-to-region beg end) - (funcall markup-function) - (goto-char (point-max))) - (let ((muse-publish-inhibit-style-hooks t)) - (muse-publish-markup-region beg end))) - (muse-publish-mark-read-only beg (point))) - (delete-region beg end)))) - -(put 'muse-publish-mark-up-tag 'muse-dangerous-tag t) - -;; Miscellaneous helper functions - -(defun muse-publish-strip-URL (string &rest ignored) - "If the text \"URL:\" exists at the beginning of STRING, remove it. -The text is removed regardless of whether and part of it is uppercase." - (save-match-data - (if (string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" string) - (match-string 1 string) - string))) - -(defun muse-publish-markup-type (category default-func) - (let ((rule (muse-find-markup-element :overrides category (muse-style)))) - (funcall (or rule default-func)))) - -(defun muse-published-buffer-contents (buffer) - (with-current-buffer buffer - (goto-char (point-min)) - (let ((beg (and (search-forward "Emacs Muse begins here") - (muse-line-end-position))) - (end (and (search-forward "Emacs Muse ends here") - (muse-line-beginning-position)))) - (buffer-substring-no-properties beg end)))) - -(defun muse-published-contents (file) - (when (file-readable-p file) - (muse-with-temp-buffer - (muse-insert-file-contents file) - (muse-published-buffer-contents (current-buffer))))) - -(defun muse-publish-transform-output - (file temp-file output-path name gen-func &rest cleanup-exts) - "Transform the given TEMP-FILE into the OUTPUT-PATH, using GEN-FUNC." - (setq file (muse-page-name file)) - (message "Generating %s output for %s..." name file) - (if (not (funcall gen-func temp-file output-path)) - (message "Generating %s from %s...failed" name file) - (message "Generating %s output for %s...done" name file) - (muse-delete-file-if-exists temp-file) - (dolist (ext cleanup-exts) - (muse-delete-file-if-exists - (expand-file-name (concat file ext) - (file-name-directory output-path)))) - (message "Wrote %s" output-path))) - -(defun muse-publish-read-only (string) - (let ((end (1- (length string)))) - (add-text-properties 0 end - '(rear-nonsticky (read-only) read-only t) - string) - string)) - -;;; muse-publish.el ends here diff --git a/emacs.d/elisp/muse/muse-regexps.el b/emacs.d/elisp/muse/muse-regexps.el deleted file mode 100644 index ad3ce3f..0000000 --- a/emacs.d/elisp/muse/muse-regexps.el +++ /dev/null @@ -1,270 +0,0 @@ -;;; muse-regexps.el --- define regexps used by Muse - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This file is the part of the Muse project that describes regexps -;; that are used throughout the project. - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Regular Expressions -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgroup muse-regexp nil - "Regular expressions used in publishing and syntax highlighting." - :group 'muse) - -;;; Deal with the lack of character classes for regexps in Emacs21 and -;;; XEmacs - -(defcustom muse-regexp-use-character-classes 'undecided - "Indicate whether to use extended character classes like [:space:]. -If 'undecided, Muse will use them if your emacs is known to support them. - -Emacs 22 and Emacs 21.3.50 are known to support them. XEmacs -does not support them. - -Emacs 21.2 or higher support them, but with enough annoying edge -cases that the sanest default is to leave them disabled." - :type '(choice (const :tag "Yes" t) - (const :tag "No" nil) - (const :tag "Let Muse decide" undecided)) - :group 'muse-regexp) - -(defvar muse-regexp-emacs-revision - (save-match-data - (and (string-match "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)" - emacs-version) - (match-string 1 emacs-version) - (string-to-number (match-string 1 emacs-version)))) - "The revision number of this version of Emacs.") - -(defun muse-extreg-usable-p () - "Return non-nil if extended character classes can be used, -nil otherwise. - -This is used when deciding the initial values of the muse-regexp -options." - (cond - ((eq muse-regexp-use-character-classes t) - t) - ((eq muse-regexp-use-character-classes nil) - nil) - ((featurep 'xemacs) nil) ; unusable on XEmacs - ((> emacs-major-version 21) t) ; usable if > 21 - ((< emacs-major-version 21) nil) - ((< emacs-minor-version 3) nil) - ;; don't use if version is of format 21.x - ((null muse-regexp-emacs-revision) nil) - ;; only trust 21.3.50 or higher - ((>= muse-regexp-emacs-revision 50) t) - (t nil))) - -(defcustom muse-regexp-blank - (if (muse-extreg-usable-p) - "[:blank:]" - " \t") - "Regexp to use in place of \"[:blank:]\". -This should be something that matches spaces and tabs. - -It is like a regexp, but should be embeddable inside brackets. -Muse will detect the appropriate value correctly most of -the time." - :type 'string - :options '("[:blank:]" " \t") - :group 'muse-regexp) - -(defcustom muse-regexp-alnum - (if (muse-extreg-usable-p) - "[:alnum:]" - "A-Za-z0-9") - "Regexp to use in place of \"[:alnum:]\". -This should be something that matches all letters and numbers. - -It is like a regexp, but should be embeddable inside brackets. -muse will detect the appropriate value correctly most of -the time." - :type 'string - :options '("[:alnum:]" "A-Za-z0-9") - :group 'muse-regexp) - -(defcustom muse-regexp-lower - (if (muse-extreg-usable-p) - "[:lower:]" - "a-z") - "Regexp to use in place of \"[:lower:]\". -This should match all lowercase characters. - -It is like a regexp, but should be embeddable inside brackets. -muse will detect the appropriate value correctly most of -the time." - :type 'string - :options '("[:lower:]" "a-z") - :group 'muse-regexp) - -(defcustom muse-regexp-upper - (if (muse-extreg-usable-p) - "[:upper:]" - "A-Z") - "Regexp to use in place of \"[:upper:]\". -This should match all uppercase characters. - -It is like a regexp, but should be embeddable inside brackets. -muse will detect the appropriate value correctly most of -the time." - :type 'string - :options '("[:upper:]" "A-Z") - :group 'muse-regexp) - -;;; Regexps used to define Muse publishing syntax - -(defcustom muse-list-item-regexp - (concat "^%s\\(\\([^\n" muse-regexp-blank "].*?\\)?::" - "\\(?:[" muse-regexp-blank "]+\\|$\\)" - "\\|[" muse-regexp-blank "]-[" muse-regexp-blank "]*" - "\\|[" muse-regexp-blank "][0-9]+\\.[" muse-regexp-blank "]*\\)") - "Regexp used to match the beginning of a list item. -The '%s' will be replaced with a whitespace regexp when publishing." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-ol-item-regexp (concat "\\`[" muse-regexp-blank "]+[0-9]+\\.") - "Regexp used to match an ordered list item." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-ul-item-regexp (concat "\\`[" muse-regexp-blank "]+-") - "Regexp used to match an unordered list item." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-dl-term-regexp - (concat "[" muse-regexp-blank "]*\\(.+?\\)[" - muse-regexp-blank "]+::\\(?:[" muse-regexp-blank "]+\\|$\\)") - "Regexp used to match a definition list term. -The first match string must contain the term." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-dl-entry-regexp (concat "\\`[" muse-regexp-blank "]*::") - "Regexp used to match a definition list entry." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-table-field-regexp - (concat "[" muse-regexp-blank "]+\\(|+\\)\\(?:[" - muse-regexp-blank "]\\|$\\)") - "Regexp used to match table separators when publishing." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-table-line-regexp (concat ".*" muse-table-field-regexp ".*") - "Regexp used to match a table line when publishing." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-table-hline-regexp (concat "[" muse-regexp-blank - "]*|[-+]+|[" muse-regexp-blank - "]*") - "Regexp used to match a horizontal separator line in a table." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-table-el-border-regexp (concat "[" muse-regexp-blank "]*" - "\\+\\(-*\\+\\)+" - "[" muse-regexp-blank "]*") - "Regexp used to match the beginning and end of a table.el-style table." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-table-el-line-regexp (concat "[" muse-regexp-blank "]*" - "|\\(.*|\\)*" - "[" muse-regexp-blank "]*") - "Regexp used to match a table line of a table.el-style table." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-tag-regexp - (concat "<\\([^/" muse-regexp-blank "\n][^" muse-regexp-blank - "</>\n]*\\)\\(\\s-+[^<>]+[^</>\n]\\)?\\(/\\)?>") - "A regexp used to find XML-style tags within a buffer when publishing. -Group 1 should be the tag name, group 2 the properties, and group -3 the optional immediate ending slash." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-explicit-link-regexp - "\\[\\[\\([^][\n]+\\)\\]\\(?:\\[\\([^][\n]+\\)\\]\\)?\\]" - "Regexp used to match [[target][description]] links. -Paren group 1 must match the URL, and paren group 2 the description." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-implicit-link-regexp - (concat "\\([^" muse-regexp-blank "\n]+\\)") - "Regexp used to match an implicit link. -An implicit link is the largest block of text to be checked for -URLs and bare WikiNames by the `muse-link-at-point' function. -Paren group 1 is the text to be checked. - -URLs are checked by default. To get WikiNames, load -muse-wiki.el. - -This is only used when you are using muse-mode.el, but not -muse-colors.el. - -If the above applies, and you want to match things with spaces in -them, you will have to modify this." - :type 'regexp - :group 'muse-regexp) - -;;; Regexps used to determine file types - -(defcustom muse-file-regexp - (concat "\\`[~/]\\|\\?\\|/\\'\\|\\." - "\\(html?\\|pdf\\|mp3\\|el\\|zip\\|txt\\|tar\\)" - "\\(\\.\\(gz\\|bz2\\)\\)?\\'") - "A link matching this regexp will be regarded as a link to a file." - :type 'regexp - :group 'muse-regexp) - -(defcustom muse-image-regexp - "\\.\\(eps\\|gif\\|jp\\(e?g\\)\\|p\\(bm\\|ng\\)\\|tiff\\|x\\([bp]m\\)\\)\\'" - "A link matching this regexp will be published inline as an image. -For example: - - [[./wife.jpg][A picture of my wife]] - -If you omit the description, the alt tag of the resulting HTML -buffer will be the name of the file." - :type 'regexp - :group 'muse-regexp) - -(provide 'muse-regexps) - -;;; muse-regexps.el ends here diff --git a/emacs.d/elisp/muse/muse-texinfo.el b/emacs.d/elisp/muse/muse-texinfo.el deleted file mode 100644 index 4ad0092..0000000 --- a/emacs.d/elisp/muse/muse-texinfo.el +++ /dev/null @@ -1,346 +0,0 @@ -;;; muse-texinfo.el --- publish entries to Texinfo format or PDF - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse Texinfo Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-latex) -(require 'texnfo-upd) - -(defgroup muse-texinfo nil - "Rules for marking up a Muse file as a Texinfo article." - :group 'muse-publish) - -(defcustom muse-texinfo-process-natively nil - "If non-nil, use the Emacs `texinfmt' module to make Info files." - :type 'boolean - :require 'texinfmt - :group 'muse-texinfo) - -(defcustom muse-texinfo-extension ".texi" - "Default file extension for publishing Texinfo files." - :type 'string - :group 'muse-texinfo) - -(defcustom muse-texinfo-info-extension ".info" - "Default file extension for publishing Info files." - :type 'string - :group 'muse-texinfo) - -(defcustom muse-texinfo-pdf-extension ".pdf" - "Default file extension for publishing PDF files." - :type 'string - :group 'muse-texinfo) - -(defcustom muse-texinfo-header - "\\input texinfo @c -*-texinfo-*- - -@setfilename <lisp>(concat (muse-page-name) \".info\")</lisp> -@settitle <lisp>(muse-publishing-directive \"title\")</lisp> - -@documentencoding iso-8859-1 - -@iftex -@finalout -@end iftex - -@titlepage -@title <lisp>(muse-publishing-directive \"title\")</lisp> -@author <lisp>(muse-publishing-directive \"author\")</lisp> -@end titlepage - -<lisp>(and muse-publish-generate-contents \"@contents\")</lisp> - -@node Top, Overview, , (dir) -@top Overview -@c Page published by Emacs Muse begins here\n\n" - "Text to prepend to a Muse page being published as Texinfo. -This may be text or a filename. -It may contain <lisp> markup tags." - :type 'string - :group 'muse-texinfo) - -(defcustom muse-texinfo-footer - "\n@c Page published by Emacs Muse ends here -@bye\n" - "Text to append to a Muse page being published as Texinfo. -This may be text or a filename. -It may contain <lisp> markup tags." - :type 'string - :group 'muse-texinfo) - -(defcustom muse-texinfo-markup-regexps nil - "List of markup rules for publishing a Muse page to Texinfo. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-texinfo) - -(defcustom muse-texinfo-markup-functions - '((table . muse-texinfo-markup-table) - (heading . muse-texinfo-markup-heading)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-texinfo) - -(defcustom muse-texinfo-markup-strings - '((image-with-desc . "@center @image{%1%, , , %3%, %2%}@*\n@center %3%") - (image . "@noindent @image{%s, , , , %s}") - (image-link . "@uref{%s, %s.%s}") - (anchor-ref . "@ref{%s, %s}") - (url . "@uref{%s, %s}") - (link . "@ref{Top, %2%, , %1%, }") - (link-and-anchor . "@ref{%3%, %2%, , %1%, %3%}") - (email-addr . "@email{%s}") - (anchor . "@anchor{%s} ") - (emdash . "---") - (comment-begin . "@ignore\n") - (comment-end . "\n@end ignore\n") - (rule . "@sp 1") - (no-break-space . "@w{ }") - (line-break . "@*") - (enddots . "@enddots{}") - (dots . "@dots{}") - (section . "@chapter ") - (subsection . "@section ") - (subsubsection . "@subsection ") - (section-other . "@subsubheading ") - (footnote . "@footnote{") - (footnote-end . "}") - (begin-underline . "_") - (end-underline . "_") - (begin-literal . "@samp{") - (end-literal . "}") - (begin-emph . "@emph{") - (end-emph . "}") - (begin-more-emph . "@strong{") - (end-more-emph . "}") - (begin-most-emph . "@strong{@emph{") - (end-most-emph . "}}") - (begin-verse . "@display\n") - (end-verse-line . "") - (verse-space . "@ @ ") - (end-verse . "\n@end display") - (begin-example . "@example\n") - (end-example . "\n@end example") - (begin-center . "@quotation\n") - (end-center . "\n@end quotation") - (begin-quote . "@quotation\n") - (end-quote . "\n@end quotation") - (begin-cite . "") - (begin-cite-author . "") - (begin-cite-year . "") - (end-cite . "") - (begin-uli . "@itemize @bullet\n") - (end-uli . "\n@end itemize") - (begin-uli-item . "@item\n") - (begin-oli . "@enumerate\n") - (end-oli . "\n@end enumerate") - (begin-oli-item . "@item\n") - (begin-dl . "@table @strong\n") - (end-dl . "\n@end table") - (begin-ddt . "@item ")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-texinfo) - -(defcustom muse-texinfo-markup-specials - '((?@ . "@@") - (?{ . "@{") - (?} . "@}")) - "A table of characters which must be represented specially." - :type '(alist :key-type character :value-type string) - :group 'muse-texinfo) - -(defcustom muse-texinfo-markup-specials-url - '((?@ . "@@") - (?{ . "@{") - (?} . "@}") - (?, . "@comma{}")) - "A table of characters which must be represented specially. -These are applied to URLs." - :type '(alist :key-type character :value-type string) - :group 'muse-texinfo) - -(defun muse-texinfo-decide-specials (context) - "Determine the specials to escape, depending on CONTEXT." - (cond ((memq context '(underline literal emphasis email url url-desc image - footnote)) - muse-texinfo-markup-specials-url) - (t muse-texinfo-markup-specials))) - -(defun muse-texinfo-markup-table () - (let* ((table-info (muse-publish-table-fields (match-beginning 0) - (match-end 0))) - (row-len (car table-info)) - (field-list (cdr table-info))) - (when table-info - (muse-insert-markup "@multitable @columnfractions") - (dotimes (field row-len) - (muse-insert-markup " " (number-to-string (/ 1.0 row-len)))) - (dolist (fields field-list) - (let ((type (car fields))) - (unless (eq type 'hline) - (setq fields (cdr fields)) - (if (= type 2) - (muse-insert-markup "\n@headitem ") - (muse-insert-markup "\n@item ")) - (insert (car fields)) - (setq fields (cdr fields)) - (dolist (field fields) - (muse-insert-markup " @tab ") - (insert field))))) - (muse-insert-markup "\n@end multitable") - (insert ?\n)))) - -(defun muse-texinfo-remove-links (string) - "Remove explicit links from STRING, replacing them with the link -description. - -If no description exists for the link, use the link itself." - (let ((start nil)) - (while (setq start (string-match muse-explicit-link-regexp string - start)) - (setq string - (replace-match (or (match-string 2 string) - (match-string 1 string)) - t t string))) - string)) - -(defun muse-texinfo-protect-wikiwords (start end) - "Protect all wikiwords from START to END from further processing." - (and (boundp 'muse-wiki-wikiword-regexp) - (featurep 'muse-wiki) - (save-excursion - (goto-char start) - (while (re-search-forward muse-wiki-wikiword-regexp end t) - (muse-publish-mark-read-only (match-beginning 0) - (match-end 0)))))) - -(defun muse-texinfo-markup-heading () - (save-excursion - (muse-publish-markup-heading)) - (let* ((eol (muse-line-end-position)) - (orig-heading (buffer-substring (point) eol)) - (beg (point))) - (delete-region (point) eol) - ;; don't allow links to be published in headings - (insert (muse-texinfo-remove-links orig-heading)) - (muse-texinfo-protect-wikiwords beg (point)))) - -(defun muse-texinfo-munge-buffer () - (muse-latex-fixup-dquotes) - (texinfo-insert-node-lines (point-min) (point-max) t) - (texinfo-all-menus-update t)) - -(defun muse-texinfo-pdf-browse-file (file) - (shell-command (concat "open " file))) - -(defun muse-texinfo-info-generate (file output-path final-target) - ;; The version of `texinfmt.el' that comes with Emacs 21 doesn't - ;; support @documentencoding, so hack it in. - (when (and (not (featurep 'xemacs)) - (eq emacs-major-version 21)) - (put 'documentencoding 'texinfo-format - 'texinfo-discard-line-with-args)) - ;; Most versions of `texinfmt.el' do not support @headitem, so hack - ;; it in. - (unless (get 'headitem 'texinfo-format) - (put 'headitem 'texinfo-format 'texinfo-multitable-item)) - (muse-publish-transform-output - file output-path final-target "Info" - (function - (lambda (file output-path) - (if muse-texinfo-process-natively - (save-window-excursion - (save-excursion - (find-file file) - (let ((inhibit-read-only t)) - (texinfo-format-buffer)) - (save-buffer) - (kill-buffer (current-buffer)) - (let ((buf (get-file-buffer file))) - (with-current-buffer buf - (set-buffer-modified-p nil) - (kill-buffer (current-buffer)))) - t)) - (let ((result (shell-command - (concat "makeinfo --enable-encoding --output=" - output-path " " file)))) - (if (or (not (numberp result)) - (eq result 0)) - t - nil))))))) - -(defun muse-texinfo-pdf-generate (file output-path final-target) - (let ((muse-latex-pdf-program "pdftex") - (muse-latex-pdf-cruft '(".aux" ".cp" ".fn" ".ky" ".log" ".pg" ".toc" - ".tp" ".vr"))) - (muse-latex-pdf-generate file output-path final-target))) - -;;; Register the Muse TEXINFO Publishers - -(muse-define-style "texi" - :suffix 'muse-texinfo-extension - :regexps 'muse-texinfo-markup-regexps - :functions 'muse-texinfo-markup-functions - :strings 'muse-texinfo-markup-strings - :specials 'muse-texinfo-decide-specials - :after 'muse-texinfo-munge-buffer - :header 'muse-texinfo-header - :footer 'muse-texinfo-footer - :browser 'find-file) - -(muse-derive-style "info" "texi" - :final 'muse-texinfo-info-generate - :link-suffix 'muse-texinfo-info-extension - :osuffix 'muse-texinfo-info-extension - :browser 'info) - -(muse-derive-style "info-pdf" "texi" - :final 'muse-texinfo-pdf-generate - :link-suffix 'muse-texinfo-pdf-extension - :osuffix 'muse-texinfo-pdf-extension - :browser 'muse-texinfo-pdf-browse-file) - -(provide 'muse-texinfo) - -;;; muse-texinfo.el ends here diff --git a/emacs.d/elisp/muse/muse-wiki.el b/emacs.d/elisp/muse/muse-wiki.el deleted file mode 100644 index e2cd3a2..0000000 --- a/emacs.d/elisp/muse/muse-wiki.el +++ /dev/null @@ -1,498 +0,0 @@ -;;; muse-wiki.el --- wiki features for Muse - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Yann Hodique <Yann.Hodique@lifl.fr> -;; Keywords: - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;; Per B. Sederberg (per AT med DOT upenn DOT edu) made it so that all -;; files in a Muse project can become implicit links. - -;;; Code: - -(require 'muse-regexps) -(require 'muse-mode) - -(eval-when-compile - (require 'muse-colors)) - -(defgroup muse-wiki nil - "Options controlling the behavior of Emacs Muse Wiki features." - :group 'muse-mode) - -(defcustom muse-wiki-use-wikiword t - "Whether to use color and publish bare WikiNames." - :type 'boolean - :group 'muse-wiki) - -(defcustom muse-wiki-allow-nonexistent-wikiword nil - "Whether to color bare WikiNames that don't have an existing file." - :type 'boolean - :group 'muse-wiki) - -(defcustom muse-wiki-match-all-project-files nil - "If non-nil, Muse will color and publish implicit links to any -file in your project, regardless of whether its name is a WikiWord." - :type 'boolean - :group 'muse-wiki) - -(defcustom muse-wiki-ignore-implicit-links-to-current-page nil - "If non-nil, Muse will not recognize implicit links to the current -page, both when formatting and publishing." - :type 'boolean - :group 'muse-wiki) - -(defvar muse-wiki-project-file-regexp nil - "Regexp used to match the files in the current project. - -This is set by `muse-wiki-update-project-file-regexp' automatically -when `muse-wiki-match-all-project-files' is non-nil.") -(make-variable-buffer-local 'muse-wiki-project-file-regexp) - -(defun muse-wiki-update-project-file-regexp () - "Update a local copy of `muse-wiki-project-file-regexp' to include -all the files in the project." - ;; see if the user wants to match project files - (when muse-wiki-match-all-project-files - (let ((files (mapcar #'car (muse-project-file-alist (muse-project))))) - (setq muse-wiki-project-file-regexp - (when files - (concat "\\(" - ;; include all files from the project - (regexp-opt files 'words) - "\\)")))) - ;; update coloring setup - (when (featurep 'muse-colors) - (muse-colors-define-highlighting 'muse-mode muse-colors-markup)))) - -(add-hook 'muse-update-values-hook - 'muse-wiki-update-project-file-regexp) -(add-hook 'muse-project-file-alist-hook - 'muse-wiki-update-project-file-regexp) - -(defcustom muse-wiki-wikiword-regexp - (concat "\\<\\(\\(?:[" muse-regexp-upper - "]+[" muse-regexp-lower "]+\\)\\(?:[" - muse-regexp-upper "]+[" muse-regexp-lower "]+\\)+\\)") - "Regexp used to match WikiWords." - :set (function - (lambda (sym value) - (set sym value) - (when (featurep 'muse-colors) - (muse-colors-define-highlighting 'muse-mode muse-colors-markup)))) - :type 'regexp - :group 'muse-wiki) - -(defcustom muse-wiki-ignore-bare-project-names nil - "Determine whether project names without a page specifer are links. - -If non-nil, project names without a page specifier will not be -considered links. - -When nil, project names without a specifier are highlighted and -they link to the default page of the project that they name." - :type 'boolean - :group 'muse-wiki) - -(defvar muse-wiki-interwiki-regexp nil - "Regexp that matches all interwiki links. - -This is automatically generated by setting `muse-wiki-interwiki-alist'. -It can also be set by calling `muse-wiki-update-interwiki-regexp'.") - -(defcustom muse-wiki-interwiki-delimiter "#\\|::" - "Delimiter regexp used for InterWiki links. - -If you use groups, use only shy groups." - :type 'regexp - :group 'muse-wiki) - -(defcustom muse-wiki-interwiki-replacement ": " - "Regexp used for replacing `muse-wiki-interwiki-delimiter' in -InterWiki link descriptions. - -If you want this replacement to happen, you must add -`muse-wiki-publish-pretty-interwiki' to -`muse-publish-desc-transforms'." - :type 'regexp - :group 'muse-wiki) - -(eval-when-compile - (defvar muse-wiki-interwiki-alist)) - -(defun muse-wiki-project-files-with-spaces (&optional project) - "Return a list of files in PROJECT that have spaces." - (setq project (muse-project project)) - (let ((flist nil)) - (save-match-data - (dolist (entry (muse-project-file-alist project)) - (when (string-match " " (car entry)) - (setq flist (cons (car entry) flist))))) - flist)) - -(defun muse-wiki-update-interwiki-regexp () - "Update the value of `muse-wiki-interwiki-regexp' based on -`muse-wiki-interwiki-alist' and `muse-project-alist'." - (if (null muse-project-alist) - (setq muse-wiki-interwiki-regexp nil) - (let ((old-value muse-wiki-interwiki-regexp)) - (setq muse-wiki-interwiki-regexp - (concat "\\<\\(" (regexp-opt (mapcar #'car muse-project-alist)) - (when muse-wiki-interwiki-alist - (let ((interwiki-rules - (mapcar #'car muse-wiki-interwiki-alist))) - (when interwiki-rules - (concat "\\|" (regexp-opt interwiki-rules))))) - "\\)\\(?:\\(" muse-wiki-interwiki-delimiter - "\\)\\(" - (when muse-wiki-match-all-project-files - ;; append the files from the project - (let ((files nil)) - (dolist (proj muse-project-alist) - (setq files - (nconc (muse-wiki-project-files-with-spaces - (car proj)) - files))) - (when files - (concat (regexp-opt files) "\\|")))) - "\\sw+\\)\\(#\\S-+\\)?\\)?\\>")) - (when (and (featurep 'muse-colors) - (not (string= old-value muse-wiki-interwiki-regexp))) - (muse-colors-define-highlighting 'muse-mode muse-colors-markup))))) - -(defcustom muse-wiki-interwiki-alist - '(("EmacsWiki" . "http://www.emacswiki.org/cgi-bin/wiki/")) - "A table of WikiNames that refer to external entities. - -The format of this table is an alist, or series of cons cells. -Each cons cell must be of the form: - - (WIKINAME . STRING-OR-FUNCTION) - -The second part of the cons cell may either be a STRING, which in most -cases should be a URL, or a FUNCTION. If a function, it will be -called with one argument: the tag applied to the Interwiki name, or -nil if no tag was used. If the cdr was a STRING and a tag is used, -the tag is simply appended. - -Here are some examples: - - (\"JohnWiki\" . \"http://alice.dynodns.net/wiki?\") - -Referring to [[JohnWiki::EmacsModules]] then really means: - - http://alice.dynodns.net/wiki?EmacsModules - -If a function is used for the replacement text, you can get creative -depending on what the tag is. Tags may contain any alphabetic -character, any number, % or _. If you need other special characters, -use % to specify the hex code, as in %2E. All browsers should support -this." - :type '(repeat (cons (string :tag "WikiName") - (choice (string :tag "URL") function))) - :set (function - (lambda (sym value) - (set sym value) - (muse-wiki-update-interwiki-regexp))) - :group 'muse-wiki) - -(add-hook 'muse-update-values-hook - 'muse-wiki-update-interwiki-regexp) - -(defun muse-wiki-resolve-project-page (&optional project page) - "Return the published path from the current page to PAGE of PROJECT. - -If PAGE is not specified, use the value of :default in PROJECT. - -If PROJECT is not specified, default to the current project. If -no project is current, use the first project of -`muse-projects-alist'. - -Note that PAGE can have several output directories. If this is -the case, we will use the first one that matches our current -style and has the same link suffix, ignoring the others. If no -style has the same link suffix as the current publishing style, -use the first style we find." - (setq project (or (and project - (muse-project project)) - (muse-project) - (car muse-project-alist)) - page (or page (muse-get-keyword :default (cadr project)))) - (let* ((page-path (and muse-project-alist - (muse-project-page-file page project))) - (remote-styles (and page-path (muse-project-applicable-styles - page-path (cddr project)))) - (local-style (muse-project-current-output-style))) - (cond ((and remote-styles local-style muse-publishing-p) - (muse-project-resolve-link page local-style remote-styles)) - ((not muse-publishing-p) - (if page-path - page-path - (when muse-wiki-allow-nonexistent-wikiword - ;; make a path to a nonexistent file in project - (setq page-path (expand-file-name - page (car (cadr project)))) - (if (and muse-file-extension - (not (string= muse-file-extension ""))) - (concat page-path "." muse-file-extension) - page-path))))))) - -(defun muse-wiki-handle-implicit-interwiki (&optional string) - "If STRING or point has an interwiki link, resolve it to a filename. - -Match string 0 is set to the link." - (when (and muse-wiki-interwiki-regexp - (if string (string-match muse-wiki-interwiki-regexp string) - (looking-at muse-wiki-interwiki-regexp))) - (let* ((project (match-string 1 string)) - (subst (cdr (assoc project muse-wiki-interwiki-alist))) - (word (match-string 3 string)) - (anchor (if (match-beginning 4) - (match-string 4 string) - ""))) - (if subst - (if (functionp subst) - (and (setq word (funcall subst word)) - (concat word anchor)) - (concat subst word anchor)) - (and (assoc project muse-project-alist) - (or word (not muse-wiki-ignore-bare-project-names)) - (setq word (muse-wiki-resolve-project-page project word)) - (concat word anchor)))))) - -(defun muse-wiki-handle-explicit-interwiki (&optional string) - "If STRING or point has an interwiki link, resolve it to a filename." - (let ((right-pos (if string (length string) (match-end 1)))) - (when (and muse-wiki-interwiki-regexp - (if string (string-match muse-wiki-interwiki-regexp string) - (save-restriction - (narrow-to-region (point) right-pos) - (looking-at muse-wiki-interwiki-regexp)))) - (let* ((project (match-string 1 string)) - (subst (cdr (assoc project muse-wiki-interwiki-alist))) - (anchor (and (match-beginning 4) - (match-string 4 string))) - (word (when (match-end 2) - (cond (anchor (match-string 3 string)) - (string (substring string (match-end 2))) - (right-pos (buffer-substring (match-end 2) - right-pos)) - (t nil))))) - (if (and (null word) - right-pos - (not (= right-pos (match-end 1)))) - ;; if only a project name was found, it must take up the - ;; entire string or link - nil - (unless anchor - (if (or (null word) - (not (string-match "#[^#]+\\'" word))) - (setq anchor "") - (setq anchor (match-string 0 word)) - (setq word (substring word 0 (match-beginning 0))))) - (if subst - (if (functionp subst) - (and (setq word (funcall subst word)) - (concat word anchor)) - (concat subst word anchor)) - (and (assoc project muse-project-alist) - (or word (not muse-wiki-ignore-bare-project-names)) - (setq word (muse-wiki-resolve-project-page project word)) - (concat word anchor)))))))) - -(defun muse-wiki-handle-wikiword (&optional string) - "If STRING or point has a WikiWord, return it. - -Match 1 is set to the WikiWord." - (when (and (or (and muse-wiki-match-all-project-files - muse-wiki-project-file-regexp - (if string - (string-match muse-wiki-project-file-regexp string) - (looking-at muse-wiki-project-file-regexp))) - (and muse-wiki-use-wikiword - (if string - (string-match muse-wiki-wikiword-regexp string) - (looking-at muse-wiki-wikiword-regexp)))) - (cond - (muse-wiki-allow-nonexistent-wikiword - t) - ((and muse-wiki-ignore-implicit-links-to-current-page - (string= (match-string 1 string) (muse-page-name))) - nil) - ((and (muse-project-of-file) - (muse-project-page-file - (match-string 1 string) muse-current-project t)) - t) - ((file-exists-p (match-string 1 string)) - t) - (t nil))) - (match-string 1 string))) - -;;; Prettifications - -(defcustom muse-wiki-publish-small-title-words - '("the" "and" "at" "on" "of" "for" "in" "an" "a") - "Strings that should be downcased in a page title. - -This is used by `muse-wiki-publish-pretty-title', which must be -called manually." - :type '(repeat string) - :group 'muse-wiki) - -(defcustom muse-wiki-hide-nop-tag t - "If non-nil, hide <nop> tags when coloring a Muse buffer." - :type 'boolean - :group 'muse-wiki) - -(defun muse-wiki-publish-pretty-title (&optional title explicit) - "Return a pretty version of the given TITLE. - -If EXPLICIT is non-nil, TITLE will be returned unmodified." - (unless title (setq title (or (muse-publishing-directive "title") ""))) - (if (or explicit - (save-match-data (string-match muse-url-regexp title))) - title - (save-match-data - (let ((case-fold-search nil)) - (while (string-match (concat "\\([" muse-regexp-lower - "]\\)\\([" muse-regexp-upper - "0-9]\\)") - title) - (setq title (replace-match "\\1 \\2" t nil title))) - (let* ((words (split-string title)) - (w (cdr words))) - (while w - (if (member (downcase (car w)) - muse-wiki-publish-small-title-words) - (setcar w (downcase (car w)))) - (setq w (cdr w))) - (mapconcat 'identity words " ")))))) - -(defun muse-wiki-publish-pretty-interwiki (desc &optional explicit) - "Replace instances of `muse-wiki-interwiki-delimiter' with -`muse-wiki-interwiki-replacement'." - (if (or explicit - (save-match-data (string-match muse-url-regexp desc))) - desc - (muse-replace-regexp-in-string muse-wiki-interwiki-delimiter - muse-wiki-interwiki-replacement - desc))) - -;;; Coloring setup - -(defun muse-wiki-colors-nop-tag (beg end) - "Inhibit the colorization of inhibit links just after the tag. - -Example: <nop>WikiWord" - (when muse-wiki-hide-nop-tag - (add-text-properties beg (+ beg 5) - '(invisible muse intangible t))) - (unless (> (+ beg 6) (point-max)) - (add-text-properties (+ beg 5) (+ beg 6) - '(muse-no-implicit-link t)))) - -(defun muse-colors-wikiword-separate () - (add-text-properties (match-beginning 0) (match-end 0) - '(invisible muse intangible t))) - -(defun muse-wiki-insinuate-colors () - (add-to-list 'muse-colors-tags - '("nop" nil nil nil muse-wiki-colors-nop-tag) - t) - (add-to-list 'muse-colors-markup - '(muse-wiki-interwiki-regexp t muse-colors-implicit-link) - t) - (add-to-list 'muse-colors-markup - '(muse-wiki-wikiword-regexp t muse-colors-implicit-link) - t) - (add-to-list 'muse-colors-markup - '(muse-wiki-project-file-regexp t muse-colors-implicit-link) - t) - (add-to-list 'muse-colors-markup - '("''''" ?\' muse-colors-wikiword-separate) - nil) - (muse-colors-define-highlighting 'muse-mode muse-colors-markup)) - -(eval-after-load "muse-colors" '(muse-wiki-insinuate-colors)) - -;;; Publishing setup - -(defun muse-wiki-publish-nop-tag (beg end) - "Inhibit the colorization of inhibit links just after the tag. - -Example: <nop>WikiWord" - (unless (= (point) (point-max)) - (muse-publish-mark-read-only (point) (+ (point) 1)))) - -(defun muse-wiki-insinuate-publish () - (add-to-list 'muse-publish-markup-tags - '("nop" nil nil nil muse-wiki-publish-nop-tag) - t) - (add-to-list 'muse-publish-markup-regexps - '(3100 muse-wiki-interwiki-regexp 0 link) - t) - (add-to-list 'muse-publish-markup-regexps - '(3200 muse-wiki-wikiword-regexp 0 link) - t) - (add-to-list 'muse-publish-markup-regexps - '(3250 muse-wiki-project-file-regexp 0 link) - t) - (add-to-list 'muse-publish-markup-regexps - '(3300 "''''" 0 "") - t) - (custom-add-option 'muse-publish-desc-transforms - 'muse-wiki-publish-pretty-interwiki) - (custom-add-option 'muse-publish-desc-transforms - 'muse-wiki-publish-pretty-title)) - -(eval-after-load "muse-publish" '(muse-wiki-insinuate-publish)) - -;;; Insinuate link handling - -(custom-add-option 'muse-implicit-link-functions - 'muse-wiki-handle-implicit-interwiki) -(custom-add-option 'muse-implicit-link-functions - 'muse-wiki-handle-wikiword) - -(custom-add-option 'muse-explicit-link-functions - 'muse-wiki-handle-explicit-interwiki) - -(add-to-list 'muse-implicit-link-functions - 'muse-wiki-handle-implicit-interwiki t) -(add-to-list 'muse-implicit-link-functions - 'muse-wiki-handle-wikiword t) - -(add-to-list 'muse-explicit-link-functions - 'muse-wiki-handle-explicit-interwiki t) - -;;; Obsolete functions - -(defun muse-wiki-update-custom-values () - (muse-display-warning - (concat "Please remove `muse-wiki-update-custom-values' from" - " `muse-mode-hook'. Its use is now deprecated."))) - -(provide 'muse-wiki) -;;; muse-wiki.el ends here diff --git a/emacs.d/elisp/muse/muse-xml-common.el b/emacs.d/elisp/muse/muse-xml-common.el deleted file mode 100644 index 75869ca..0000000 --- a/emacs.d/elisp/muse/muse-xml-common.el +++ /dev/null @@ -1,201 +0,0 @@ -;;; muse-xml-common.el --- common routines for XML-like publishing styles - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Contributors: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse XML Publishing - Common Elements -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-regexps) - -(defcustom muse-xml-encoding-map - '((iso-8859-1 . "iso-8859-1") - (iso-2022-jp . "iso-2022-jp") - (utf-8 . "utf-8") - (japanese-iso-8bit . "euc-jp") - (chinese-big5 . "big5") - (mule-utf-8 . "utf-8") - (chinese-iso-8bit . "gb2312") - (chinese-gbk . "gbk")) - "An alist mapping Emacs coding systems to appropriate XML charsets. -Use the base name of the coding system (i.e. without the -unix)." - :type '(alist :key-type coding-system :value-type string) - :group 'muse-xml) - -(defun muse-xml-transform-content-type (content-type default) - "Using `muse-xml-encoding-map', try and resolve an Emacs coding -system to an associated XML coding system. -If no match is found, the DEFAULT charset is used instead." - (let ((match (and (fboundp 'coding-system-base) - (assoc (coding-system-base content-type) - muse-xml-encoding-map)))) - (if match - (cdr match) - default))) - -(defcustom muse-xml-markup-specials - '((?\" . """) - (?\< . "<") - (?\> . ">") - (?\& . "&")) - "A table of characters which must be represented specially." - :type '(alist :key-type character :value-type string) - :group 'muse-xml) - -(defcustom muse-xml-markup-specials-url-extra - '((?\" . """) - (?\< . "<") - (?\> . ">") - (?\& . "&") - (?\ . "%20") - (?\n . "%0D%0A")) - "A table of characters which must be represented specially. -These are extra characters that are escaped within URLs." - :type '(alist :key-type character :value-type string) - :group 'muse-xml) - -(defun muse-xml-decide-specials (context) - "Determine the specials to escape, depending on CONTEXT." - (cond ((memq context '(email url image)) - 'muse-xml-escape-url) - ((eq context 'url-extra) - muse-xml-markup-specials-url-extra) - (t muse-xml-markup-specials))) - -(defun muse-xml-escape-url (str) - "Convert to character entities any non-alphanumeric characters -outside a few punctuation symbols, that risk being misinterpreted -if not escaped." - (when str - (setq str (muse-publish-escape-specials-in-string str 'url-extra)) - (let (pos code len ch) - (save-match-data - (while (setq pos (string-match (concat "[^-" - muse-regexp-alnum - "/:._=@\\?~#%\"\\+<>()&;]") - str pos)) - (setq ch (aref str pos) - code (concat "&#" (int-to-string - (cond ((fboundp 'char-to-ucs) - (char-to-ucs ch)) - ((fboundp 'char-to-int) - (char-to-int ch)) - (t ch))) - ";") - len (length code) - str (concat (substring str 0 pos) - code - (when (< pos (length str)) - (substring str (1+ pos) nil))) - pos (+ len pos))) - str)))) - -(defun muse-xml-markup-anchor () - (unless (get-text-property (match-end 1) 'muse-link) - (let ((text (muse-markup-text 'anchor (match-string 2)))) - (save-match-data - (skip-chars-forward (concat muse-regexp-blank "\n")) - (when (looking-at (concat "<\\([^" muse-regexp-blank "/>\n]+\\)>")) - (goto-char (match-end 0))) - (muse-insert-markup text))) - (match-string 1))) - -(defun muse-xml-sort-table (table) - "Sort the given table structure so that it validates properly." - ;; Note that the decision matrix must have a nil diagonal, or else - ;; elements with the same type will be reversed with respect to each - ;; other. - (let ((decisions '((nil nil nil) ; body < header, body < footer - (t nil t) ; header stays where it is - (t nil nil)))) ; footer < header - (sort table #'(lambda (l r) - (and (integerp (car l)) (integerp (car r)) - (nth (1- (car r)) - (nth (1- (car l)) decisions))))))) - -(defun muse-xml-markup-table (&optional attributes) - "Publish the matched region into a table. -If a string ATTRIBUTES is given, pass it to the markup string begin-table." - (let* ((table-info (muse-publish-table-fields (match-beginning 0) - (match-end 0))) - (row-len (car table-info)) - (supports-group (not (string= (muse-markup-text 'begin-table-group - row-len) - ""))) - (field-list (muse-xml-sort-table (cdr table-info))) - last-part) - (when table-info - (let ((beg (point))) - (muse-publish-ensure-block beg)) - (muse-insert-markup (muse-markup-text 'begin-table (or attributes ""))) - (muse-insert-markup (muse-markup-text 'begin-table-group row-len)) - (dolist (fields field-list) - (let* ((type (car fields)) - (part (cond ((eq type 'hline) nil) - ((= type 1) "tbody") - ((= type 2) "thead") - ((= type 3) "tfoot"))) - (col (cond ((eq type 'hline) nil) - ((= type 1) "td") - ((= type 2) "th") - ((= type 3) "td")))) - (setq fields (cdr fields)) - (unless (and part last-part (string= part last-part)) - (when last-part - (muse-insert-markup " </" last-part ">\n") - (when (eq type 'hline) - ;; horizontal separators are represented by closing - ;; the current table group and opening a new one - (muse-insert-markup (muse-markup-text 'end-table-group)) - (muse-insert-markup (muse-markup-text 'begin-table-group - row-len)))) - (when part - (muse-insert-markup " <" part ">\n")) - (setq last-part part)) - (unless (eq type 'hline) - (muse-insert-markup (muse-markup-text 'begin-table-row)) - (dolist (field fields) - (muse-insert-markup (muse-markup-text 'begin-table-entry col)) - (insert field) - (muse-insert-markup (muse-markup-text 'end-table-entry col))) - (muse-insert-markup (muse-markup-text 'end-table-row))))) - (when last-part - (muse-insert-markup " </" last-part ">\n")) - (muse-insert-markup (muse-markup-text 'end-table-group)) - (muse-insert-markup (muse-markup-text 'end-table)) - (insert ?\n)))) - -(defun muse-xml-prepare-buffer () - (set (make-local-variable 'muse-publish-url-transforms) - (cons 'muse-xml-escape-string muse-publish-url-transforms))) - -(provide 'muse-xml-common) - -;;; muse-xml-common.el ends here diff --git a/emacs.d/elisp/muse/muse-xml.el b/emacs.d/elisp/muse/muse-xml.el deleted file mode 100644 index 9f26ade..0000000 --- a/emacs.d/elisp/muse/muse-xml.el +++ /dev/null @@ -1,274 +0,0 @@ -;;; muse-xml.el --- publish XML files - -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Michael Olson <mwolson@gnu.org> -;; Date: Sat 23-Jul-2005 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; James Clarke's nxml-mode can be used for editing and validating -;; Muse-generated XML files. If you are in nxml-mode use the command -;; C-c C-s C-f to point to the schema in `contrib/muse.rnc', which -;; comes with Muse. Say yes if you are asked if you want to copy the -;; file to your location. C-c C-s C-a can then be used to reload the -;; schema if you make changes to the file. - -;;; Contributors: - -;; Peter K. Lee (saint AT corenova DOT com) made the initial -;; implementation of planner-publish.el, which was heavily borrowed -;; from. - -;; Brad Collins (brad AT chenla DOT org) provided a Compact RelaxNG -;; schema. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Muse XML Publishing -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'muse-publish) -(require 'muse-regexps) -(require 'muse-xml-common) - -(defgroup muse-xml nil - "Options controlling the behavior of Muse XML publishing. -See `muse-xml' for more information." - :group 'muse-publish) - -(defcustom muse-xml-extension ".xml" - "Default file extension for publishing XML files." - :type 'string - :group 'muse-xml) - -(defcustom muse-xml-header - "<?xml version=\"1.0\" encoding=\"<lisp> - (muse-xml-encoding)</lisp>\"?> -<MUSE> - <pageinfo> - <title><lisp>(muse-publishing-directive \"title\")</lisp></title> - <author><lisp>(muse-publishing-directive \"author\")</lisp></author> - <maintainer><lisp>(muse-style-element :maintainer)</lisp></maintainer> - <pubdate><lisp>(muse-publishing-directive \"date\")</lisp></pubdate> - </pageinfo> - <!-- Page published by Emacs Muse begins here -->\n" - "Header used for publishing XML files. -This may be text or a filename." - :type 'string - :group 'muse-xml) - -(defcustom muse-xml-footer " - <!-- Page published by Emacs Muse ends here --> -</MUSE>\n" - "Footer used for publishing XML files. -This may be text or a filename." - :type 'string - :group 'muse-xml) - -(defcustom muse-xml-markup-regexps - `(;; Beginning of doc, end of doc, or plain paragraph separator - (10000 ,(concat "\\(\\(\n\\(?:[" muse-regexp-blank "]*\n\\)*" - "\\([" muse-regexp-blank "]*\n\\)\\)" - "\\|\\`\\s-*\\|\\s-*\\'\\)") - ;; this is somewhat repetitive because we only require the - ;; line just before the paragraph beginning to be not - ;; read-only - 3 muse-xml-markup-paragraph)) - "List of markup rules for publishing a Muse page to XML. -For more on the structure of this list, see `muse-publish-markup-regexps'." - :type '(repeat (choice - (list :tag "Markup rule" - integer - (choice regexp symbol) - integer - (choice string function symbol)) - function)) - :group 'muse-xml) - -(defcustom muse-xml-markup-functions - '((anchor . muse-xml-markup-anchor) - (table . muse-xml-markup-table)) - "An alist of style types to custom functions for that kind of text. -For more on the structure of this list, see -`muse-publish-markup-functions'." - :type '(alist :key-type symbol :value-type function) - :group 'muse-xml) - -(defcustom muse-xml-markup-strings - '((image-with-desc . "<image href=\"%s.%s\">%s</image>") - (image . "<image href=\"%s.%s\"></image>") - (image-link . "<link type=\"image\" href=\"%s\">%s.%s</link>") - (anchor-ref . "<link type=\"url\" href=\"#%s\">%s</link>") - (url . "<link type=\"url\" href=\"%s\">%s</link>") - (link . "<link type=\"url\" href=\"%s\">%s</link>") - (link-and-anchor . "<link type=\"url\" href=\"%s#%s\">%s</link>") - (email-addr . "<link type=\"email\" href=\"%s\">%s</link>") - (anchor . "<anchor id=\"%s\" />\n") - (emdash . "%s--%s") - (comment-begin . "<!-- ") - (comment-end . " -->") - (rule . "<hr />") - (fn-sep . "<hr />\n") - (no-break-space . " ") - (line-break . "<br>") - (enddots . "....") - (dots . "...") - (section . "<section level=\"1\"><title>") - (section-end . "</title>") - (subsection . "<section level=\"2\"><title>") - (subsection-end . "</title>") - (subsubsection . "<section level=\"3\"><title>") - (subsubsection-end . "</title>") - (section-other . "<section level=\"%s\"><title>") - (section-other-end . "</title>") - (section-close . "</section>") - (footnote . "<footnote>") - (footnote-end . "</footnote>") - (begin-underline . "<format type=\"underline\">") - (end-underline . "</format>") - (begin-literal . "<code>") - (end-literal . "</code>") - (begin-emph . "<format type=\"emphasis\" level=\"1\">") - (end-emph . "</format>") - (begin-more-emph . "<format type=\"emphasis\" level=\"2\">") - (end-more-emph . "</format>") - (begin-most-emph . "<format type=\"emphasis\" level=\"3\">") - (end-most-emph . "</format>") - (begin-verse . "<verse>\n") - (begin-verse-line . "<line>") - (end-verse-line . "</line>") - (empty-verse-line . "<line />") - (begin-last-stanza-line . "<line>") - (end-last-stanza-line . "</line>") - (end-verse . "</verse>") - (begin-example . "<example>") - (end-example . "</example>") - (begin-center . "<p><format type=\"center\">\n") - (end-center . "\n</format></p>") - (begin-quote . "<blockquote>\n") - (end-quote . "\n</blockquote>") - (begin-cite . "<cite>") - (begin-cite-author . "<cite type=\"author\">") - (begin-cite-year . "<cite type=\"year\">") - (end-cite . "</cite>") - (begin-quote-item . "<p>") - (end-quote-item . "</p>") - (begin-uli . "<list type=\"unordered\">\n") - (end-uli . "\n</list>") - (begin-uli-item . "<item>") - (end-uli-item . "</item>") - (begin-oli . "<list type=\"ordered\">\n") - (end-oli . "\n</list>") - (begin-oli-item . "<item>") - (end-oli-item . "</item>") - (begin-dl . "<list type=\"definition\">\n") - (end-dl . "\n</list>") - (begin-dl-item . "<item>\n") - (end-dl-item . "\n</item>") - (begin-ddt . "<term>") - (end-ddt . "</term>") - (begin-dde . "<definition>") - (end-dde . "</definition>") - (begin-table . "<table%s>\n") - (end-table . "</table>") - (begin-table-row . " <tr>\n") - (end-table-row . " </tr>\n") - (begin-table-entry . " <%s>") - (end-table-entry . "</%s>\n")) - "Strings used for marking up text. -These cover the most basic kinds of markup, the handling of which -differs little between the various styles." - :type '(alist :key-type symbol :value-type string) - :group 'muse-xml) - -(defcustom muse-xml-encoding-default 'utf-8 - "The default Emacs buffer encoding to use in published files. -This will be used if no special characters are found." - :type 'symbol - :group 'muse-xml) - -(defcustom muse-xml-charset-default "utf-8" - "The default XML charset to use if no translation is -found in `muse-xml-encoding-map'." - :type 'string - :group 'muse-xml) - -(defun muse-xml-encoding () - (muse-xml-transform-content-type - (or (and (boundp 'buffer-file-coding-system) - buffer-file-coding-system) - muse-xml-encoding-default) - muse-xml-charset-default)) - -(defun muse-xml-markup-paragraph () - (let ((end (copy-marker (match-end 0) t))) - (goto-char (match-beginning 0)) - (when (save-excursion - (save-match-data - (and (not (get-text-property (max (point-min) (1- (point))) - 'muse-no-paragraph)) - (re-search-backward "<\\(/?\\)p[ >]" nil t) - (not (string-equal (match-string 1) "/"))))) - (when (get-text-property (1- (point)) 'muse-end-list) - (goto-char (previous-single-property-change (1- (point)) - 'muse-end-list))) - (muse-insert-markup "</p>")) - (goto-char end)) - (cond - ((eobp) - (unless (bolp) - (insert "\n"))) - ((get-text-property (point) 'muse-no-paragraph) - (forward-char 1) - nil) - ((eq (char-after) ?\<) - (when (looking-at (concat "<\\(format\\|code\\|link\\|image" - "\\|anchor\\|footnote\\)[ >]")) - (muse-insert-markup "<p>"))) - (t - (muse-insert-markup "<p>")))) - -(defun muse-xml-finalize-buffer () - (when (boundp 'buffer-file-coding-system) - (when (memq buffer-file-coding-system '(no-conversion undecided-unix)) - ;; make it agree with the default charset - (setq buffer-file-coding-system muse-xml-encoding-default)))) - -;;; Register the Muse XML Publisher - -(muse-define-style "xml" - :suffix 'muse-xml-extension - :regexps 'muse-xml-markup-regexps - :functions 'muse-xml-markup-functions - :strings 'muse-xml-markup-strings - :specials 'muse-xml-decide-specials - :after 'muse-xml-finalize-buffer - :header 'muse-xml-header - :footer 'muse-xml-footer - :browser 'find-file) - -(provide 'muse-xml) - -;;; muse-xml.el ends here diff --git a/emacs.d/elisp/muse/muse.el b/emacs.d/elisp/muse/muse.el deleted file mode 100644 index 4d4a0b9..0000000 --- a/emacs.d/elisp/muse/muse.el +++ /dev/null @@ -1,881 +0,0 @@ -;;; muse.el --- an authoring and publishing tool for Emacs - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Emacs Lisp Archive Entry -;; Filename: muse.el -;; Version: 3.20 -;; Date: Sun 31 Jan-2010 -;; Keywords: hypermedia -;; Author: John Wiegley <johnw@gnu.org> -;; Maintainer: Michael Olson <mwolson@gnu.org> -;; Description: An authoring and publishing tool for Emacs -;; URL: http://mwolson.org/projects/EmacsMuse.html -;; Compatibility: Emacs21 XEmacs21 Emacs22 - -;; This file is part of Emacs Muse. It is not part of GNU Emacs. - -;; Emacs Muse 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. - -;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Muse is a tool for easily authoring and publishing documents. It -;; allows for rapid prototyping of hyperlinked text, which may then be -;; exported to multiple output formats -- such as HTML, LaTeX, -;; Texinfo, etc. - -;; The markup rules used by Muse are intended to be very friendly to -;; people familiar with Emacs. See the included manual for more -;; information. - -;;; Contributors: - -;;; Code: - -;; Indicate that this version of Muse supports nested tags -(provide 'muse-nested-tags) - -(defvar muse-version "3.20" - "The version of Muse currently loaded") - -(defun muse-version (&optional insert) - "Display the version of Muse that is currently loaded. -If INSERT is non-nil, insert the text instead of displaying it." - (interactive "P") - (if insert - (insert muse-version) - (message muse-version))) - -(defgroup muse nil - "Options controlling the behavior of Muse. -The markup used by Muse is intended to be very friendly to people -familiar with Emacs." - :group 'hypermedia) - -(defvar muse-under-windows-p (memq system-type '(ms-dos windows-nt))) - -(provide 'muse) - -(condition-case nil - (require 'derived) - (error nil)) -(require 'wid-edit) -(require 'muse-regexps) - -(defvar muse-update-values-hook nil - "Hook for values that are automatically generated. -This is to be used by add-on modules for Muse. -It is run just before colorizing or publishing a buffer.") - -(defun muse-update-values () - "Update various values that are automatically generated. - -Call this after changing `muse-project-alist'." - (interactive) - (run-hooks 'muse-update-values-hook) - (dolist (buffer (buffer-list)) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (when (derived-mode-p 'muse-mode) - (and (boundp 'muse-current-project) - (fboundp 'muse-project-of-file) - (setq muse-current-project nil) - (setq muse-current-project (muse-project-of-file)))))))) - -;; Default file extension - -;; By default, use the .muse file extension. -;;;###autoload (add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode)) - -;; We need to have this at top-level, as well, so that any Muse or -;; Planner documents opened during init will just work. -(add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode)) - -(eval-when-compile - (defvar muse-ignored-extensions)) - -(defvar muse-ignored-extensions-regexp nil - "A regexp of extensions to omit from the ending of a Muse page name. -This is autogenerated from `muse-ignored-extensions'.") - -(defun muse-update-file-extension (sym val) - "Update the value of `muse-file-extension'." - (let ((old (and (boundp sym) (symbol-value sym)))) - (set sym val) - (when (and (featurep 'muse-mode) - (or (not (stringp val)) - (not (stringp old)) - (not (string= old val)))) - ;; remove old auto-mode-alist association - (when (and (boundp sym) (stringp old)) - (setq auto-mode-alist - (delete (cons (concat "\\." old "\\'") - 'muse-mode-choose-mode) - auto-mode-alist))) - ;; associate the new file extension with muse-mode - (when (stringp val) - (add-to-list 'auto-mode-alist - (cons (concat "\\." val "\\'") - 'muse-mode-choose-mode))) - ;; update the ignored extensions regexp - (when (fboundp 'muse-update-ignored-extensions-regexp) - (muse-update-ignored-extensions-regexp - 'muse-ignored-extensions muse-ignored-extensions))))) - -(defcustom muse-file-extension "muse" - "File extension of Muse files. Omit the period at the beginning. -If you don't want Muse files to have an extension, set this to nil." - :type '(choice - (const :tag "None" nil) - (string)) - :set 'muse-update-file-extension - :group 'muse) - -(defcustom muse-completing-read-function 'completing-read - "Function to call when prompting user to choose between a list of options. -This should take the same arguments as `completing-read'." - :type 'function - :group 'muse) - -(defun muse-update-ignored-extensions-regexp (sym val) - "Update the value of `muse-ignored-extensions-regexp'." - (set sym val) - (if val - (setq muse-ignored-extensions-regexp - (concat "\\.\\(" - (regexp-quote (or muse-file-extension "")) "\\|" - (mapconcat 'identity val "\\|") - "\\)\\'")) - (setq muse-ignored-extensions-regexp - (if muse-file-extension - (concat "\\.\\(" muse-file-extension "\\)\\'") - nil)))) - -(add-hook 'muse-update-values-hook - (lambda () - (muse-update-ignored-extensions-regexp - 'muse-ignored-extensions muse-ignored-extensions))) - -(defcustom muse-ignored-extensions '("bz2" "gz" "[Zz]") - "A list of extensions to omit from the ending of a Muse page name. -These are regexps. - -Don't put a period at the beginning of each extension unless you -understand that it is part of a regexp." - :type '(repeat (regexp :tag "Extension")) - :set 'muse-update-ignored-extensions-regexp - :group 'muse) - -(defun muse-update-file-extension-after-init () - ;; This is short, but it has to be a function, otherwise Emacs21 - ;; does not load it properly when running after-init-hook - (unless (string= muse-file-extension "muse") - (let ((val muse-file-extension) - (muse-file-extension "muse")) - (muse-update-file-extension 'muse-file-extension val)))) - -;; Once the user's init file has been processed, determine whether -;; they want a file extension -(add-hook 'after-init-hook 'muse-update-file-extension-after-init) - -;; URL protocols - -(require 'muse-protocols) - -;; Helper functions - -(defsubst muse-delete-file-if-exists (file) - (when (file-exists-p file) - (delete-file file) - (message "Removed %s" file))) - -(defsubst muse-time-less-p (t1 t2) - "Say whether time T1 is less than time T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - -(eval-when-compile - (defvar muse-publishing-current-file nil)) - -(defun muse-current-file () - "Return the name of the currently visited or published file." - (or (and (boundp 'muse-publishing-current-file) - muse-publishing-current-file) - (buffer-file-name) - (concat default-directory (buffer-name)))) - -(defun muse-page-name (&optional name) - "Return the canonical form of a Muse page name. - -What this means is that the directory part of NAME is removed, -and the file extensions in `muse-ignored-extensions' are also -removed from NAME." - (save-match-data - (unless (and name (not (string= name ""))) - (setq name (muse-current-file))) - (if name - (let ((page (file-name-nondirectory name))) - (if (and muse-ignored-extensions-regexp - (string-match muse-ignored-extensions-regexp page)) - (replace-match "" t t page) - page))))) - -(defun muse-display-warning (message) - "Display the given MESSAGE as a warning." - (if (fboundp 'display-warning) - (display-warning 'muse message - (if (featurep 'xemacs) - 'warning - :warning)) - (let ((buf (get-buffer-create "*Muse warnings*"))) - (with-current-buffer buf - (goto-char (point-max)) - (insert "Warning (muse): " message) - (unless (bolp) - (newline))) - (display-buffer buf) - (sit-for 0)))) - -(defun muse-eval-lisp (form) - "Evaluate the given form and return the result as a string." - (require 'pp) - (save-match-data - (condition-case err - (let ((object (eval (read form)))) - (cond - ((stringp object) object) - ((and (listp object) - (not (eq object nil))) - (let ((string (pp-to-string object))) - (substring string 0 (1- (length string))))) - ((numberp object) - (number-to-string object)) - ((eq object nil) "") - (t - (pp-to-string object)))) - (error - (muse-display-warning (format "%s: Error evaluating %s: %s" - (muse-page-name) form err)) - "; INVALID LISP CODE")))) - -(defmacro muse-with-temp-buffer (&rest body) - "Create a temporary buffer, and evaluate BODY there like `progn'. -See also `with-temp-file' and `with-output-to-string'. - -Unlike `with-temp-buffer', this will never attempt to save the -temp buffer. It is meant to be used along with -`insert-file-contents' or `muse-insert-file-contents'. - -The undo feature will be disabled in the new buffer. - -If `debug-on-error' is set to t, keep the buffer around for -debugging purposes rather than removing it." - (let ((temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-buffer (generate-new-buffer " *muse-temp*"))) - (buffer-disable-undo ,temp-buffer) - (unwind-protect - (if debug-on-error - (with-current-buffer ,temp-buffer - ,@body) - (condition-case err - (with-current-buffer ,temp-buffer - ,@body) - (error - (if (and (boundp 'muse-batch-publishing-p) - muse-batch-publishing-p) - (progn - (message "%s: Error occured: %s" - (muse-page-name) err) - (backtrace)) - (muse-display-warning - (format (concat "An error occurred while publishing" - " %s:\n %s\n\nSet debug-on-error to" - " `t' if you would like a backtrace.") - (muse-page-name) err)))))) - (when (buffer-live-p ,temp-buffer) - (with-current-buffer ,temp-buffer - (set-buffer-modified-p nil)) - (unless debug-on-error (kill-buffer ,temp-buffer))))))) - -(put 'muse-with-temp-buffer 'lisp-indent-function 0) -(put 'muse-with-temp-buffer 'edebug-form-spec '(body)) - -(defun muse-insert-file-contents (filename &optional visit) - "Insert the contents of file FILENAME after point. -Do character code conversion and end-of-line conversion, but none -of the other unnecessary things like format decoding or -`find-file-hook'. - -If VISIT is non-nil, the buffer's visited filename -and last save file modtime are set, and it is marked unmodified. -If visiting and the file does not exist, visiting is completed -before the error is signaled." - (let ((format-alist nil) - (after-insert-file-functions nil) - (inhibit-file-name-handlers - (append '(jka-compr-handler image-file-handler epa-file-handler) - inhibit-file-name-handlers)) - (inhibit-file-name-operation 'insert-file-contents)) - (insert-file-contents filename visit))) - -(defun muse-write-file (filename &optional nomessage) - "Write current buffer into file FILENAME. -Unlike `write-file', this does not visit the file, try to back it -up, or interact with vc.el in any way. - -If the file was not written successfully, return nil. Otherwise, -return non-nil. - -If the NOMESSAGE argument is non-nil, suppress the \"Wrote file\" -message." - (when nomessage (setq nomessage 'nomessage)) - (let ((backup-inhibited t) - (buffer-file-name filename) - (buffer-file-truename (file-truename filename))) - (save-current-buffer - (save-restriction - (widen) - (if (not (file-writable-p buffer-file-name)) - (prog1 nil - (muse-display-warning - (format "Cannot write file %s:\n %s" buffer-file-name - (let ((dir (file-name-directory buffer-file-name))) - (if (not (file-directory-p dir)) - (if (file-exists-p dir) - (format "%s is not a directory" dir) - (format "No directory named %s exists" dir)) - (if (not (file-exists-p buffer-file-name)) - (format "Directory %s write-protected" dir) - "File is write-protected")))))) - (let ((coding-system-for-write - (or (and (boundp 'save-buffer-coding-system) - save-buffer-coding-system) - coding-system-for-write))) - (write-region (point-min) (point-max) buffer-file-name - nil nomessage)) - (when (boundp 'last-file-coding-system-used) - (when (boundp 'buffer-file-coding-system-explicit) - (setq buffer-file-coding-system-explicit - last-coding-system-used)) - (if save-buffer-coding-system - (setq save-buffer-coding-system last-coding-system-used) - (setq buffer-file-coding-system last-coding-system-used))) - t))))) - -(defun muse-collect-alist (list element &optional test) - "Collect items from LIST whose car is equal to ELEMENT. -If TEST is specified, use it to compare ELEMENT." - (unless test (setq test 'equal)) - (let ((items nil)) - (dolist (item list) - (when (funcall test element (car item)) - (setq items (cons item items)))) - items)) - -(defmacro muse-sort-with-closure (list predicate closure) - "Sort LIST, stably, comparing elements using PREDICATE. -Returns the sorted list. LIST is modified by side effects. -PREDICATE is called with two elements of list and CLOSURE. -PREDICATE should return non-nil if the first element should sort -before the second." - `(sort ,list (lambda (a b) (funcall ,predicate a b ,closure)))) - -(put 'muse-sort-with-closure 'lisp-indent-function 0) -(put 'muse-sort-with-closure 'edebug-form-spec '(form function-form form)) - -(defun muse-sort-by-rating (rated-list &optional test) - "Sort RATED-LIST according to the rating of each element. -The rating is stripped out in the returned list. -Default sorting is highest-first. - -If TEST if specified, use it to sort the list. The default test is '>." - (unless test (setq test '>)) - (mapcar (function cdr) - (muse-sort-with-closure - rated-list - (lambda (a b closure) - (let ((na (numberp (car a))) - (nb (numberp (car b)))) - (cond ((and na nb) (funcall closure (car a) (car b))) - (na (not nb)) - (t nil)))) - test))) - -(defun muse-escape-specials-in-string (specials string &optional reverse) - "Apply the transformations in SPECIALS to STRING. - -The transforms should form a fully reversible and non-ambiguous -syntax when STRING is parsed from left to right. - -If REVERSE is specified, reverse an already-escaped string." - (let ((rules (mapcar (lambda (rule) - (cons (regexp-quote (if reverse - (cdr rule) - (car rule))) - (if reverse (car rule) (cdr rule)))) - specials))) - (save-match-data - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (not (eobp)) - (unless (catch 'found - (dolist (rule rules) - (when (looking-at (car rule)) - (replace-match (cdr rule) t t) - (throw 'found t)))) - (forward-char))) - (buffer-string))))) - -(defun muse-trim-whitespace (string) - "Return a version of STRING with no initial nor trailing whitespace." - (muse-replace-regexp-in-string - (concat "\\`[" muse-regexp-blank "]+\\|[" muse-regexp-blank "]+\\'") - "" string)) - -(defun muse-path-sans-extension (path) - "Return PATH sans final \"extension\". - -The extension, in a file name, is the part that follows the last `.', -except that a leading `.', if any, doesn't count. - -This differs from `file-name-sans-extension' in that it will -never modify the directory part of the path." - (concat (file-name-directory path) - (file-name-nondirectory (file-name-sans-extension path)))) - -;; The following code was extracted from cl - -(defun muse-const-expr-p (x) - (cond ((consp x) - (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) - (or (symbolp (nth 1 x)) - (and (eq (and (consp (nth 1 x)) - (car (nth 1 x))) 'lambda) 'func))))) - ((symbolp x) (and (memq x '(nil t)) t)) - (t t))) - -(put 'muse-assertion-failed 'error-conditions '(error)) -(put 'muse-assertion-failed 'error-message "Assertion failed") - -(defun muse-list* (arg &rest rest) - "Return a new list with specified args as elements, cons'd to last arg. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'." - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) - -(defmacro muse-assert (form &optional show-args string &rest args) - "Verify that FORM returns non-nil; signal an error if not. -Second arg SHOW-ARGS means to include arguments of FORM in message. -Other args STRING and ARGS... are arguments to be passed to `error'. -They are not evaluated unless the assertion fails. If STRING is -omitted, a default message listing FORM itself is used." - (let ((sargs - (and show-args - (delq nil (mapcar - (function - (lambda (x) - (and (not (muse-const-expr-p x)) x))) - (cdr form)))))) - (list 'progn - (list 'or form - (if string - (muse-list* 'error string (append sargs args)) - (list 'signal '(quote muse-assertion-failed) - (muse-list* 'list (list 'quote form) sargs)))) - nil))) - -;; Compatibility functions - -(if (fboundp 'looking-back) - (defalias 'muse-looking-back 'looking-back) - (defun muse-looking-back (regexp &optional limit &rest ignored) - (save-excursion - (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))) - -(eval-and-compile - (if (fboundp 'line-end-position) - (defalias 'muse-line-end-position 'line-end-position) - (defun muse-line-end-position (&optional n) - (save-excursion (end-of-line n) (point)))) - - (if (fboundp 'line-beginning-position) - (defalias 'muse-line-beginning-position 'line-beginning-position) - (defun muse-line-beginning-position (&optional n) - (save-excursion (beginning-of-line n) (point)))) - - (if (fboundp 'match-string-no-properties) - (defalias 'muse-match-string-no-properties 'match-string-no-properties) - (defun muse-match-string-no-properties (num &optional string) - (match-string num string)))) - -(defun muse-replace-regexp-in-string (regexp replacement text &optional fixedcase literal) - "Replace REGEXP with REPLACEMENT in TEXT. - -Return a new string containing the replacements. - -If fourth arg FIXEDCASE is non-nil, do not alter case of replacement text. -If fifth arg LITERAL is non-nil, insert REPLACEMENT literally." - (cond - ((and (featurep 'xemacs) (fboundp 'replace-in-string)) - (and (fboundp 'replace-in-string) ; stupid byte-compiler warning - (replace-in-string text regexp replacement literal))) - ((fboundp 'replace-regexp-in-string) - (replace-regexp-in-string regexp replacement text fixedcase literal)) - (t (error (concat "Neither `replace-in-string' nor " - "`replace-regexp-in-string' was found"))))) - -(if (fboundp 'add-to-invisibility-spec) - (defalias 'muse-add-to-invisibility-spec 'add-to-invisibility-spec) - (defun muse-add-to-invisibility-spec (element) - "Add ELEMENT to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (if (eq buffer-invisibility-spec t) - (setq buffer-invisibility-spec (list t))) - (setq buffer-invisibility-spec - (cons element buffer-invisibility-spec)))) - -(if (fboundp 'read-directory-name) - (defalias 'muse-read-directory-name 'read-directory-name) - (defun muse-read-directory-name (prompt &optional dir default-dirname mustmatch initial) - "Read directory name - see `read-file-name' for details." - (unless dir - (setq dir default-directory)) - (read-file-name prompt dir (or default-dirname - (if initial (expand-file-name initial dir) - dir)) - mustmatch initial))) - -(defun muse-file-remote-p (file) - "Test whether FILE specifies a location on a remote system. -Return non-nil if the location is indeed remote. - -For example, the filename \"/user@host:/foo\" specifies a location -on the system \"/user@host:\"." - (cond ((fboundp 'file-remote-p) - (file-remote-p file)) - ((fboundp 'tramp-handle-file-remote-p) - (tramp-handle-file-remote-p file)) - ((and (boundp 'ange-ftp-name-format) - (string-match (car ange-ftp-name-format) file)) - t) - (t nil))) - -(if (fboundp 'delete-and-extract-region) - (defalias 'muse-delete-and-extract-region 'delete-and-extract-region) - (defun muse-delete-and-extract-region (start end) - "Delete the text between START and END and return it." - (prog1 (buffer-substring start end) - (delete-region start end)))) - -(if (fboundp 'delete-dups) - (defalias 'muse-delete-dups 'delete-dups) - (defun muse-delete-dups (list) - "Destructively remove `equal' duplicates from LIST. -Store the result in LIST and return it. LIST must be a proper list. -Of several `equal' occurrences of an element in LIST, the first -one is kept." - (let ((tail list)) - (while tail - (setcdr tail (delete (car tail) (cdr tail))) - (setq tail (cdr tail)))) - list)) - -;; Set face globally in a predictable fashion -(defun muse-copy-face (old new) - "Copy face OLD to NEW." - (if (featurep 'xemacs) - (copy-face old new 'all) - (copy-face old new))) - -;; Widget compatibility functions - -(defun muse-widget-type-value-create (widget) - "Convert and instantiate the value of the :type attribute of WIDGET. -Store the newly created widget in the :children attribute. - -The value of the :type attribute should be an unconverted widget type." - (let ((value (widget-get widget :value)) - (type (widget-get widget :type))) - (widget-put widget :children - (list (widget-create-child-value widget - (widget-convert type) - value))))) - -(defun muse-widget-child-value-get (widget) - "Get the value of the first member of :children in WIDGET." - (widget-value (car (widget-get widget :children)))) - -(defun muse-widget-type-match (widget value) - "Non-nil if the :type value of WIDGET matches VALUE. - -The value of the :type attribute should be an unconverted widget type." - (widget-apply (widget-convert (widget-get widget :type)) :match value)) - -;; Link-handling functions and variables - -(defun muse-get-link (&optional target) - "Based on the match data, retrieve the link. -Use TARGET to get the string, if it is specified." - (muse-match-string-no-properties 1 target)) - -(defun muse-get-link-desc (&optional target) - "Based on the match data, retrieve the link description. -Use TARGET to get the string, if it is specified." - (muse-match-string-no-properties 2 target)) - -(defvar muse-link-specials - '(("[" . "%5B") - ("]" . "%5D") - ("%" . "%%")) - "Syntax used for escaping and unescaping links. -This allows brackets to occur in explicit links as long as you -use the standard Muse functions to create them.") - -(defun muse-link-escape (text) - "Escape characters in TEXT that conflict with the explicit link -regexp." - (when (stringp text) - (muse-escape-specials-in-string muse-link-specials text))) - -(defun muse-link-unescape (text) - "Un-escape characters in TEXT that conflict with the explicit -link regexp." - (when (stringp text) - (muse-escape-specials-in-string muse-link-specials text t))) - -(defun muse-handle-url (&optional string) - "If STRING or point has a URL, match and return it." - (if (if string (string-match muse-url-regexp string) - (looking-at muse-url-regexp)) - (match-string 0 string))) - -(defcustom muse-implicit-link-functions '(muse-handle-url) - "A list of functions to handle an implicit link. -An implicit link is one that is not surrounded by brackets. - -By default, Muse handles URLs only. -If you want to handle WikiWords, load muse-wiki.el." - :type 'hook - :options '(muse-handle-url) - :group 'muse) - -(defun muse-handle-implicit-link (&optional link) - "Handle implicit links. If LINK is not specified, look at point. -An implicit link is one that is not surrounded by brackets. -By default, Muse handles URLs only. -If you want to handle WikiWords, load muse-wiki.el. - -This function modifies the match data so that match 0 is the -link. - -The match data is restored after each unsuccessful handler -function call. If LINK is specified, only restore at very end. - -This behavior is needed because the part of the buffer that -`muse-implicit-link-regexp' matches must be narrowed to the part -that is an accepted link." - (let ((funcs muse-implicit-link-functions) - (res nil) - (data (match-data t))) - (while funcs - (setq res (funcall (car funcs) link)) - (if res - (setq funcs nil) - (unless link (set-match-data data)) - (setq funcs (cdr funcs)))) - (when link (set-match-data data)) - res)) - -(defcustom muse-explicit-link-functions nil - "A list of functions to handle an explicit link. -An explicit link is one [[like][this]] or [[this]]." - :type 'hook - :group 'muse) - -(defun muse-handle-explicit-link (&optional link) - "Handle explicit links. If LINK is not specified, look at point. -An explicit link is one that looks [[like][this]] or [[this]]. - -The match data is preserved. If no handlers are able to process -LINK, return LINK (if specified) or the 1st match string. If -LINK is not specified, it is assumed that Muse has matched -against `muse-explicit-link-regexp' before calling this -function." - (let ((funcs muse-explicit-link-functions) - (res nil)) - (save-match-data - (while funcs - (setq res (funcall (car funcs) link)) - (if res - (setq funcs nil) - (setq funcs (cdr funcs))))) - (muse-link-unescape - (if res - res - (or link (muse-get-link)))))) - -;; Movement functions - -(defun muse-list-item-type (str) - "Determine the type of list given STR. -Returns either 'ul, 'ol, 'dl-term, 'dl-entry, or nil." - (save-match-data - (cond ((or (string= str "") - (< (length str) 2)) - nil) - ((string-match muse-dl-entry-regexp str) - 'dl-entry) - ((string-match muse-dl-term-regexp str) - 'dl-term) - ((string-match muse-ol-item-regexp str) - 'ol) - ((string-match muse-ul-item-regexp str) - 'ul) - (t nil)))) - -(defun muse-list-item-critical-point (&optional offset) - "Figure out where the important markup character for the -currently-matched list item is. - -If OFFSET is specified, it is the number of groupings outside of -the contents of `muse-list-item-regexp'." - (unless offset (setq offset 0)) - (if (match-end (+ offset 2)) - ;; at a definition list - (match-end (+ offset 2)) - ;; at a different kind of list - (match-beginning (+ offset 1)))) - -(defun muse-forward-paragraph (&optional pattern) - "Move forward safely by one paragraph, or according to PATTERN." - (when (get-text-property (point) 'muse-end-list) - (goto-char (next-single-property-change (point) 'muse-end-list))) - (setq pattern (if pattern - (concat "^\\(?:" pattern "\\|\n\\|\\'\\)") - "^\\s-*\\(\n\\|\\'\\)")) - (let ((next-list-end (or (next-single-property-change (point) 'muse-end-list) - (point-max)))) - (forward-line 1) - (if (re-search-forward pattern nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max))) - (when (> (point) next-list-end) - (goto-char next-list-end)))) - -(defun muse-forward-list-item-1 (type empty-line indented-line) - "Determine whether a nested list item is after point." - (if (match-beginning 1) - ;; if we are given a dl entry, skip past everything on the same - ;; level, except for other dl entries - (and (eq type 'dl-entry) - (not (eq (char-after (match-beginning 2)) ?\:))) - ;; blank line encountered with no list item on the same - ;; level after it - (let ((beg (point))) - (forward-line 1) - (if (save-match-data - (and (looking-at indented-line) - (not (looking-at empty-line)))) - ;; found that this blank line is followed by some - ;; indentation, plus other text, so we'll keep - ;; going - t - (goto-char beg) - nil)))) - -(defun muse-forward-list-item (type indent &optional no-skip-nested) - "Move forward to the next item of TYPE. -Return non-nil if successful, nil otherwise. -The beginning indentation is given by INDENT. - -If NO-SKIP-NESTED is non-nil, do not skip past nested items. -Note that if you desire this behavior, you will also need to -provide a very liberal INDENT value, such as -\(concat \"[\" muse-regexp-blank \"]*\")." - (let* ((list-item (format muse-list-item-regexp indent)) - (empty-line (concat "^[" muse-regexp-blank "]*\n")) - (indented-line (concat "^" indent "[" muse-regexp-blank "]")) - (list-pattern (concat "\\(?:" empty-line "\\)?" - "\\(" list-item "\\)"))) - (while (progn - (muse-forward-paragraph list-pattern) - ;; make sure we don't go past boundary - (and (not (or (get-text-property (point) 'muse-end-list) - (>= (point) (point-max)))) - ;; move past markup that is part of another construct - (or (and (match-beginning 1) - (or (get-text-property - (muse-list-item-critical-point 1) 'muse-link) - (and (derived-mode-p 'muse-mode) - (get-text-property - (muse-list-item-critical-point 1) - 'face)))) - ;; skip nested items - (and (not no-skip-nested) - (muse-forward-list-item-1 type empty-line - indented-line)))))) - (cond ((or (get-text-property (point) 'muse-end-list) - (>= (point) (point-max))) - ;; at a list boundary, so stop - nil) - ((let ((str (when (match-beginning 2) - ;; get the entire line - (save-excursion - (goto-char (match-beginning 2)) - (buffer-substring (muse-line-beginning-position) - (muse-line-end-position)))))) - (and str (eq type (muse-list-item-type str)))) - ;; same type, so indicate that there are more items to be - ;; parsed - (goto-char (match-beginning 1))) - (t - (when (match-beginning 1) - (goto-char (match-beginning 1))) - ;; move to just before foreign list item markup - nil)))) - -(defun muse-goto-tag-end (tag nested) - "Move forward past the end of TAG. - -If NESTED is non-nil, look for other instances of this tag that -may be nested inside of this tag, and skip past them." - (if (not nested) - (search-forward (concat "</" tag ">") nil t) - (let ((nesting 1) - (tag-regexp (concat "\\(<\\(/?\\)" tag "\\([ >]\\)\\)")) - (match-found nil)) - (while (and (> nesting 0) - (setq match-found (re-search-forward tag-regexp nil t))) - ;; for the sake of font-locking code, skip matches in comments - (unless (get-text-property (match-beginning 0) 'muse-comment) - (if (string-equal (match-string 2) "/") - (and (string-equal (match-string 3) ">") - (setq nesting (1- nesting))) - (setq nesting (1+ nesting))))) - match-found))) - -;;; muse.el ends here diff --git a/emacs.d/elisp/popup.el b/emacs.d/elisp/popup.el deleted file mode 100644 index 0f14dfe..0000000 --- a/emacs.d/elisp/popup.el +++ /dev/null @@ -1,1061 +0,0 @@ -;;; popup.el --- Visual popup interface - -;; Copyright (C) 2009, 2010 Tomohiro Matsuyama - -;; Author: Tomohiro Matsuyama <tomo@cx4a.org> -;; Keywords: lisp -;; Version: 0.4 - -;; 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: - -;; - -;;; Code: - -(eval-when-compile - (require 'cl)) - - - -;; Utilities - -(defvar popup-use-optimized-column-computation t - "Use optimized column computation routine. -If there is a problem, please set it to nil.") - -;; Borrowed from anything.el -(defmacro popup-aif (test-form then-form &rest else-forms) - "Anaphoric if. Temporary variable `it' is the result of test-form." - (declare (indent 2)) - `(let ((it ,test-form)) - (if it ,then-form ,@else-forms))) - -(defun popup-x-to-string (x) - "Convert any object to string effeciently. -This is faster than prin1-to-string in many cases." - (typecase x - (string x) - (symbol (symbol-name x)) - (integer (number-to-string x)) - (float (number-to-string x)) - (t (format "%s" x)))) - -(defun popup-substring-by-width (string width) - "Return cons of substring and remaining string by `WIDTH'." - ;; Expand tabs with 4 spaces - (setq string (replace-regexp-in-string "\t" " " string)) - (loop with len = (length string) - with w = 0 - for l from 0 - for c in (append string nil) - while (<= (incf w (char-width c)) width) - finally return - (if (< l len) - (cons (substring string 0 l) (substring string l)) - (list string)))) - -(defun popup-fill-string (string &optional width max-width justify squeeze) - "Split STRING into fixed width strings and return a cons cell like -\(WIDTH . ROWS). Here, the car WIDTH indicates the actual maxim width of ROWS. - -The argument WIDTH specifies the width of filling each paragraph. WIDTH nil -means don't perform any justification and word wrap. Note that this function -doesn't add any padding characters at the end of each row. - -MAX-WIDTH, if WIDTH is nil, specifies the maximum number of columns. - -The optional fourth argument JUSTIFY specifies which kind of justification -to do: `full', `left', `right', `center', or `none' (equivalent to nil). -A value of t means handle each paragraph as specified by its text properties. - -SQUEEZE nil means leave whitespaces other than line breaks untouched." - (if (eq width 0) - (error "Can't fill string with 0 width")) - (if width - (setq max-width width)) - (with-temp-buffer - (let ((tab-width 4) - (fill-column width) - (left-margin 0) - (kinsoku-limit 1) - indent-tabs-mode - row rows) - (insert string) - (untabify (point-min) (point-max)) - (if width - (fill-region (point-min) (point-max) justify (not squeeze))) - (goto-char (point-min)) - (setq width 0) - (while (prog2 - (let ((line (buffer-substring - (point) (progn (end-of-line) (point))))) - (if max-width - (while (progn - (setq row (truncate-string-to-width line max-width) - width (max width (string-width row))) - (push row rows) - (if (not (= (length row) (length line))) - (setq line (substring line (length row)))))) - (setq width (max width (string-width line))) - (push line rows))) - (< (point) (point-max)) - (beginning-of-line 2))) - (cons width (nreverse rows))))) - -(defmacro popup-save-buffer-state (&rest body) - (declare (indent 0)) - `(save-excursion - (let ((buffer-undo-list t) - (buffer-read-only nil) - (modified (buffer-modified-p))) - (unwind-protect - (progn ,@body) - (set-buffer-modified-p modified))))) - -(defun popup-preferred-width (list) - "Return preferred width of popup to show `LIST' beautifully." - (loop with tab-width = 4 - for item in list - for summary = (popup-item-summary item) - maximize (string-width (popup-x-to-string item)) into width - if (stringp summary) - maximize (+ (string-width summary) 2) into summary-width - finally return (* (ceiling (/ (+ (or width 0) (or summary-width 0)) 10.0)) 10))) - -;; window-full-width-p is not defined in Emacs 22.1 -(defun popup-window-full-width-p (&optional window) - (if (fboundp 'window-full-width-p) - (window-full-width-p window) - (= (window-width window) (frame-width (window-frame (or window (selected-window))))))) - -;; truncated-partial-width-window-p is not defined in Emacs 22 -(defun popup-truncated-partial-width-window-p (&optional window) - (unless window - (setq window (selected-window))) - (unless (popup-window-full-width-p window) - (let ((t-p-w-w (buffer-local-value 'truncate-partial-width-windows - (window-buffer window)))) - (if (integerp t-p-w-w) - (< (window-width window) t-p-w-w) - t-p-w-w)))) - -(defun popup-current-physical-column () - (or (when (and popup-use-optimized-column-computation - (eq (window-hscroll) 0)) - (let ((current-column (current-column))) - (if (or (popup-truncated-partial-width-window-p) - truncate-lines - (< current-column (window-width))) - current-column))) - (car (posn-col-row (posn-at-point))))) - -(defun popup-last-line-of-buffer-p () - (save-excursion (end-of-line) (/= (forward-line) 0))) - -(defun popup-lookup-key-by-event (function event) - (or (funcall function (vector event)) - (if (symbolp event) - (popup-aif (get event 'event-symbol-element-mask) - (funcall function (vector (logior (or (get (car it) 'ascii-character) 0) - (cadr it)))))))) - - - -;; Popup common - -(defgroup popup nil - "Visual popup interface" - :group 'lisp - :prefix "popup-") - -(defface popup-face - '((t (:background "lightgray" :foreground "black"))) - "Face for popup." - :group 'popup) - -(defface popup-scroll-bar-foreground-face - '((t (:background "black"))) - "Foreground face for scroll-bar." - :group 'popup) - -(defface popup-scroll-bar-background-face - '((t (:background "gray"))) - "Background face for scroll-bar." - :group 'popup) - -(defvar popup-instances nil - "Popup instances.") - -(defvar popup-scroll-bar-foreground-char - (propertize " " 'face 'popup-scroll-bar-foreground-face) - "Foreground character for scroll-bar.") - -(defvar popup-scroll-bar-background-char - (propertize " " 'face 'popup-scroll-bar-background-face) - "Background character for scroll-bar.") - -(defstruct popup - point row column width height min-height direction overlays - parent depth - face selection-face - margin-left margin-right margin-left-cancel scroll-bar symbol - cursor offset scroll-top current-height list newlines - pattern original-list) - -(defun popup-item-propertize (item &rest properties) - "Same to `propertize` but this avoids overriding existed value with `nil` property." - (let (props) - (while properties - (when (cadr properties) - (push (car properties) props) - (push (cadr properties) props)) - (setq properties (cddr properties))) - (apply 'propertize - (popup-x-to-string item) - (nreverse props)))) - -(defun popup-item-property (item property) - (if (stringp item) - (get-text-property 0 property item))) - -(defun* popup-make-item (name - &key - value - popup-face - selection-face - sublist - document - symbol - summary) - "Utility function to make popup item. -See also `popup-item-propertize'." - (popup-item-propertize name - 'value value - 'popup-face popup-face - 'selection-face selection-face - 'document document - 'symbol symbol - 'summary summary - 'sublist sublist)) - -(defsubst popup-item-value (item) (popup-item-property item 'value)) -(defsubst popup-item-value-or-self (item) (or (popup-item-value item) item)) -(defsubst popup-item-popup-face (item) (popup-item-property item 'popup-face)) -(defsubst popup-item-selection-face (item) (popup-item-property item 'selection-face)) -(defsubst popup-item-document (item) (popup-item-property item 'document)) -(defsubst popup-item-summary (item) (popup-item-property item 'summary)) -(defsubst popup-item-symbol (item) (popup-item-property item 'symbol)) -(defsubst popup-item-sublist (item) (popup-item-property item 'sublist)) - -(defun popup-item-documentation (item) - (let ((doc (popup-item-document item))) - (if (functionp doc) - (setq doc (funcall doc (popup-item-value-or-self item)))) - doc)) - -(defun popup-item-show-help-1 (item) - (let ((doc (popup-item-documentation item))) - (when doc - (with-current-buffer (get-buffer-create " *Popup Help*") - (erase-buffer) - (insert doc) - (goto-char (point-min)) - (display-buffer (current-buffer))) - t))) - -(defun popup-item-show-help (item &optional persist) - (when item - (if (not persist) - (save-window-excursion - (when (popup-item-show-help-1 item) - (block nil - (while t - (clear-this-command-keys) - (let ((key (read-key-sequence-vector nil))) - (case (key-binding key) - ('scroll-other-window - (scroll-other-window)) - ('scroll-other-window-down - (scroll-other-window-down nil)) - (t - (setq unread-command-events (append key unread-command-events)) - (return)))))))) - (popup-item-show-help-1 item)))) - -(defun popup-set-list (popup list) - (popup-set-filtered-list popup list) - (setf (popup-pattern popup) nil) - (setf (popup-original-list popup) list)) - -(defun popup-set-filtered-list (popup list) - (setf (popup-list popup) list - (popup-offset popup) (if (> (popup-direction popup) 0) - 0 - (max (- (popup-height popup) (length list)) 0)))) - -(defun popup-selected-item (popup) - (nth (popup-cursor popup) (popup-list popup))) - -(defun popup-selected-line (popup) - (- (popup-cursor popup) (popup-scroll-top popup))) - -(defun popup-line-overlay (popup line) - (aref (popup-overlays popup) line)) - -(defun popup-selected-line-overlay (popup) - (popup-line-overlay popup (popup-selected-line popup))) - -(defun popup-hide-line (popup line) - (let ((overlay (popup-line-overlay popup line))) - (overlay-put overlay 'display nil) - (overlay-put overlay 'after-string nil))) - -(defun popup-line-hidden-p (popup line) - (let ((overlay (popup-line-overlay popup line))) - (and (eq (overlay-get overlay 'display) nil) - (eq (overlay-get overlay 'after-string) nil)))) - -(defun popup-set-line-item (popup line item face margin-left margin-right scroll-bar-char symbol summary) - (let* ((overlay (popup-line-overlay popup line)) - (content (popup-create-line-string popup (popup-x-to-string item) margin-left margin-right symbol summary)) - (start 0) - (prefix (overlay-get overlay 'prefix)) - (postfix (overlay-get overlay 'postfix)) - end) - ;; Overlap face properties - (if (get-text-property start 'face content) - (setq start (next-single-property-change start 'face content))) - (while (and start (setq end (next-single-property-change start 'face content))) - (put-text-property start end 'face face content) - (setq start (next-single-property-change end 'face content))) - (if start - (put-text-property start (length content) 'face face content)) - (unless (overlay-get overlay 'dangle) - (overlay-put overlay 'display (concat prefix (substring content 0 1))) - (setq prefix nil - content (concat (substring content 1)))) - (overlay-put overlay - 'after-string - (concat prefix - content - scroll-bar-char - postfix)))) - -(defun popup-create-line-string (popup string margin-left margin-right symbol summary) - (let* ((popup-width (popup-width popup)) - (summary-width (string-width summary)) - (string (car (popup-substring-by-width string - (- popup-width - (if (> summary-width 0) - (+ summary-width 2) - 0))))) - (string-width (string-width string))) - (concat margin-left - string - (make-string (max (- popup-width string-width summary-width) 0) ? ) - summary - symbol - margin-right))) - -(defun popup-live-p (popup) - (and popup (popup-overlays popup) t)) - -(defun popup-child-point (popup &optional offset) - (overlay-end (popup-line-overlay popup - (or offset - (popup-selected-line popup))))) - -(defun* popup-create (point - width - height - &key - min-height - around - (face 'popup-face) - (selection-face face) - scroll-bar - margin-left - margin-right - symbol - parent - parent-offset) - (or margin-left (setq margin-left 0)) - (or margin-right (setq margin-right 0)) - (unless point - (setq point - (if parent (popup-child-point parent parent-offset) (point)))) - - (save-excursion - (goto-char point) - (let* ((row (line-number-at-pos)) - (column (popup-current-physical-column)) - (overlays (make-vector height nil)) - (popup-width (+ width - (if scroll-bar 1 0) - margin-left - margin-right - (if symbol 2 0))) - margin-left-cancel - (window (selected-window)) - (window-start (window-start)) - (window-hscroll (window-hscroll)) - (window-width (window-width)) - (right (+ column popup-width)) - (overflow (and (> right window-width) - (>= right popup-width))) - (foldable (and (null parent) - (>= column popup-width))) - (direction (or - ;; Currently the direction of cascade popup won't be changed - (and parent (popup-direction parent)) - - ;; Calculate direction - (if (and (> row height) - (> height (- (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0))) - (count-lines window-start (point))))) - -1 - 1))) - (depth (if parent (1+ (popup-depth parent)) 0)) - (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0)))) - current-column) - (when (> newlines 0) - (popup-save-buffer-state - (goto-char (point-max)) - (insert (make-string newlines ?\n)))) - - (if overflow - (if foldable - (progn - (decf column (- popup-width margin-left margin-right)) - (unless around (move-to-column column))) - (when (not truncate-lines) - ;; Cut out overflow - (let ((d (1+ (- popup-width (- window-width column))))) - (decf popup-width d) - (decf width d))) - (decf column margin-left)) - (decf column margin-left)) - (when (and (null parent) - (< column 0)) - ;; Cancel margin left - (setq column 0) - (decf popup-width margin-left) - (setq margin-left-cancel t)) - - (dotimes (i height) - (let (overlay begin w (dangle t) (prefix "") (postfix "")) - (when around - (if (>= emacs-major-version 23) - (vertical-motion (cons column direction)) - (vertical-motion direction) - (move-to-column (+ (current-column) column)))) - (setq around t - current-column (popup-current-physical-column)) - - (when (> current-column column) - (backward-char) - (setq current-column (popup-current-physical-column))) - (when (< current-column column) - ;; Extend short buffer lines by popup prefix (line of spaces) - (setq prefix (make-string (+ (if (= current-column 0) - (- window-hscroll (current-column)) - 0) - (- column current-column)) - ? ))) - - (setq begin (point)) - (setq w (+ popup-width (length prefix))) - (while (and (not (eolp)) (> w 0)) - (setq dangle nil) - (decf w (char-width (char-after))) - (forward-char)) - (if (< w 0) - (setq postfix (make-string (- w) ? ))) - - (setq overlay (make-overlay begin (point))) - (overlay-put overlay 'window window) - (overlay-put overlay 'dangle dangle) - (overlay-put overlay 'prefix prefix) - (overlay-put overlay 'postfix postfix) - (overlay-put overlay 'width width) - (aset overlays - (if (> direction 0) i (- height i 1)) - overlay))) - (loop for p from (- 10000 (* depth 1000)) - for overlay in (nreverse (append overlays nil)) - do (overlay-put overlay 'priority p)) - (let ((it (make-popup :point point - :row row - :column column - :width width - :height height - :min-height min-height - :direction direction - :parent parent - :depth depth - :face face - :selection-face selection-face - :margin-left margin-left - :margin-right margin-right - :margin-left-cancel margin-left-cancel - :scroll-bar scroll-bar - :symbol symbol - :cursor 0 - :scroll-top 0 - :current-height 0 - :list nil - :newlines newlines - :overlays overlays))) - (push it popup-instances) - it)))) - -(defun popup-delete (popup) - (when (popup-live-p popup) - (popup-hide popup) - (mapc 'delete-overlay (popup-overlays popup)) - (setf (popup-overlays popup) nil) - (setq popup-instances (delq popup popup-instances)) - (let ((newlines (popup-newlines popup))) - (when (> newlines 0) - (popup-save-buffer-state - (goto-char (point-max)) - (dotimes (i newlines) - (if (= (char-before) ?\n) - (delete-char -1))))))) - nil) - -(defun popup-draw (popup) - (loop with height = (popup-height popup) - with min-height = (popup-min-height popup) - with popup-face = (popup-face popup) - with selection-face = (popup-selection-face popup) - with list = (popup-list popup) - with length = (length list) - with thum-size = (max (/ (* height height) (max length 1)) 1) - with page-size = (/ (+ 0.0 (max length 1)) height) - with scroll-bar = (popup-scroll-bar popup) - with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? ) - with margin-right = (make-string (popup-margin-right popup) ? ) - with symbol = (popup-symbol popup) - with cursor = (popup-cursor popup) - with scroll-top = (popup-scroll-top popup) - with offset = (popup-offset popup) - for o from offset - for i from scroll-top - while (< o height) - for item in (nthcdr scroll-top list) - for page-index = (* thum-size (/ o thum-size)) - for face = (if (= i cursor) - (or (popup-item-selection-face item) selection-face) - (or (popup-item-popup-face item) popup-face)) - for empty-char = (propertize " " 'face face) - for scroll-bar-char = (if scroll-bar - (cond - ((<= page-size 1) - empty-char) - ((and (> page-size 1) - (>= cursor (* page-index page-size)) - (< cursor (* (+ page-index thum-size) page-size))) - popup-scroll-bar-foreground-char) - (t - popup-scroll-bar-background-char)) - "") - for sym = (if symbol - (concat " " (or (popup-item-symbol item) " ")) - "") - for summary = (or (popup-item-summary item) "") - - do - ;; Show line and set item to the line - (popup-set-line-item popup o item face margin-left margin-right scroll-bar-char sym summary) - - finally - ;; Remember current height - (setf (popup-current-height popup) (- o offset)) - - ;; Hide remaining lines - (let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) "")) - (symbol (if symbol " " ""))) - (if (> (popup-direction popup) 0) - (progn - (when min-height - (while (< o min-height) - (popup-set-line-item popup o "" popup-face margin-left margin-right scroll-bar-char symbol "") - (incf o))) - (while (< o height) - (popup-hide-line popup o) - (incf o))) - (loop with h = (if min-height (- height min-height) offset) - for o from 0 below offset - if (< o h) - do (popup-hide-line popup o) - if (>= o h) - do (popup-set-line-item popup o "" popup-face margin-left margin-right scroll-bar-char symbol "")))))) - -(defun popup-hide (popup) - (dotimes (i (popup-height popup)) - (popup-hide-line popup i))) - -(defun popup-hidden-p (popup) - (let ((hidden t)) - (when (popup-live-p popup) - (dotimes (i (popup-height popup)) - (unless (popup-line-hidden-p popup i) - (setq hidden nil)))) - hidden)) - -(defun popup-select (popup i) - (setq i (+ i (popup-offset popup))) - (when (and (<= 0 i) (< i (popup-height popup))) - (setf (popup-cursor popup) i) - (popup-draw popup) - t)) - -(defun popup-next (popup) - (let ((height (popup-height popup)) - (cursor (1+ (popup-cursor popup))) - (scroll-top (popup-scroll-top popup)) - (length (length (popup-list popup)))) - (cond - ((>= cursor length) - ;; Back to first page - (setq cursor 0 - scroll-top 0)) - ((= cursor (+ scroll-top height)) - ;; Go to next page - (setq scroll-top (min (1+ scroll-top) (max (- length height) 0))))) - (setf (popup-cursor popup) cursor - (popup-scroll-top popup) scroll-top) - (popup-draw popup))) - -(defun popup-previous (popup) - (let ((height (popup-height popup)) - (cursor (1- (popup-cursor popup))) - (scroll-top (popup-scroll-top popup)) - (length (length (popup-list popup)))) - (cond - ((< cursor 0) - ;; Go to last page - (setq cursor (1- length) - scroll-top (max (- length height) 0))) - ((= cursor (1- scroll-top)) - ;; Go to previous page - (decf scroll-top))) - (setf (popup-cursor popup) cursor - (popup-scroll-top popup) scroll-top) - (popup-draw popup))) - -(defun popup-scroll-down (popup &optional n) - (let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1)) - (- (length (popup-list popup)) (popup-height popup))))) - (setf (popup-cursor popup) scroll-top - (popup-scroll-top popup) scroll-top) - (popup-draw popup))) - -(defun popup-scroll-up (popup &optional n) - (let ((scroll-top (max (- (popup-scroll-top popup) (or n 1)) - 0))) - (setf (popup-cursor popup) scroll-top - (popup-scroll-top popup) scroll-top) - (popup-draw popup))) - - - -;; Popup isearch - -(defface popup-isearch-match - '((t (:background "sky blue"))) - "Popup isearch match face." - :group 'popup) - -(defvar popup-isearch-cursor-color "blue") - -(defvar popup-isearch-keymap - (let ((map (make-sparse-keymap))) - ;(define-key map "\r" 'popup-isearch-done) - (define-key map "\C-g" 'popup-isearch-cancel) - (define-key map "\C-h" 'popup-isearch-delete) - (define-key map (kbd "DEL") 'popup-isearch-delete) - map)) - -(defsubst popup-isearch-char-p (char) - (and (integerp char) - (<= 32 char) - (<= char 126))) - -(defun popup-isearch-filter-list (pattern list) - (loop with regexp = (regexp-quote pattern) - for item in list - do - (unless (stringp item) - (setq item (popup-item-propertize (popup-x-to-string item) - 'value item))) - if (string-match regexp item) - collect (let ((beg (match-beginning 0)) - (end (match-end 0))) - (alter-text-property 0 (length item) 'face - (lambda (prop) - (unless (eq prop 'popup-isearch-match) - prop)) - item) - (put-text-property beg end - 'face 'popup-isearch-match - item) - item))) - -(defun popup-isearch-prompt (popup pattern) - (format "Pattern: %s" (if (= (length (popup-list popup)) 0) - (propertize pattern 'face 'isearch-fail) - pattern))) - -(defun popup-isearch-update (popup pattern &optional callback) - (setf (popup-cursor popup) 0 - (popup-scroll-top popup) 0 - (popup-pattern popup) pattern) - (let ((list (popup-isearch-filter-list pattern (popup-original-list popup)))) - (popup-set-filtered-list popup list) - (if callback - (funcall callback list))) - (popup-draw popup)) - -(defun* popup-isearch (popup - &key - (cursor-color popup-isearch-cursor-color) - (keymap popup-isearch-keymap) - callback - help-delay) - (let ((list (popup-original-list popup)) - (pattern (or (popup-pattern popup) "")) - (old-cursor-color (frame-parameter (selected-frame) 'cursor-color)) - prompt key binding done) - (unwind-protect - (unless (block nil - (if cursor-color - (set-cursor-color cursor-color)) - (while t - (setq prompt (popup-isearch-prompt popup pattern)) - (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) - (if (null key) - (unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt) - (clear-this-command-keys) - (push (read-event prompt) unread-command-events)) - (setq binding (lookup-key keymap key)) - (cond - ((and (stringp key) - (popup-isearch-char-p (aref key 0))) - (setq pattern (concat pattern key))) - ((eq binding 'popup-isearch-done) - (return t)) - ((eq binding 'popup-isearch-cancel) - (return nil)) - ((eq binding 'popup-isearch-delete) - (if (> (length pattern) 0) - (setq pattern (substring pattern 0 (1- (length pattern)))))) - (t - (setq unread-command-events - (append (listify-key-sequence key) unread-command-events)) - (return t))) - (popup-isearch-update popup pattern callback)))) - (popup-isearch-update popup "" callback) - t) ; Return non-nil if isearch is cancelled - (if old-cursor-color - (set-cursor-color old-cursor-color))))) - - - -;; Popup tip - -(defface popup-tip-face - '((t (:background "khaki1" :foreground "black"))) - "Face for popup tip." - :group 'popup) - -(defvar popup-tip-max-width 80) - -(defun* popup-tip (string - &key - point - (around t) - width - (height 15) - min-height - truncate - margin - margin-left - margin-right - scroll-bar - parent - parent-offset - nowait - prompt - &aux tip lines) - (if (bufferp string) - (setq string (with-current-buffer string (buffer-string)))) - ;; TODO strip text (mainly face) properties - (setq string (substring-no-properties string)) - - (and (eq margin t) (setq margin 1)) - (or margin-left (setq margin-left margin)) - (or margin-right (setq margin-right margin)) - - (let ((it (popup-fill-string string width popup-tip-max-width))) - (setq width (car it) - lines (cdr it))) - - (setq tip (popup-create point width height - :min-height min-height - :around around - :margin-left margin-left - :margin-right margin-right - :scroll-bar scroll-bar - :face 'popup-tip-face - :parent parent - :parent-offset parent-offset)) - - (unwind-protect - (when (> (popup-width tip) 0) ; not to be corrupted - (when (and (not (eq width (popup-width tip))) ; truncated - (not truncate)) - ;; Refill once again to lines be fitted to popup width - (setq width (popup-width tip)) - (setq lines (cdr (popup-fill-string string width width)))) - - (popup-set-list tip lines) - (popup-draw tip) - (if nowait - tip - (clear-this-command-keys) - (push (read-event prompt) unread-command-events) - t)) - (unless nowait - (popup-delete tip)))) - - - -;; Popup menu - -(defface popup-menu-face - '((t (:background "lightgray" :foreground "black"))) - "Face for popup menu." - :group 'popup) - -(defface popup-menu-selection-face - '((t (:background "steelblue" :foreground "white"))) - "Face for popup menu selection." - :group 'popup) - -(defvar popup-menu-show-tip-function 'popup-tip - "Function used for showing tooltip by `popup-menu-show-quick-help'.") - -(defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help - "Function used for showing quick help by `popup-menu*'.") - -(defun popup-menu-show-help (menu &optional persist item) - (popup-item-show-help (or item (popup-selected-item menu)) persist)) - -(defun popup-menu-documentation (menu &optional item) - (popup-item-documentation (or item (popup-selected-item menu)))) - -(defun popup-menu-show-quick-help (menu &optional item &rest args) - (let* ((point (plist-get args :point)) - (height (or (plist-get args :height) (popup-height menu))) - (min-height (min height (popup-current-height menu))) - (around nil) - (parent-offset (popup-offset menu)) - (doc (popup-menu-documentation menu item))) - (when (stringp doc) - (if (popup-hidden-p menu) - (setq around t - menu nil - parent-offset nil) - (setq point nil)) - (let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning - (apply popup-menu-show-tip-function - doc - :point point - :height height - :min-height min-height - :around around - :parent menu - :parent-offset parent-offset - args))))) - -(defun popup-menu-read-key-sequence (keymap &optional prompt timeout) - (catch 'timeout - (let ((timer (and timeout - (run-with-timer timeout nil - (lambda () - (if (zerop (length (this-command-keys))) - (throw 'timeout nil)))))) - (old-global-map (current-global-map)) - (temp-global-map (make-sparse-keymap)) - (overriding-terminal-local-map (make-sparse-keymap))) - (substitute-key-definition 'keyboard-quit 'keyboard-quit - temp-global-map old-global-map) - (define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar])) - (define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar])) - (set-keymap-parent overriding-terminal-local-map keymap) - (if (current-local-map) - (define-key overriding-terminal-local-map [menu-bar] - (lookup-key (current-local-map) [menu-bar]))) - (unwind-protect - (progn - (use-global-map temp-global-map) - (clear-this-command-keys) - (with-temp-message prompt - (read-key-sequence nil))) - (use-global-map old-global-map) - (if timer (cancel-timer timer)))))) - -(defun popup-menu-fallback (event default)) - -(defun* popup-menu-event-loop (menu keymap fallback &optional prompt help-delay isearch isearch-cursor-color isearch-keymap isearch-callback &aux key binding) - (block nil - (while (popup-live-p menu) - (and isearch - (popup-isearch menu - :cursor-color isearch-cursor-color - :keymap isearch-keymap - :callback isearch-callback - :help-delay help-delay) - (keyboard-quit)) - (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) - (if (null key) - (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt) - (clear-this-command-keys) - (push (read-event prompt) unread-command-events)) - (if (eq (lookup-key (current-global-map) key) 'keyboard-quit) - (keyboard-quit)) - (setq binding (lookup-key keymap key)) - (cond - ((eq binding 'popup-close) - (if (popup-parent menu) - (return))) - ((memq binding '(popup-select popup-open)) - (let* ((item (popup-selected-item menu)) - (sublist (popup-item-sublist item))) - (if sublist - (popup-aif (popup-cascade-menu sublist - :around nil - :parent menu - :margin-left (popup-margin-left menu) - :margin-right (popup-margin-right menu) - :scroll-bar (popup-scroll-bar menu)) - (and it (return it))) - (if (eq binding 'popup-select) - (return (popup-item-value-or-self item)))))) - ((eq binding 'popup-next) - (popup-next menu)) - ((eq binding 'popup-previous) - (popup-previous menu)) - ((eq binding 'popup-help) - (popup-menu-show-help menu)) - ((eq binding 'popup-isearch) - (popup-isearch menu - :cursor-color isearch-cursor-color - :keymap isearch-keymap - :callback isearch-callback - :help-delay help-delay)) - ((commandp binding) - (call-interactively binding)) - (t - (funcall fallback key (key-binding key)))))))) - -;; popup-menu is used by mouse.el unfairly... -(defun* popup-menu* (list - &key - point - (around t) - (width (popup-preferred-width list)) - (height 15) - margin - margin-left - margin-right - scroll-bar - symbol - parent - parent-offset - (keymap popup-menu-keymap) - (fallback 'popup-menu-fallback) - help-delay - prompt - isearch - (isearch-cursor-color popup-isearch-cursor-color) - (isearch-keymap popup-isearch-keymap) - isearch-callback - &aux menu event) - (and (eq margin t) (setq margin 1)) - (or margin-left (setq margin-left margin)) - (or margin-right (setq margin-right margin)) - (if (and scroll-bar - (integerp margin-right) - (> margin-right 0)) - ;; Make scroll-bar space as margin-right - (decf margin-right)) - (setq menu (popup-create point width height - :around around - :face 'popup-menu-face - :selection-face 'popup-menu-selection-face - :margin-left margin-left - :margin-right margin-right - :scroll-bar scroll-bar - :symbol symbol - :parent parent)) - (unwind-protect - (progn - (popup-set-list menu list) - (popup-draw menu) - (popup-menu-event-loop menu keymap fallback prompt help-delay isearch - isearch-cursor-color isearch-keymap isearch-callback)) - (popup-delete menu))) - -(defun popup-cascade-menu (list &rest args) - "Same to `popup-menu', but an element of `LIST' can be -list of submenu." - (apply 'popup-menu* - (mapcar (lambda (item) - (if (consp item) - (popup-make-item (car item) - :sublist (cdr item) - :symbol ">") - item)) - list) - :symbol t - args)) - -(defvar popup-menu-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'popup-select) - (define-key map "\C-f" 'popup-open) - (define-key map [right] 'popup-open) - (define-key map "\C-b" 'popup-close) - (define-key map [left] 'popup-close) - - (define-key map "\C-n" 'popup-next) - (define-key map [down] 'popup-next) - (define-key map "\C-p" 'popup-previous) - (define-key map [up] 'popup-previous) - - (define-key map [f1] 'popup-help) - (define-key map (kbd "\C-?") 'popup-help) - - (define-key map "\C-s" 'popup-isearch) - map)) - -(provide 'popup) -;;; popup.el ends here diff --git a/emacs.d/elisp/tabbar.el b/emacs.d/elisp/tabbar.el deleted file mode 100644 index 09db712..0000000 --- a/emacs.d/elisp/tabbar.el +++ /dev/null @@ -1,1932 +0,0 @@ -;;; Tabbar.el --- Display a tab bar in the header line - -;; Copyright (C) 2003, 2004, 2005 David Ponce - -;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> -;; Created: 25 February 2003 -;; Keywords: convenience -;; Revision: $Id: tabbar.el,v 1.69 2006/06/08 08:27:39 ponced Exp $ - -(defconst tabbar-version "2.0") - -;; This file is not part of GNU Emacs. - -;; 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, 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; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. - -;;; Commentary: -;; -;; This library provides the Tabbar global minor mode to display a tab -;; bar in the header line of Emacs 21 and later versions. You can use -;; the mouse to click on a tab and select it. Also, three buttons are -;; displayed on the left side of the tab bar in this order: the -;; "home", "scroll left", and "scroll right" buttons. The "home" -;; button is a general purpose button used to change something on the -;; tab bar. The scroll left and scroll right buttons are used to -;; scroll tabs horizontally. Tabs can be divided up into groups to -;; maintain several sets of tabs at the same time (see also the -;; chapter "Core" below for more details on tab grouping). Only one -;; group is displayed on the tab bar, and the "home" button, for -;; example, can be used to navigate through the different groups, to -;; show different tab bars. -;; -;; In a graphic environment, using the mouse is probably the preferred -;; way to work with the tab bar. However, you can also use the tab -;; bar when Emacs is running on a terminal, so it is possible to use -;; commands to press special buttons, or to navigate cyclically -;; through tabs. -;; -;; These commands, and default keyboard shortcuts, are provided: -;; -;; `tabbar-mode' -;; Toggle the Tabbar global minor mode. When enabled a tab bar is -;; displayed in the header line. -;; -;; `tabbar-local-mode' (C-c <C-f10>) -;; Toggle the Tabbar-Local minor mode. Provided the global minor -;; mode is turned on, the tab bar becomes local in the current -;; buffer when the local minor mode is enabled. This permits to -;; see the tab bar in a buffer where the header line is already -;; used by another mode (like `Info-mode' for example). -;; -;; `tabbar-mwheel-mode' -;; Toggle the Tabbar-Mwheel global minor mode. When enabled you -;; can use the mouse wheel to navigate through tabs of groups. -;; -;; `tabbar-press-home' (C-c <C-home>) -;; `tabbar-press-scroll-left' (C-c <C-prior>) -;; `tabbar-press-scroll-right' (C-c <C-next>) -;; Simulate a mouse-1 click on respectively the "home", "scroll -;; left", and "scroll right" buttons. A numeric prefix argument -;; value of 2, or 3, respectively simulates a mouse-2, or mouse-3 -;; click. -;; -;; `tabbar-backward' (C-c <C-left>) -;; `tabbar-forward' (C-c <C-right>) -;; Are the basic commands to navigate cyclically through tabs or -;; groups of tabs. The cycle is controlled by the -;; `tabbar-cycle-scope' option. The default is to navigate -;; through all tabs across all existing groups of tabs. You can -;; change the default behavior to navigate only through the tabs -;; visible on the tab bar, or through groups of tabs only. Or use -;; the more specialized commands below. -;; -;; `tabbar-backward-tab' -;; `tabbar-forward-tab' -;; Navigate through the tabs visible on the tab bar. -;; -;; `tabbar-backward-group' (C-c <C-up>) -;; `tabbar-forward-group' (C-c <C-down>) -;; Navigate through existing groups of tabs. -;; -;; -;; Core -;; ---- -;; -;; The content of the tab bar is represented by an internal data -;; structure: a tab set. A tab set is a collection (group) of tabs, -;; identified by an unique name. In a tab set, at any time, one and -;; only one tab is designated as selected within the tab set. -;; -;; A tab is a simple data structure giving the value of the tab, and a -;; reference to its tab set container. A tab value can be any Lisp -;; object. Each tab object is guaranteed to be unique. -;; -;; A tab set is displayed on the tab bar through a "view" defined by -;; the index of the leftmost tab shown. Thus, it is possible to -;; scroll the tab bar horizontally by changing the start index of the -;; tab set view. -;; -;; The visual representation of a tab bar is a list of valid -;; `header-line-format' template elements, one for each special -;; button, and for each tab found into a tab set "view". When the -;; visual representation of a tab is required, the function specified -;; in the variable `tabbar-tab-label-function' is called to obtain it. -;; The visual representation of a special button is obtained by -;; calling the function specified in `tabbar-button-label-function', -;; which is passed a button name among `home', `scroll-left', or -;; `scroll-right'. There are also options and faces to customize the -;; appearance of buttons and tabs (see the code for more details). -;; -;; When the mouse is over a tab, the function specified in -;; `tabbar-help-on-tab-function' is called, which is passed the tab -;; and should return a help string to display. When a tab is -;; selected, the function specified in `tabbar-select-tab-function' is -;; called, which is passed the tab and the event received. -;; -;; Similarly, to control the behavior of the special buttons, the -;; following variables are available, for respectively the `home', -;; `scroll-left' and `scroll-right' value of `<button>': -;; -;; `tabbar-<button>-function' -;; Function called when <button> is selected. The function is -;; passed the mouse event received. -;; -;; `tabbar-<button>-help-function' -;; Function called with no arguments to obtain a help string -;; displayed when the mouse is over <button>. -;; -;; To increase performance, each tab set automatically maintains its -;; visual representation in a cache. As far as possible, the cache is -;; used to display the tab set, and refreshed only when necessary. -;; -;; Several tab sets can be maintained at the same time. Only one is -;; displayed on the tab bar, it is obtained by calling the function -;; specified in the variable `tabbar-current-tabset-function'. -;; -;; A special tab set is maintained, that contains the list of the -;; currently selected tabs in the existing tab sets. This tab set is -;; useful to show the existing tab sets in a tab bar, and switch -;; between them easily. The function `tabbar-get-tabsets-tabset' -;; returns this special tab set. -;; -;; -;; Buffer tabs -;; ----------- -;; -;; The default tab bar implementation provided displays buffers in -;; dedicated tabs. Selecting a tab, switch (mouse-1), or pop -;; (mouse-2), to the buffer it contains. -;; -;; The list of buffers put in tabs is provided by the function -;; specified in the variable `tabbar-buffer-list-function'. The -;; default function: `tabbar-buffer-list', excludes buffers whose name -;; starts with a space, when they are not visiting a file. -;; -;; Buffers are organized in groups, each one represented by a tab set. -;; A buffer can have no group, or belong to more than one group. The -;; function specified by the variable `tabbar-buffer-groups-function' -;; is called for each buffer to obtain the groups it belongs to. The -;; default function provided: `tabbar-buffer-groups' organizes buffers -;; depending on their major mode (see that function for details). -;; -;; The "home" button toggles display of buffer groups on the tab bar, -;; allowing to easily show another buffer group by clicking on the -;; associated tab. -;; -;; Known problems: -;; -;; Bug item #858306 at <http://sf.net/tracker/?group_id=79309>: -;; tabbar-mode crashes GNU Emacs 21.3 on MS-Windows 98/95. -;; - -;;; History: -;; - -;;; Code: - -;;; Options -;; -(defgroup tabbar nil - "Display a tab bar in the header line." - :group 'convenience) - -(defcustom tabbar-cycle-scope nil - "*Specify the scope of cyclic navigation through tabs. -The following scopes are possible: - -- `tabs' - Navigate through visible tabs only. -- `groups' - Navigate through tab groups only. -- default - Navigate through visible tabs, then through tab groups." - :group 'tabbar - :type '(choice :tag "Cycle through..." - (const :tag "Visible Tabs Only" tabs) - (const :tag "Tab Groups Only" groups) - (const :tag "Visible Tabs then Tab Groups" nil))) - -(defcustom tabbar-auto-scroll-flag t - "*Non-nil means to automatically scroll the tab bar. -That is, when a tab is selected outside of the tab bar visible area, -the tab bar is scrolled horizontally so the selected tab becomes -visible." - :group 'tabbar - :type 'boolean) - -(defvar tabbar-inhibit-functions '(tabbar-default-inhibit-function) - "List of functions to be called before displaying the tab bar. -Those functions are called one by one, with no arguments, until one of -them returns a non-nil value, and thus, prevents to display the tab -bar.") - -(defvar tabbar-current-tabset-function nil - "Function called with no argument to obtain the current tab set. -This is the tab set displayed on the tab bar.") - -(defvar tabbar-tab-label-function nil - "Function that obtains a tab label displayed on the tab bar. -The function is passed a tab and should return a string.") - -(defvar tabbar-select-tab-function nil - "Function that select a tab. -The function is passed a mouse event and a tab, and should make it the -selected tab.") - -(defvar tabbar-help-on-tab-function nil - "Function to obtain a help string for a tab. -The help string is displayed when the mouse is onto the button. The -function is passed the tab and should return a help string or nil for -none.") - -(defvar tabbar-button-label-function nil - "Function that obtains a button label displayed on the tab bar. -The function is passed a button name should return a propertized -string to display.") - -(defvar tabbar-home-function nil - "Function called when clicking on the tab bar home button. -The function is passed the mouse event received.") - -(defvar tabbar-home-help-function nil - "Function to obtain a help string for the tab bar home button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-left-function 'tabbar-scroll-left - "Function that scrolls tabs on left. -The function is passed the mouse event received when clicking on the -scroll left button. It should scroll the current tab set.") - -(defvar tabbar-scroll-left-help-function 'tabbar-scroll-left-help - "Function to obtain a help string for the scroll left button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-right-function 'tabbar-scroll-right - "Function that scrolls tabs on right. -The function is passed the mouse event received when clicking on the -scroll right button. It should scroll the current tab set.") - -(defvar tabbar-scroll-right-help-function 'tabbar-scroll-right-help - "Function to obtain a help string for the scroll right button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -;;; Misc. -;; -(eval-and-compile - (defalias 'tabbar-display-update - (if (fboundp 'force-window-update) - #'(lambda () (force-window-update (selected-window))) - 'force-mode-line-update))) - -(defsubst tabbar-click-p (event) - "Return non-nil if EVENT is a mouse click event." - (memq 'click (event-modifiers event))) - -(defun tabbar-shorten (str width) - "Return a shortened string from STR that fits in the given display WIDTH. -WIDTH is specified in terms of character display width in the current -buffer; see also `char-width'. If STR display width is greater than -WIDTH, STR is truncated and an ellipsis string \"...\" is inserted at -end or in the middle of the returned string, depending on available -room." - (let* ((n (length str)) - (sw (string-width str)) - (el "...") - (ew (string-width el)) - (w 0) - (i 0)) - (cond - ;; STR fit in WIDTH, return it. - ((<= sw width) - str) - ;; There isn't enough room for the ellipsis, STR is just - ;; truncated to fit in WIDTH. - ((<= width ew) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (substring str 0 i)) - ;; There isn't enough room to insert the ellipsis in the middle - ;; of the truncated string, so put the ellipsis at end. - ((zerop (setq sw (/ (- width ew) 2))) - (setq width (- width ew)) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (concat (substring str 0 i) el)) - ;; Put the ellipsis in the middle of the truncated string. - (t - (while (< w sw) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (setq w (+ w ew)) - (while (< w width) - (setq n (1- n) - w (+ w (char-width (aref str n))))) - (concat (substring str 0 i) el (substring str n))) - ))) - -;;; Tab and tab set -;; -(defsubst tabbar-make-tab (object tabset) - "Return a new tab with value OBJECT. -TABSET is the tab set the tab belongs to." - (cons object tabset)) - -(defsubst tabbar-tab-value (tab) - "Return the value of tab TAB." - (car tab)) - -(defsubst tabbar-tab-tabset (tab) - "Return the tab set TAB belongs to." - (cdr tab)) - -(defvar tabbar-tabsets nil - "The tab sets store.") - -(defvar tabbar-tabsets-tabset nil - "The special tab set of existing tab sets.") - -(defvar tabbar-current-tabset nil - "The tab set currently displayed on the tab bar.") -(make-variable-buffer-local 'tabbar-current-tabset) - -(defvar tabbar-init-hook nil - "Hook run after tab bar data has been initialized. -You should use this hook to initialize dependent data.") - -(defsubst tabbar-init-tabsets-store () - "Initialize the tab set store." - (setq tabbar-tabsets (make-vector 31 0) - tabbar-tabsets-tabset (make-symbol "tabbar-tabsets-tabset")) - (put tabbar-tabsets-tabset 'start 0) - (run-hooks 'tabbar-init-hook)) - -(defvar tabbar-quit-hook nil - "Hook run after tab bar data has been freed. -You should use this hook to reset dependent data.") - -(defsubst tabbar-free-tabsets-store () - "Free the tab set store." - (setq tabbar-tabsets nil - tabbar-tabsets-tabset nil) - (run-hooks 'tabbar-quit-hook)) - -;; Define an "hygienic" function free of side effect between its local -;; variables and those of the callee. -(eval-and-compile - (defalias 'tabbar-map-tabsets - (let ((function (make-symbol "function")) - (result (make-symbol "result")) - (tabset (make-symbol "tabset"))) - `(lambda (,function) - "Apply FUNCTION to each tab set, and make a list of the results. -The result is a list just as long as the number of existing tab sets." - (let (,result) - (mapatoms - #'(lambda (,tabset) - (push (funcall ,function ,tabset) ,result)) - tabbar-tabsets) - ,result))))) - -(defun tabbar-make-tabset (name &rest objects) - "Make a new tab set whose name is the string NAME. -It is initialized with tabs build from the list of OBJECTS." - (let* ((tabset (intern name tabbar-tabsets)) - (tabs (mapcar #'(lambda (object) - (tabbar-make-tab object tabset)) - objects))) - (set tabset tabs) - (put tabset 'select (car tabs)) - (put tabset 'start 0) - tabset)) - -(defsubst tabbar-get-tabset (name) - "Return the tab set whose name is the string NAME. -Return nil if not found." - (intern-soft name tabbar-tabsets)) - -(defsubst tabbar-delete-tabset (tabset) - "Delete the tab set TABSET. -That is, remove it from the tab sets store." - (unintern tabset tabbar-tabsets)) - -(defsubst tabbar-tabs (tabset) - "Return the list of tabs in TABSET." - (symbol-value tabset)) - -(defsubst tabbar-tab-values (tabset) - "Return the list of tab values in TABSET." - (mapcar 'tabbar-tab-value (tabbar-tabs tabset))) - -(defsubst tabbar-get-tab (object tabset) - "Search for a tab with value OBJECT in TABSET. -Return the tab found, or nil if not found." - (assoc object (tabbar-tabs tabset))) - -(defsubst tabbar-member (tab tabset) - "Return non-nil if TAB is in TABSET." - (or (eq (tabbar-tab-tabset tab) tabset) - (memq tab (tabbar-tabs tabset)))) - -(defsubst tabbar-template (tabset) - "Return the cached visual representation of TABSET. -That is, a `header-line-format' template, or nil if the cache is -empty." - (get tabset 'template)) - -(defsubst tabbar-set-template (tabset template) - "Set the cached visual representation of TABSET to TEMPLATE. -TEMPLATE must be a valid `header-line-format' template, or nil to -cleanup the cache." - (put tabset 'template template)) - -(defsubst tabbar-selected-tab (tabset) - "Return the tab selected in TABSET." - (get tabset 'select)) - -(defsubst tabbar-selected-value (tabset) - "Return the value of the tab selected in TABSET." - (tabbar-tab-value (tabbar-selected-tab tabset))) - -(defsubst tabbar-selected-p (tab tabset) - "Return non-nil if TAB is the selected tab in TABSET." - (eq tab (tabbar-selected-tab tabset))) - -(defvar tabbar--track-selected nil) - -(defsubst tabbar-select-tab (tab tabset) - "Make TAB the selected tab in TABSET. -Does nothing if TAB is not found in TABSET. -Return TAB if selected, nil if not." - (when (tabbar-member tab tabset) - (unless (tabbar-selected-p tab tabset) - (tabbar-set-template tabset nil) - (setq tabbar--track-selected tabbar-auto-scroll-flag)) - (put tabset 'select tab))) - -(defsubst tabbar-select-tab-value (object tabset) - "Make the tab with value OBJECT, the selected tab in TABSET. -Does nothing if a tab with value OBJECT is not found in TABSET. -Return the tab selected, or nil if nothing was selected." - (tabbar-select-tab (tabbar-get-tab object tabset) tabset)) - -(defsubst tabbar-start (tabset) - "Return the index of the first visible tab in TABSET." - (get tabset 'start)) - -(defsubst tabbar-view (tabset) - "Return the list of visible tabs in TABSET. -That is, the sub-list of tabs starting at the first visible one." - (nthcdr (tabbar-start tabset) (tabbar-tabs tabset))) - -(defun tabbar-add-tab (tabset object &optional append) - "Add to TABSET a tab with value OBJECT if there isn't one there yet. -If the tab is added, it is added at the beginning of the tab list, -unless the optional argument APPEND is non-nil, in which case it is -added at the end." - (let ((tabs (tabbar-tabs tabset))) - (if (tabbar-get-tab object tabset) - tabs - (let ((tab (tabbar-make-tab object tabset))) - (tabbar-set-template tabset nil) - (set tabset (if append - (append tabs (list tab)) - (cons tab tabs))))))) - -(defun tabbar-delete-tab (tab) - "Remove TAB from its tab set." - (let* ((tabset (tabbar-tab-tabset tab)) - (tabs (tabbar-tabs tabset)) - (sel (eq tab (tabbar-selected-tab tabset))) - (next (and sel (cdr (memq tab tabs))))) - (tabbar-set-template tabset nil) - (setq tabs (delq tab tabs)) - ;; When the selected tab is deleted, select the next one, if - ;; available, or the last one otherwise. - (and sel (tabbar-select-tab (car (or next (last tabs))) tabset)) - (set tabset tabs))) - -(defun tabbar-scroll (tabset count) - "Scroll the visible tabs in TABSET of COUNT units. -If COUNT is positive move the view on right. If COUNT is negative, -move the view on left." - (let ((start (min (max 0 (+ (tabbar-start tabset) count)) - (1- (length (tabbar-tabs tabset)))))) - (when (/= start (tabbar-start tabset)) - (tabbar-set-template tabset nil) - (put tabset 'start start)))) - -(defun tabbar-tab-next (tabset tab &optional before) - "Search in TABSET for the tab after TAB. -If optional argument BEFORE is non-nil, search for the tab before -TAB. Return the tab found, or nil otherwise." - (let* (last (tabs (tabbar-tabs tabset))) - (while (and tabs (not (eq tab (car tabs)))) - (setq last (car tabs) - tabs (cdr tabs))) - (and tabs (if before last (nth 1 tabs))))) - -(defun tabbar-current-tabset (&optional update) - "Return the tab set currently displayed on the tab bar. -If optional argument UPDATE is non-nil, call the user defined function -`tabbar-current-tabset-function' to obtain it. Otherwise return the -current cached copy." - (and update tabbar-current-tabset-function - (setq tabbar-current-tabset - (funcall tabbar-current-tabset-function))) - tabbar-current-tabset) - -(defun tabbar-get-tabsets-tabset () - "Return the tab set of selected tabs in existing tab sets." - (set tabbar-tabsets-tabset (tabbar-map-tabsets 'tabbar-selected-tab)) - (tabbar-scroll tabbar-tabsets-tabset 0) - (tabbar-set-template tabbar-tabsets-tabset nil) - tabbar-tabsets-tabset) - -;;; Faces -;; -(defface tabbar-default - '( - ;;(((class color grayscale) (background light)) - ;; :inherit variable-pitch - ;; :height 0.8 - ;; :foreground "gray50" - ;; :background "grey75" - ;; ) - (((class color grayscale) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "grey75" - :background "gray50" - ) - (((class mono) (background light)) - :inherit variable-pitch - :height 0.8 - :foreground "black" - :background "white" - ) - (((class mono) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "white" - :background "black" - ) - (t - :inherit variable-pitch - :height 0.8 - :foreground "gray50" - :background "gray75" - )) - "Default face used in the tab bar." - :group 'tabbar) - -(defface tabbar-unselected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - )) - "Face used for unselected tabs." - :group 'tabbar) - -(defface tabbar-selected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style pressed-button) - :foreground "blue" - )) - "Face used for the selected tab." - :group 'tabbar) - -(defface tabbar-highlight - '((t - :underline t - )) - "Face used to highlight a tab during mouse-overs." - :group 'tabbar) - -(defface tabbar-separator - '((t - :inherit tabbar-default - :height 0.1 - )) - "Face used for separators between tabs." - :group 'tabbar) - -(defface tabbar-button - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - :foreground "dark red" - )) - "Face used for tab bar buttons." - :group 'tabbar) - -(defface tabbar-button-highlight - '((t - :inherit tabbar-default - )) - "Face used to highlight a button during mouse-overs." - :group 'tabbar) - -(defcustom tabbar-background-color nil - "*Background color of the tab bar. -By default, use the background color specified for the -`tabbar-default' face (or inherited from another face), or the -background color of the `default' face otherwise." - :group 'tabbar - :type '(choice (const :tag "Default" nil) - (color))) - -(defsubst tabbar-background-color () - "Return the background color of the tab bar." - (or tabbar-background-color - (let* ((face 'tabbar-default) - (color (face-background face))) - (while (null color) - (or (facep (setq face (face-attribute face :inherit))) - (setq face 'default)) - (setq color (face-background face))) - color))) - -;;; Buttons and separator look and feel -;; -(defconst tabbar-button-widget - '(cons - (cons :tag "Enabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - (cons :tag "Disabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - ) - "Widget for editing a tab bar button. -A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON), -where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when -the button is respectively enabled and disabled. Each button value is -a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a -list of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING. -If only the ENABLED-BUTTON image is provided, a DISABLED-BUTTON image -is derived from it.") - -;;; Home button -;; -(defvar tabbar-home-button-value nil - "Value of the home button.") - -(defconst tabbar-home-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 -6 0 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 -255 255 255 255 255 255 26 130 26 255 255 255 255 255 255 255 0 9 26 -41 130 41 26 9 0 255 255 255 255 5 145 140 135 130 125 120 115 5 255 -255 255 255 0 9 26 41 130 41 26 9 0 255 255 255 255 255 255 255 26 130 -26 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 255 -255 255 255 255 255 0 6 0 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 -")) - "Default image for the enabled home button.") - -(defconst tabbar-home-button-disabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 0 132 128 123 119 114 110 -106 0 255 255 255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 -")) - "Default image for the disabled home button.") - -(defcustom tabbar-home-button - (cons (cons "[o]" tabbar-home-button-enabled-image) - (cons "[x]" tabbar-home-button-disabled-image)) - "The home button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -;;; Scroll left button -;; -(defvar tabbar-scroll-left-button-value nil - "Value of the scroll left button.") - -(defconst tabbar-scroll-left-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 128 16 48 255 255 255 255 255 255 255 -255 144 28 86 128 0 255 255 255 255 255 255 160 44 92 159 135 113 0 -255 255 255 255 160 44 97 165 144 129 120 117 0 255 255 176 44 98 175 -174 146 127 126 127 128 0 255 255 0 160 184 156 143 136 134 135 137 -138 0 255 255 176 32 67 144 146 144 145 146 148 149 0 255 255 255 255 -160 42 75 140 154 158 159 160 0 255 255 255 255 255 255 160 40 74 154 -170 171 0 255 255 255 255 255 255 255 255 160 41 82 163 0 255 255 255 -255 255 255 255 255 255 255 160 32 48 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 -")) - "Default image for the enabled scroll left button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-left-button - (cons (cons " <" tabbar-scroll-left-button-enabled-image) - (cons " =" nil)) - "The scroll left button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-left-button-value nil))) - -;;; Scroll right button -;; -(defvar tabbar-scroll-right-button-value nil - "Value of the scroll right button.") - -(defconst tabbar-scroll-right-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -48 32 160 255 255 255 255 255 255 255 255 255 255 44 161 71 32 160 255 -255 255 255 255 255 255 255 36 157 163 145 62 32 160 255 255 255 255 -255 255 30 128 133 137 142 124 50 32 160 255 255 255 255 29 120 121 -124 126 126 124 105 42 32 176 255 255 31 126 127 128 128 128 128 126 -124 89 32 255 255 33 134 135 136 137 137 138 119 49 32 176 255 255 34 -143 144 145 146 128 54 32 160 255 255 255 255 36 152 153 134 57 32 160 -255 255 255 255 255 255 38 141 60 32 160 255 255 255 255 255 255 255 -255 48 32 160 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 -")) - "Default image for the enabled scroll right button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-right-button - (cons (cons " >" tabbar-scroll-right-button-enabled-image) - (cons " =" nil)) - "The scroll right button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-right-button-value nil))) - -;;; Separator -;; -(defconst tabbar-separator-widget - '(cons (choice (string) - (number :tag "Space width" 0.2)) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - "Widget for editing a tab bar separator. -A separator is specified as a pair (STRING-OR-WIDTH . IMAGE) where -STRING-OR-WIDTH is a string value or a space width, and IMAGE a list -of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING-OR-WIDTH. -The value (\"\"), or (0) hide separators.") - -(defvar tabbar-separator-value nil - "Value of the separator used between tabs.") - -(defcustom tabbar-separator (list 0.2) - "Separator used between tabs. -The variable `tabbar-separator-widget' gives details on this widget." - :group 'tabbar - :type tabbar-separator-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of separator value. - (setq tabbar-separator-value nil))) - -;;; Images -;; -(defcustom tabbar-use-images t - "*Non-nil means to try to use images in tab bar. -That is for buttons and separators." - :group 'tabbar - :type 'boolean - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of all buttons and separator values. - (setq tabbar-separator-value nil - tabbar-home-button-value nil - tabbar-scroll-left-button-value nil - tabbar-scroll-right-button-value nil))) - -(defsubst tabbar-find-image (specs) - "Find an image, choosing one of a list of image specifications. -SPECS is a list of image specifications. See also `find-image'." - (when (and tabbar-use-images (display-images-p)) - (condition-case nil - (find-image specs) - (error nil)))) - -(defsubst tabbar-disable-image (image) - "From IMAGE, return a new image which looks disabled." - (setq image (copy-sequence image)) - (setcdr image (plist-put (cdr image) :conversion 'disabled)) - image) - -(defsubst tabbar-normalize-image (image &optional margin) - "Make IMAGE centered and transparent. -If optional MARGIN is non-nil, it must be a number of pixels to add as -an extra margin around the image." - (let ((plist (cdr image))) - (or (plist-get plist :ascent) - (setq plist (plist-put plist :ascent 'center))) - (or (plist-get plist :mask) - (setq plist (plist-put plist :mask '(heuristic t)))) - (or (not (natnump margin)) - (plist-get plist :margin) - (plist-put plist :margin margin)) - (setcdr image plist)) - image) - -;;; Button keymaps and callbacks -;; -(defun tabbar-make-mouse-keymap (callback) - "Return a keymap that call CALLBACK on mouse events. -CALLBACK is passed the received mouse event." - (let ((keymap (make-sparse-keymap))) - ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK. - (define-key keymap [header-line down-mouse-1] 'ignore) - (define-key keymap [header-line mouse-1] callback) - (define-key keymap [header-line down-mouse-2] 'ignore) - (define-key keymap [header-line mouse-2] callback) - (define-key keymap [header-line down-mouse-3] 'ignore) - (define-key keymap [header-line mouse-3] callback) - keymap)) - -(defsubst tabbar-make-mouse-event (&optional type) - "Return a mouse click event. -Optional argument TYPE is a mouse-click event or one of the -symbols `mouse-1', `mouse-2' or `mouse-3'. -The default is `mouse-1'." - (if (tabbar-click-p type) - type - (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1) - (or (event-start nil) ;; Emacs 21.4 - (list (selected-window) (point) '(0 . 0) 0))))) - -;;; Buttons -;; -(defconst tabbar-default-button-keymap - (tabbar-make-mouse-keymap 'tabbar-select-button-callback) - "Default keymap of a button.") - -(defun tabbar-help-on-button (window object position) - "Return a help string or nil for none, for the button under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the button label under the mouse. -POSITION is the position in that label. -Call `tabbar-NAME-help-function' where NAME is the button name -associated to OBJECT." - (let* ((name (get-text-property position 'tabbar-button object)) - (funvar (and name - (intern-soft (format "tabbar-%s-help-function" - name))))) - (and (symbol-value funvar) - (funcall (symbol-value funvar))))) - -(defsubst tabbar-click-on-button (name &optional type) - "Handle a mouse click event on button NAME. -Call `tabbar-select-NAME-function' with the received, or simulated -mouse click event. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (let ((funvar (intern-soft (format "tabbar-%s-function" name)))) - (when (symbol-value funvar) - (funcall (symbol-value funvar) (tabbar-make-mouse-event type)) - (tabbar-display-update)))) - -(defun tabbar-select-button-callback (event) - "Handle a mouse EVENT on a button. -Pass mouse click events on a button to `tabbar-click-on-button'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-button - (get-text-property (cdr target) 'tabbar-button (car target)) - event)))) - -(defun tabbar-make-button-keymap (name) - "Return a keymap to handle mouse click events on button NAME." - (if (fboundp 'posn-string) - tabbar-default-button-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-button ',name ,event))))))) - -;;; Button callbacks -;; -(defun tabbar-scroll-left (event) - "On mouse EVENT, scroll current tab set on left." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) -1))) - -(defun tabbar-scroll-left-help () - "Help string shown when mouse is over the scroll left button." - "mouse-1: scroll tabs left.") - -(defun tabbar-scroll-right (event) - "On mouse EVENT, scroll current tab set on right." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) 1))) - -(defun tabbar-scroll-right-help () - "Help string shown when mouse is over the scroll right button." - "mouse-1: scroll tabs right.") - -;;; Tabs -;; -(defconst tabbar-default-tab-keymap - (tabbar-make-mouse-keymap 'tabbar-select-tab-callback) - "Default keymap of a tab.") - -(defun tabbar-help-on-tab (window object position) - "Return a help string or nil for none, for the tab under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the tab label under the mouse. -POSITION is the position in that label. -Call `tabbar-help-on-tab-function' with the associated tab." - (when tabbar-help-on-tab-function - (let ((tab (get-text-property position 'tabbar-tab object))) - (funcall tabbar-help-on-tab-function tab)))) - -(defsubst tabbar-click-on-tab (tab &optional type) - "Handle a mouse click event on tab TAB. -Call `tabbar-select-tab-function' with the received, or simulated -mouse click event, and TAB. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (when tabbar-select-tab-function - (funcall tabbar-select-tab-function - (tabbar-make-mouse-event type) tab) - (tabbar-display-update))) - -(defun tabbar-select-tab-callback (event) - "Handle a mouse EVENT on a tab. -Pass mouse click events on a tab to `tabbar-click-on-tab'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-tab - (get-text-property (cdr target) 'tabbar-tab (car target)) - event)))) - -(defun tabbar-make-tab-keymap (tab) - "Return a keymap to handle mouse click events on TAB." - (if (fboundp 'posn-string) - tabbar-default-tab-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-tab ',tab ,event))))))) - -;;; Tab bar construction -;; -(defun tabbar-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-NAME-button'." - (let* ((btn (symbol-value - (intern-soft (format "tabbar-%s-button" name)))) - (on (tabbar-find-image (cdar btn))) - (off (and on (tabbar-find-image (cddr btn))))) - (when on - (tabbar-normalize-image on 1) - (if off - (tabbar-normalize-image off 1) - ;; If there is no disabled button image, derive one from the - ;; button enabled image. - (setq off (tabbar-disable-image on)))) - (cons - (propertize (or (caar btn) " ") 'display on) - (propertize (or (cadr btn) " ") 'display off)))) - -(defun tabbar-line-button (name) - "Return the display representation of button NAME. -That is, a propertized string used as an `header-line-format' template -element." - (let ((label (if tabbar-button-label-function - (funcall tabbar-button-label-function name) - (cons name name)))) - ;; Cache the display value of the enabled/disabled buttons in - ;; variables `tabbar-NAME-button-value'. - (set (intern (format "tabbar-%s-button-value" name)) - (cons - (propertize (car label) - 'tabbar-button name - 'face 'tabbar-button - 'mouse-face 'tabbar-button-highlight - 'pointer 'hand - 'local-map (tabbar-make-button-keymap name) - 'help-echo 'tabbar-help-on-button) - (propertize (cdr label) - 'face 'tabbar-button - 'pointer 'arrow))))) - -(defun tabbar-line-separator () - "Return the display representation of a tab bar separator. -That is, a propertized string used as an `header-line-format' template -element." - (let ((image (tabbar-find-image (cdr tabbar-separator)))) - ;; Cache the separator display value in variable - ;; `tabbar-separator-value'. - (setq tabbar-separator-value - (cond - (image - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (tabbar-normalize-image image))) - ((numberp (car tabbar-separator)) - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (list 'space - :width (car tabbar-separator)))) - ((propertize (or (car tabbar-separator) " ") - 'face 'tabbar-separator - 'pointer 'arrow)))) - )) - -(defsubst tabbar-line-buttons (tabset) - "Return a list of propertized strings for tab bar buttons. -TABSET is the tab set used to choose the appropriate buttons." - (list - (if tabbar-home-function - (car tabbar-home-button-value) - (cdr tabbar-home-button-value)) - (if (> (tabbar-start tabset) 0) - (car tabbar-scroll-left-button-value) - (cdr tabbar-scroll-left-button-value)) - (if (< (tabbar-start tabset) - (1- (length (tabbar-tabs tabset)))) - (car tabbar-scroll-right-button-value) - (cdr tabbar-scroll-right-button-value)) - tabbar-separator-value)) - -(defsubst tabbar-line-tab (tab) - "Return the display representation of tab TAB. -That is, a propertized string used as an `header-line-format' template -element. -Call `tabbar-tab-label-function' to obtain a label for TAB." - (concat (propertize - (if tabbar-tab-label-function - (funcall tabbar-tab-label-function tab) - tab) - 'tabbar-tab tab - 'local-map (tabbar-make-tab-keymap tab) - 'help-echo 'tabbar-help-on-tab - 'mouse-face 'tabbar-highlight - 'face (if (tabbar-selected-p tab (tabbar-current-tabset)) - 'tabbar-selected - 'tabbar-unselected) - 'pointer 'hand) - tabbar-separator-value)) - -(defun tabbar-line-format (tabset) - "Return the `header-line-format' value to display TABSET." - (let* ((sel (tabbar-selected-tab tabset)) - (tabs (tabbar-view tabset)) - (padcolor (tabbar-background-color)) - atsel elts) - ;; Initialize buttons and separator values. - (or tabbar-separator-value - (tabbar-line-separator)) - (or tabbar-home-button-value - (tabbar-line-button 'home)) - (or tabbar-scroll-left-button-value - (tabbar-line-button 'scroll-left)) - (or tabbar-scroll-right-button-value - (tabbar-line-button 'scroll-right)) - ;; Track the selected tab to ensure it is always visible. - (when tabbar--track-selected - (while (not (memq sel tabs)) - (tabbar-scroll tabset -1) - (setq tabs (tabbar-view tabset))) - (while (and tabs (not atsel)) - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - atsel (eq (car tabs) sel) - tabs (cdr tabs))) - (setq elts (nreverse elts)) - ;; At this point the selected tab is the last elt in ELTS. - ;; Scroll TABSET and ELTS until the selected tab becomes - ;; visible. - (with-temp-buffer - (let ((truncate-partial-width-windows nil) - (inhibit-modification-hooks t) - deactivate-mark ;; Prevent deactivation of the mark! - start) - (setq truncate-lines nil - buffer-undo-list t) - (apply 'insert (tabbar-line-buttons tabset)) - (setq start (point)) - (while (and (cdr elts) ;; Always show the selected tab! - (progn - (delete-region start (point-max)) - (goto-char (point-max)) - (apply 'insert elts) - (goto-char (point-min)) - (> (vertical-motion 1) 0))) - (tabbar-scroll tabset 1) - (setq elts (cdr elts))))) - (setq elts (nreverse elts)) - (setq tabbar--track-selected nil)) - ;; Format remaining tabs. - (while tabs - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - tabs (cdr tabs))) - ;; Cache and return the new tab bar. - (tabbar-set-template - tabset - (list (tabbar-line-buttons tabset) - (nreverse elts) - (propertize "%-" - 'face (list :background padcolor - :foreground padcolor) - 'pointer 'arrow))) - )) - -(defun tabbar-line () - "Return the header line templates that represent the tab bar. -Inhibit display of the tab bar in current window if any of the -`tabbar-inhibit-functions' return non-nil." - (cond - ((run-hook-with-args-until-success 'tabbar-inhibit-functions) - ;; Don't show the tab bar. - (setq header-line-format nil)) - ((tabbar-current-tabset t) - ;; When available, use a cached tab bar value, else recompute it. - (or (tabbar-template tabbar-current-tabset) - (tabbar-line-format tabbar-current-tabset))))) - -(defconst tabbar-header-line-format '(:eval (tabbar-line)) - "The tab bar header line format.") - -(defun tabbar-default-inhibit-function () - "Inhibit display of the tab bar in specified windows. -That is dedicated windows, and `checkdoc' status windows." - (or (window-dedicated-p (selected-window)) - (member (buffer-name) - (list " *Checkdoc Status*" - (if (boundp 'ispell-choices-buffer) - ispell-choices-buffer - "*Choices*"))))) - -;;; Cyclic navigation through tabs -;; -(defun tabbar-cycle (&optional backward type) - "Cycle to the next available tab. -The scope of the cyclic navigation through tabs is specified by the -option `tabbar-cycle-scope'. -If optional argument BACKWARD is non-nil, cycle to the previous tab -instead. -Optional argument TYPE is a mouse event type (see the function -`tabbar-make-mouse-event' for details)." - (let* ((tabset (tabbar-current-tabset t)) - (ttabset (tabbar-get-tabsets-tabset)) - ;; If navigation through groups is requested, and there is - ;; only one group, navigate through visible tabs. - (cycle (if (and (eq tabbar-cycle-scope 'groups) - (not (cdr (tabbar-tabs ttabset)))) - 'tabs - tabbar-cycle-scope)) - selected tab) - (when tabset - (setq selected (tabbar-selected-tab tabset)) - (cond - ;; Cycle through visible tabs only. - ((eq cycle 'tabs) - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no tab after/before the selected one, cycle - ;; to the first/last visible tab. - (unless tab - (setq tabset (tabbar-tabs tabset) - tab (car (if backward (last tabset) tabset)))) - ) - ;; Cycle through tab groups only. - ((eq cycle 'groups) - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no group after/before the selected one, cycle - ;; to the first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ) - (t - ;; Cycle through visible tabs then tab groups. - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no visible tab after/before the selected one, - ;; cycle to the next/previous available group. - (unless tab - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no next/previous group, cycle to the - ;; first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ;; Select the first/last visible tab of the new group. - (setq tabset (tabbar-tabs (tabbar-tab-tabset tab)) - tab (car (if backward (last tabset) tabset)))) - )) - (tabbar-click-on-tab tab type)))) - -;;;###autoload -(defun tabbar-backward () - "Select the previous available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle t)) - -;;;###autoload -(defun tabbar-forward () - "Select the next available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle)) - -;;;###autoload -(defun tabbar-backward-group () - "Go to selected tab in the previous available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-group () - "Go to selected tab in the next available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle))) - -;;;###autoload -(defun tabbar-backward-tab () - "Select the previous visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-tab () - "Select the next visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle))) - -;;; Button press commands -;; -(defsubst tabbar--mouse (number) - "Return a mouse button symbol from NUMBER. -That is mouse-2, or mouse-3 when NUMBER is respectively 2, or 3. -Return mouse-1 otherwise." - (cond ((eq number 2) 'mouse-2) - ((eq number 3) 'mouse-3) - ('mouse-1))) - -;;;###autoload -(defun tabbar-press-home (&optional arg) - "Press the tab bar home button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'home (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-left (&optional arg) - "Press the tab bar scroll-left button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-left (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-right (&optional arg) - "Press the tab bar scroll-right button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-right (tabbar--mouse arg))) - -;;; Mouse-wheel support -;; -(require 'mwheel) - -;;; Compatibility -;; -(defconst tabbar--mwheel-up-event - (symbol-value (if (boundp 'mouse-wheel-up-event) - 'mouse-wheel-up-event - 'mouse-wheel-up-button))) - -(defconst tabbar--mwheel-down-event - (symbol-value (if (boundp 'mouse-wheel-down-event) - 'mouse-wheel-down-event - 'mouse-wheel-down-button))) - -(defsubst tabbar--mwheel-key (event-type) - "Return a mouse wheel key symbol from EVENT-TYPE. -When EVENT-TYPE is a symbol return it. -When it is a button number, return symbol `mouse-<EVENT-TYPE>'." - (if (symbolp event-type) - event-type - (intern (format "mouse-%s" event-type)))) - -(defsubst tabbar--mwheel-up-p (event) - "Return non-nil if EVENT is a mouse-wheel up event." - (let ((x (event-basic-type event))) - (if (eq 'mouse-wheel x) - (< (car (cdr (cdr event))) 0) ;; Emacs 21.3 - ;; Emacs > 21.3 - (eq x tabbar--mwheel-up-event)))) - -;;; Basic commands -;; -;;;###autoload -(defun tabbar-mwheel-backward (event) - "Select the previous available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward'." - (interactive "@e") - (tabbar-cycle t event)) - -;;;###autoload -(defun tabbar-mwheel-forward (event) - "Select the next available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward'." - (interactive "@e") - (tabbar-cycle nil event)) - -;;;###autoload -(defun tabbar-mwheel-backward-group (event) - "Go to selected tab in the previous available group. -If there is only one group, select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-group (event) - "Go to selected tab in the next available group. -If there is only one group, select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle nil event))) - -;;;###autoload -(defun tabbar-mwheel-backward-tab (event) - "Select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-tab (event) - "Select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle nil event))) - -;;; Wrappers when there is only one generic mouse-wheel event -;; -;;;###autoload -(defun tabbar-mwheel-switch-tab (event) - "Select the next or previous tab according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-tab event) - (tabbar-mwheel-backward-tab event))) - -;;;###autoload -(defun tabbar-mwheel-switch-group (event) - "Select the next or previous group of tabs according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-group event) - (tabbar-mwheel-backward-group event))) - -;;; Minor modes -;; -(defsubst tabbar-mode-on-p () - "Return non-nil if Tabbar mode is on." - (eq (default-value 'header-line-format) - tabbar-header-line-format)) - -;;; Tabbar-Local mode -;; -(defvar tabbar--local-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-local-mode - "Toggle local display of the tab bar. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. -When turned on, if a local header line is shown, it is hidden to show -the tab bar. The tab bar is locally hidden otherwise. When turned -off, if a local header line is hidden or the tab bar is locally -hidden, it is shown again. Signal an error if Tabbar mode is off." - :group 'tabbar - :global nil - (unless (tabbar-mode-on-p) - (error "Tabbar mode must be enabled")) -;;; ON - (if tabbar-local-mode - (if (and (local-variable-p 'header-line-format) - header-line-format) - ;; A local header line exists, hide it to show the tab bar. - (progn - ;; Fail in case of an inconsistency because another local - ;; header line is already hidden. - (when (local-variable-p 'tabbar--local-hlf) - (error "Another local header line is already hidden")) - (set (make-local-variable 'tabbar--local-hlf) - header-line-format) - (kill-local-variable 'header-line-format)) - ;; Otherwise hide the tab bar in this buffer. - (setq header-line-format nil)) -;;; OFF - (if (local-variable-p 'tabbar--local-hlf) - ;; A local header line is hidden, show it again. - (progn - (setq header-line-format tabbar--local-hlf) - (kill-local-variable 'tabbar--local-hlf)) - ;; The tab bar is locally hidden, show it again. - (kill-local-variable 'header-line-format)))) - -;;; Tabbar mode -;; -(defvar tabbar-prefix-key [(control ?c)] - "The common prefix key used in Tabbar mode.") - -(defvar tabbar-prefix-map - (let ((km (make-sparse-keymap))) - (define-key km [(control home)] 'tabbar-press-home) - (define-key km [(control left)] 'tabbar-backward) - (define-key km [(control right)] 'tabbar-forward) - (define-key km [(control up)] 'tabbar-backward-group) - (define-key km [(control down)] 'tabbar-forward-group) - (define-key km [(control prior)] 'tabbar-press-scroll-left) - (define-key km [(control next)] 'tabbar-press-scroll-right) - (define-key km [(control f10)] 'tabbar-local-mode) - km) - "The key bindings provided in Tabbar mode.") - -(defvar tabbar-mode-map - (let ((km (make-sparse-keymap))) - (define-key km tabbar-prefix-key tabbar-prefix-map) - km) - "Keymap to use in Tabbar mode.") - -(defvar tabbar--global-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-mode - "Toggle display of a tab bar in the header line. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mode-map - (if tabbar-mode -;;; ON - (unless (tabbar-mode-on-p) - ;; Save current default value of `header-line-format'. - (setq tabbar--global-hlf (default-value 'header-line-format)) - (tabbar-init-tabsets-store) - (setq-default header-line-format tabbar-header-line-format)) -;;; OFF - (when (tabbar-mode-on-p) - ;; Turn off Tabbar-Local mode globally. - (mapc #'(lambda (b) - (condition-case nil - (with-current-buffer b - (and tabbar-local-mode - (tabbar-local-mode -1))) - (error nil))) - (buffer-list)) - ;; Restore previous `header-line-format'. - (setq-default header-line-format tabbar--global-hlf) - (tabbar-free-tabsets-store)) - )) - -;;; Tabbar-Mwheel mode -;; -(defvar tabbar-mwheel-mode-map - (let ((km (make-sparse-keymap))) - (if (get 'mouse-wheel 'event-symbol-elements) - ;; Use one generic mouse wheel event - (define-key km [A-mouse-wheel] - 'tabbar-mwheel-switch-group) - ;; Use separate up/down mouse wheel events - (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) - (down (tabbar--mwheel-key tabbar--mwheel-down-event))) - (define-key km `[header-line ,down] - 'tabbar-mwheel-backward-group) - (define-key km `[header-line ,up] - 'tabbar-mwheel-forward-group) - (define-key km `[header-line (control ,down)] - 'tabbar-mwheel-backward-tab) - (define-key km `[header-line (control ,up)] - 'tabbar-mwheel-forward-tab) - (define-key km `[header-line (shift ,down)] - 'tabbar-mwheel-backward) - (define-key km `[header-line (shift ,up)] - 'tabbar-mwheel-forward) - )) - km) - "Keymap to use in Tabbar-Mwheel mode.") - -;;;###autoload -(define-minor-mode tabbar-mwheel-mode - "Toggle use of the mouse wheel to navigate through tabs or groups. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mwheel-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mwheel-mode-map - (when tabbar-mwheel-mode - (unless (and mouse-wheel-mode tabbar-mode) - (tabbar-mwheel-mode -1)))) - -(defun tabbar-mwheel-follow () - "Toggle Tabbar-Mwheel following Tabbar and Mouse-Wheel modes." - (tabbar-mwheel-mode (if (and mouse-wheel-mode tabbar-mode) 1 -1))) - -(add-hook 'tabbar-mode-hook 'tabbar-mwheel-follow) -(add-hook 'mouse-wheel-mode-hook 'tabbar-mwheel-follow) - -;;; Buffer tabs -;; -(defgroup tabbar-buffer nil - "Display buffers in the tab bar." - :group 'tabbar) - -(defcustom tabbar-buffer-home-button - (cons (cons "[+]" tabbar-home-button-enabled-image) - (cons "[-]" tabbar-home-button-disabled-image)) - "The home button displayed when showing buffer tabs. -The enabled button value is displayed when showing tabs for groups of -buffers, and the disabled button value is displayed when showing -buffer tabs. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar-buffer - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -(defvar tabbar-buffer-list-function 'tabbar-buffer-list - "Function that returns the list of buffers to show in tabs. -That function is called with no arguments and must return a list of -buffers.") - -(defvar tabbar-buffer-groups-function 'tabbar-buffer-groups - "Function that gives the group names the current buffer belongs to. -It must return a list of group names, or nil if the buffer has no -group. Notice that it is better that a buffer belongs to one group.") - -(defun tabbar-buffer-list () - "Return the list of buffers to show in tabs. -Exclude buffers whose name starts with a space, when they are not -visiting a file. The current buffer is always included." - (delq nil - (mapcar #'(lambda (b) - (cond - ;; Always include the current buffer. - ((eq (current-buffer) b) b) - ((buffer-file-name b) b) - ((char-equal ?\ (aref (buffer-name b) 0)) nil) - ((buffer-live-p b) b))) - (buffer-list)))) - -(defun tabbar-buffer-mode-derived-p (mode parents) - "Return non-nil if MODE derives from a mode in PARENTS." - (let (derived) - (while (and (not derived) mode) - (if (memq mode parents) - (setq derived t) - (setq mode (get mode 'derived-mode-parent)))) - derived)) - -(defun tabbar-buffer-groups () - "Return the list of group names the current buffer belongs to. -Return a list of one element based on major mode." - (list - (cond - ((or (get-buffer-process (current-buffer)) - ;; Check if the major mode derives from `comint-mode' or - ;; `compilation-mode'. - (tabbar-buffer-mode-derived-p - major-mode '(comint-mode compilation-mode))) - "Process" - ) - ((member (buffer-name) - '("*scratch*" "*Messages*")) - "Common" - ) - ((eq major-mode 'dired-mode) - "Dired" - ) - ((memq major-mode - '(help-mode apropos-mode Info-mode Man-mode)) - "Help" - ) - ((memq major-mode - '(rmail-mode - rmail-edit-mode vm-summary-mode vm-mode mail-mode - mh-letter-mode mh-show-mode mh-folder-mode - gnus-summary-mode message-mode gnus-group-mode - gnus-article-mode score-mode gnus-browse-killed-mode)) - "Mail" - ) - (t - ;; Return `mode-name' if not blank, `major-mode' otherwise. - (if (and (stringp mode-name) - ;; Take care of preserving the match-data because this - ;; function is called when updating the header line. - (save-match-data (string-match "[^ ]" mode-name))) - mode-name - (symbol-name major-mode)) - )))) - -;;; Group buffers in tab sets. -;; -(defvar tabbar--buffers nil) - -(defun tabbar-buffer-update-groups () - "Update tab sets from groups of existing buffers. -Return the the first group where the current buffer is." - (let ((bl (sort - (mapcar - #'(lambda (b) - (with-current-buffer b - (list (current-buffer) - (buffer-name) - (if tabbar-buffer-groups-function - (funcall tabbar-buffer-groups-function) - '("Common"))))) - (and tabbar-buffer-list-function - (funcall tabbar-buffer-list-function))) - #'(lambda (e1 e2) - (string-lessp (nth 1 e1) (nth 1 e2)))))) - ;; If the cache has changed, update the tab sets. - (unless (equal bl tabbar--buffers) - ;; Add new buffers, or update changed ones. - (dolist (e bl) - (dolist (g (nth 2 e)) - (let ((tabset (tabbar-get-tabset g))) - (if tabset - (unless (equal e (assq (car e) tabbar--buffers)) - ;; This is a new buffer, or a previously existing - ;; buffer that has been renamed, or moved to another - ;; group. Update the tab set, and the display. - (tabbar-add-tab tabset (car e) t) - (tabbar-set-template tabset nil)) - (tabbar-make-tabset g (car e)))))) - ;; Remove tabs for buffers not found in cache or moved to other - ;; groups, and remove empty tabsets. - (mapc 'tabbar-delete-tabset - (tabbar-map-tabsets - #'(lambda (tabset) - (dolist (tab (tabbar-tabs tabset)) - (let ((e (assq (tabbar-tab-value tab) bl))) - (or (and e (memq tabset - (mapcar 'tabbar-get-tabset - (nth 2 e)))) - (tabbar-delete-tab tab)))) - ;; Return empty tab sets - (unless (tabbar-tabs tabset) - tabset)))) - ;; The new cache becomes the current one. - (setq tabbar--buffers bl))) - ;; Return the first group the current buffer belongs to. - (car (nth 2 (assq (current-buffer) tabbar--buffers)))) - -;;; Tab bar callbacks -;; -(defvar tabbar--buffer-show-groups nil) - -(defsubst tabbar-buffer-show-groups (flag) - "Set display of tabs for groups of buffers to FLAG." - (setq tabbar--buffer-show-groups flag - ;; Redisplay the home button. - tabbar-home-button-value nil)) - -(defun tabbar-buffer-tabs () - "Return the buffers to display on the tab bar, in a tab set." - (let ((tabset (tabbar-get-tabset (tabbar-buffer-update-groups)))) - (tabbar-select-tab-value (current-buffer) tabset) - (when tabbar--buffer-show-groups - (setq tabset (tabbar-get-tabsets-tabset)) - (tabbar-select-tab-value (current-buffer) tabset)) - tabset)) - -(defun tabbar-buffer-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-button-label'. -When NAME is 'home, return a different ENABLED button if showing tabs -or groups. Call the function `tabbar-button-label' otherwise." - (let ((lab (tabbar-button-label name))) - (when (eq name 'home) - (let* ((btn tabbar-buffer-home-button) - (on (tabbar-find-image (cdar btn))) - (off (tabbar-find-image (cddr btn)))) - ;; When `tabbar-buffer-home-button' does not provide a value, - ;; default to the enabled value of `tabbar-home-button'. - (if on - (tabbar-normalize-image on 1) - (setq on (get-text-property 0 'display (car lab)))) - (if off - (tabbar-normalize-image off 1) - (setq off (get-text-property 0 'display (car lab)))) - (setcar lab - (if tabbar--buffer-show-groups - (propertize (or (caar btn) (car lab)) 'display on) - (propertize (or (cadr btn) (car lab)) 'display off))) - )) - lab)) - -(defun tabbar-buffer-tab-label (tab) - "Return a label for TAB. -That is, a string used to represent it on the tab bar." - (let ((label (if tabbar--buffer-show-groups - (format "[%s]" (tabbar-tab-tabset tab)) - (format "%s" (tabbar-tab-value tab))))) - ;; Unless the tab bar auto scrolls to keep the selected tab - ;; visible, shorten the tab label to keep as many tabs as possible - ;; in the visible area of the tab bar. - (if tabbar-auto-scroll-flag - label - (tabbar-shorten - label (max 1 (/ (window-width) - (length (tabbar-view - (tabbar-current-tabset))))))))) - -(defun tabbar-buffer-help-on-tab (tab) - "Return the help string shown when mouse is onto TAB." - (if tabbar--buffer-show-groups - (let* ((tabset (tabbar-tab-tabset tab)) - (tab (tabbar-selected-tab tabset))) - (format "mouse-1: switch to buffer %S in group [%s]" - (buffer-name (tabbar-tab-value tab)) tabset)) - (format "mouse-1: switch to buffer %S\n\ -mouse-2: pop to buffer, mouse-3: delete other windows" - (buffer-name (tabbar-tab-value tab))) - )) - -(defun tabbar-buffer-select-tab (event tab) - "On mouse EVENT, select TAB." - (let ((mouse-button (event-basic-type event)) - (buffer (tabbar-tab-value tab))) - (cond - ((eq mouse-button 'mouse-2) - (pop-to-buffer buffer t)) - ((eq mouse-button 'mouse-3) - (delete-other-windows)) - (t - (switch-to-buffer buffer))) - ;; Don't show groups. - (tabbar-buffer-show-groups nil) - )) - -(defun tabbar-buffer-click-on-home (event) - "Handle a mouse click EVENT on the tab bar home button. -mouse-1, toggle the display of tabs for groups of buffers. -mouse-3, close the current buffer." - (let ((mouse-button (event-basic-type event))) - (cond - ((eq mouse-button 'mouse-1) - (tabbar-buffer-show-groups (not tabbar--buffer-show-groups))) - ((eq mouse-button 'mouse-3) - (kill-buffer nil)) - ))) - -(defun tabbar-buffer-help-on-home () - "Return the help string shown when mouse is onto the toggle button." - (concat - (if tabbar--buffer-show-groups - "mouse-1: show buffers in selected group" - "mouse-1: show groups of buffers") - ", mouse-3: close current buffer")) - -(defun tabbar-buffer-track-killed () - "Hook run just before actually killing a buffer. -In Tabbar mode, try to switch to a buffer in the current tab bar, -after the current buffer has been killed. Try first the buffer in tab -after the current one, then the buffer in tab before. On success, put -the sibling buffer in front of the buffer list, so it will be selected -first." - (and (eq header-line-format tabbar-header-line-format) - (eq tabbar-current-tabset-function 'tabbar-buffer-tabs) - (eq (current-buffer) (window-buffer (selected-window))) - (let ((bl (tabbar-tab-values (tabbar-current-tabset))) - (b (current-buffer)) - found sibling) - (while (and bl (not found)) - (if (eq b (car bl)) - (setq found t) - (setq sibling (car bl))) - (setq bl (cdr bl))) - (when (and (setq sibling (or (car bl) sibling)) - (buffer-live-p sibling)) - ;; Move sibling buffer in front of the buffer list. - (save-current-buffer - (switch-to-buffer sibling)))))) - -;;; Tab bar buffer setup -;; -(defun tabbar-buffer-init () - "Initialize tab bar buffer data. -Run as `tabbar-init-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function 'tabbar-buffer-tabs - tabbar-tab-label-function 'tabbar-buffer-tab-label - tabbar-select-tab-function 'tabbar-buffer-select-tab - tabbar-help-on-tab-function 'tabbar-buffer-help-on-tab - tabbar-button-label-function 'tabbar-buffer-button-label - tabbar-home-function 'tabbar-buffer-click-on-home - tabbar-home-help-function 'tabbar-buffer-help-on-home - ) - (add-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(defun tabbar-buffer-quit () - "Quit tab bar buffer. -Run as `tabbar-quit-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function nil - tabbar-tab-label-function nil - tabbar-select-tab-function nil - tabbar-help-on-tab-function nil - tabbar-button-label-function nil - tabbar-home-function nil - tabbar-home-help-function nil - ) - (remove-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(add-hook 'tabbar-init-hook 'tabbar-buffer-init) -(add-hook 'tabbar-quit-hook 'tabbar-buffer-quit) - -(provide 'tabbar) - -(run-hooks 'tabbar-load-hook) - -;;; tabbar.el ends here diff --git a/emacs.d/elisp/zenburn.el b/emacs.d/elisp/zenburn.el deleted file mode 100644 index 1238f3c..0000000 --- a/emacs.d/elisp/zenburn.el +++ /dev/null @@ -1,1179 +0,0 @@ -;;; zenburn.el --- just some alien fruit salad to keep you in the zone -;; Copyright (C) 2003, 2004, 2005, 2006 Daniel Brockman -;; Copyright (C) 2009 Adrian C., Bastien Guerry - -;; Author: Daniel Brockman <daniel@brockman.se> -;; URL: http://www.brockman.se/software/zenburn/zenburn.el -;; Updated: 2009-07-08 05:27 - -;; Adrian C. and Bastien Guerry added org-mode faces. - -;; 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 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 GNU Emacs; if not, write to the Free -;; Software Foundation, 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Some packages ship with broken implementations of `format-spec'; -;; for example, stable versions of TRAMP and ERC do this. To fix -;; this, you can put the following at the end of your ~/.emacs: - -;; (unless (zenburn-format-spec-works-p) -;; (zenburn-define-format-spec)) - -;; Thanks to Jani Nurminen, who created the original zenburn color -;; theme for vim. I'm just copying him. :-) - -;;; Short-Term Wishlist: - -;; Theme the ansi-term faces `term-red', etc., and the ERC faces -;; `fg:erc-color-face1', etc. - -;; Theme `gnus-server-offline-face', `gnus-server-opened-face', and -;; `gnus-server-denied-face'. First, find out what they hell they do. - -;; Theme `gnus-emphasis-highlight-words' after finding out what it -;; does. - -;; Theme `emms-stream-name-face' and `emms-stream-url-face'. - -;; Theme `ido-indicator-face'. - -;;; Code: - -(require 'color-theme) - -(defvar zenburn-fg "#dcdccc") -(defvar zenburn-bg "#3f3f3f") -(defvar zenburn-bg+1 "#4f4f4f") -(defvar zenburn-bg+2 "#5f5f5f") -(defvar zenburn-red+1 "#dca3a3") -(defvar zenburn-red "#cc9393") -(defvar zenburn-red-1 "#bc8383") -(defvar zenburn-red-2 "#ac7373") -(defvar zenburn-red-3 "#9c6363") -(defvar zenburn-red-4 "#8c5353") -(defvar zenburn-orange "#dfaf8f") -(defvar zenburn-yellow "#f0dfaf") -(defvar zenburn-yellow-1 "#e0cf9f") -(defvar zenburn-yellow-2 "#d0bf8f") -(defvar zenburn-green-1 "#5f7f5f") -(defvar zenburn-green "#7f9f7f") -(defvar zenburn-green+1 "#8fb28f") -(defvar zenburn-green+2 "#9fc59f") -(defvar zenburn-green+3 "#afd8af") -(defvar zenburn-green+4 "#bfebbf") -(defvar zenburn-cyan "#93e0e3") -(defvar zenburn-blue+1 "#94bff3") -(defvar zenburn-blue "#8cd0d3") -(defvar zenburn-blue-1 "#7cb8bb") -(defvar zenburn-blue-2 "#6ca0a3") -(defvar zenburn-blue-3 "#5c888b") -(defvar zenburn-blue-4 "#4c7073") -(defvar zenburn-magenta "#dc8cc3") - -(eval-after-load 'term - '(setq ansi-term-color-vector - (vector 'unspecified zenburn-bg - zenburn-red zenburn-green - zenburn-yellow zenburn-blue+1 - zenburn-magenta zenburn-cyan))) - -(defvar font-lock-pseudo-keyword-face 'font-lock-pseudo-keyword-face) -(defvar font-lock-operator-face 'font-lock-operator-face) - -(defun zenburn-format-spec-works-p () - (and (fboundp 'format-spec) - (= (next-property-change - 0 (format-spec #("<%x>" 0 4 (face (:weight bold))) - '((?x . "foo"))) 4) 4))) - -(defun zenburn-format-spec (format specification) - "Return a string based on FORMAT and SPECIFICATION. -FORMAT is a string containing `format'-like specs like \"bash %u %k\", -while SPECIFICATION is an alist mapping from format spec characters -to values." - (with-temp-buffer - (insert format) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (cond - ;; Quoted percent sign. - ((eq (char-after) ?%) - (delete-char 1)) - ;; Valid format spec. - ((looking-at "\\([-0-9.]*\\)\\([a-zA-Z]\\)") - (let* ((num (match-string 1)) - (spec (string-to-char (match-string 2))) - (val (cdr (assq spec specification)))) - (unless val - (error "Invalid format character: %s" spec)) - (let ((text (format (concat "%" num "s") val))) - (insert-and-inherit text) - ;; Delete the specifier body. - (delete-region (+ (match-beginning 0) (length text)) - (+ (match-end 0) (length text))) - ;; Delete the percent sign. - (delete-region (1- (match-beginning 0)) (match-beginning 0))))) - ;; Signal an error on bogus format strings. - (t - (error "Invalid format string")))) - (buffer-string))) - -(defun zenburn-define-format-spec () - (interactive) - (fset 'format-spec #'zenburn-format-spec)) - -(unless (zenburn-format-spec-works-p) - (zenburn-define-format-spec)) - -(eval-after-load 'format-spec - '(unless (zenburn-format-spec-works-p) - (zenburn-define-format-spec))) - -(setq-default mode-line-buffer-identification - (list (propertize "%12b" 'face - (list :weight 'bold - :foreground zenburn-yellow)))) -(setq-default mode-line-frame-identification "") -(setq-default erc-mode-line-format - (concat (propertize "%t" 'face - (list :weight 'bold - :foreground zenburn-yellow)) - " %a")) - -(setq gnus-logo-colors `(,zenburn-bg+2 ,zenburn-bg+1) - gnus-mode-line-image-cache - '(image :type xpm :ascent center :data "/* XPM */ -static char *gnus-pointer[] = { -/* width height num_colors chars_per_pixel */ -\" 18 11 2 1\", -/* colors */ -\". c #dcdccc\", -\"# c None s None\", -/* pixels */ -\"######..##..######\", -\"#####........#####\", -\"#.##.##..##...####\", -\"#...####.###...##.\", -\"#..###.######.....\", -\"#####.########...#\", -\"###########.######\", -\"####.###.#..######\", -\"######..###.######\", -\"###....####.######\", -\"###..######.######\"};")) - -(defun zenburn-make-face-alias-clauses (alias-symbols) - (let (clauses) - (dolist (alias-symbol alias-symbols clauses) - (let ((alias-name (symbol-name alias-symbol))) - (if (not (string-match "-face" alias-name)) - (error "Invalid face alias: %s" alias-name) - (let ((target-name (replace-regexp-in-string - ".*\\(-face\\)" "" - alias-name nil nil 1))) - (push `(,(intern alias-name) - ((t (:inherit ,(intern target-name))))) - clauses))))))) - -;;;###autoload -(defun color-theme-zenburn () - "Just some alien fruit salad to keep you in the zone." - (interactive) - (color-theme-install - (append - (list 'color-theme-zenburn - `((background-color . ,zenburn-bg) - (background-mode . dark) - (border-color . ,zenburn-bg) - (foreground-color . ,zenburn-fg) - (mouse-color . ,zenburn-fg)) - `((emms-mode-line-icon-color . ,zenburn-fg) - (goto-address-mail-face . italic) - (goto-address-mail-mouse-face . secondary-selection) - (goto-address-url-face . bold) - (goto-address-url-mouse-face . hover-highlight) - (help-highlight-face . hover-highlight) - (imaxima-label-color . ,zenburn-yellow) - (imaxima-equation-color . ,zenburn-fg) - (list-matching-lines-face . bold) - (view-highlight-face . hover-highlight) - (widget-mouse-face . hover-highlight)) - - '(bold ((t (:weight bold)))) - '(bold-italic ((t (:italic t :weight bold)))) - `(default ((t (:background ,zenburn-bg :foreground ,zenburn-fg)))) - '(fixed-pitch ((t (:weight bold)))) - '(italic ((t (:slant italic)))) - '(underline ((t (:underline t)))) - ;; '(variable-pitch ((t (:font "-*-utopia-regular-r-*-*-12-*-*-*-*-*-*-*")))) - - `(zenburn-background-1 ((t (:background ,zenburn-bg+1)))) - `(zenburn-background-2 ((t (:background ,zenburn-bg+2)))) - - `(zenburn-primary-1 ((t (:foreground ,zenburn-yellow :weight bold)))) - `(zenburn-primary-2 ((t (:foreground ,zenburn-orange :weight bold)))) - '(zenburn-primary-3 ((t (:foreground "#dfdfbf" :weight bold)))) - '(zenburn-primary-4 ((t (:foreground "#dca3a3" :weight bold)))) - '(zenburn-primary-5 ((t (:foreground "#94bff3" :weight bold)))) - - '(zenburn-highlight-damp - ((t (:foreground "#88b090" :background "#2e3330")))) - '(zenburn-highlight-alerting - ((t (:foreground "#e37170" :background "#332323")))) - '(zenburn-highlight-subtle - ((t (:background "#464646")))) - - '(zenburn-lowlight-1 ((t (:foreground "#606060")))) - '(zenburn-lowlight-2 ((t (:foreground "#708070")))) - - `(zenburn-yellow ((t (:foreground ,zenburn-yellow)))) - `(zenburn-orange ((t (:foreground ,zenburn-orange)))) - `(zenburn-red ((t (:foreground ,zenburn-red)))) - `(zenburn-green-1 ((t (:foreground ,zenburn-green-1)))) - `(zenburn-green ((t (:foreground ,zenburn-green)))) - `(zenburn-green+1 ((t (:foreground ,zenburn-green+1)))) - `(zenburn-green+2 ((t (:foreground ,zenburn-green+2)))) - `(zenburn-green+3 ((t (:foreground ,zenburn-green+3)))) - `(zenburn-green+4 ((t (:foreground ,zenburn-green+4)))) - `(zenburn-blue ((t (:foreground ,zenburn-blue)))) - `(zenburn-blue-1 ((t (:foreground ,zenburn-blue-1)))) - `(zenburn-blue-2 ((t (:foreground ,zenburn-blue-2)))) - `(zenburn-blue-3 ((t (:foreground ,zenburn-blue-3)))) - `(zenburn-blue-4 ((t (:foreground ,zenburn-blue-4)))) - - '(zenburn-title ((t (:inherit variable-pitch :weight bold)))) - - '(font-lock-builtin - ((t (:inherit zenburn-blue)))) - '(font-lock-comment - ((t (:inherit zenburn-green)))) - '(font-lock-comment-delimiter - ((t (:inherit zenburn-lowlight-2)))) - '(font-lock-constant - ((t (:inherit zenburn-primary-4)))) - '(font-lock-doc - ((t (:inherit zenburn-green+1)))) - `(font-lock-function-name - ((t (:foreground ,zenburn-yellow)))) - '(font-lock-keyword - ((t (:inherit zenburn-primary-1)))) - '(font-lock-negation-char - ((t (:inherit zenburn-primary-1)))) - '(font-lock-preprocessor - ((t (:inherit zenburn-blue)))) - '(font-lock-string - ((t (:inherit zenburn-red)))) - '(font-lock-type - ((t (:inherit zenburn-primary-3)))) - `(font-lock-variable-name - ((t (:foreground ,zenburn-yellow)))) - '(font-lock-warning - ((t (:inherit zenburn-highlight-alerting)))) - - '(font-lock-pseudo-keyword - ((t (:inherit zenburn-primary-2)))) - '(font-lock-operator - ((t (:inherit zenburn-primary-3)))) - - '(term-default-bg ((t (nil)))) - '(term-default-bg-inv ((t (nil)))) - '(term-default-fg ((t (nil)))) - '(term-default-fg-inv ((t (nil)))) - '(term-invisible ((t (nil)))) ;; FIXME: Security risk? - '(term-invisible-inv ((t (nil)))) - '(term-bold ((t (:weight bold)))) - '(term-underline ((t (:underline t)))) - - ;; FIXME: Map these to ansi-term's faces (`term-red', etc.). - '(zenburn-term-dark-gray ((t (:foreground "#709080")))) - '(zenburn-term-light-blue ((t (:foreground "#94bff3")))) - '(zenburn-term-light-cyan ((t (:foreground "#93e0e3")))) - '(zenburn-term-light-green ((t (:foreground "#c3bf9f")))) - '(zenburn-term-light-magenta ((t (:foreground "#ec93d3")))) - '(zenburn-term-light-red ((t (:foreground "#dca3a3")))) - '(zenburn-term-light-yellow ((t (:foreground "#f0dfaf")))) - '(zenburn-term-white ((t (:foreground "#ffffff")))) - - '(zenburn-term-black ((t (:foreground "#000000")))) - '(zenburn-term-dark-blue ((t (:foreground "#506070")))) - '(zenburn-term-dark-cyan ((t (:foreground "#8cd0d3")))) - '(zenburn-term-dark-green ((t (:foreground "#60b48a")))) - '(zenburn-term-dark-magenta ((t (:foreground "#dc8cc3")))) - '(zenburn-term-dark-red ((t (:foreground "#705050")))) - '(zenburn-term-dark-yellow ((t (:foreground "#dfaf8f")))) - `(zenburn-term-light-gray ((t (:foreground ,zenburn-fg)))) - - '(plain-widget-button - ((t (:weight bold)))) - '(plain-widget-button-pressed - ((t (:inverse-video t)))) - '(plain-widget-documentation - ((t (:inherit font-lock-doc)))) - `(plain-widget-field - ((t (:background ,zenburn-bg+2)))) - '(plain-widget-inactive - ((t (:strike-through t)))) - `(plain-widget-single-line-field - ((t (:background ,zenburn-bg+2)))) - - `(fancy-widget-button - ((t (:background ,zenburn-bg+1 - :box (:line-width 2 :style released-button))))) - `(fancy-widget-button-pressed - ((t (:background ,zenburn-bg+1 - :box (:line-width 2 :style pressed-button))))) - `(fancy-widget-button-highlight - ((t (:background ,zenburn-bg+1 - :box (:line-width 2 :style released-button))))) - `(fancy-widget-button-pressed-highlight - ((t (:background ,zenburn-bg+1 - :box (:line-width 2 :style pressed-button))))) - '(fancy-widget-documentation - ((t (:inherit font-lock-doc)))) - `(fancy-widget-field - ((t (:background ,zenburn-bg+2)))) - '(fancy-widget-inactive - ((t (:strike-through t)))) - `(fancy-widget-single-line-field - ((t (:background ,zenburn-bg+2)))) - - '(widget-button - ((t (:inherit plain-widget-button)))) - '(widget-button-pressed - ((t (:inherit fancy-widget-button-pressed)))) - '(widget-button-highlight - ((t (:inherit fancy-widget-button-highlight)))) - '(widget-button-pressed-highlight - ((t (:inherit fancy-widget-button-pressed-highlight)))) - '(widget-documentation - ((t (:inherit fancy-widget-documentation)))) - '(widget-field - ((t (:inherit fancy-widget-field)))) - '(widget-inactive - ((t (:inherit fancy-widget-inactive)))) - '(widget-single-line-field - ((t (:inherit fancy-widget-single-line-field)))) - - `(border ((t (:background ,zenburn-bg)))) - '(fringe ((t (:inherit zenburn-highlight-subtle)))) - '(header-line ((t (:inherit zenburn-highlight-damp - :box (:color "#2e3330" :line-width 2))))) - '(mode-line ((t (:foreground "#acbc90" :background "#1e2320" - :box (:color "#1e2320" :line-width 2))))) - '(mode-line-inactive ((t (:background "#2e3330" :foreground "#88b090" - :box (:color "#2e3330" :line-width 2))))) - `(minibuffer-prompt ((t (:foreground ,zenburn-yellow)))) - `(Buffer-menu-buffer ((t (:inherit zenburn-primary-1)))) - - '(region ((t (:foreground "#71d3b4" :background "#233323")))) - `(secondary-selection ((t (:foreground ,zenburn-fg :background "#506070")))) - - '(trailing-whitespace ((t (:inherit font-lock-warning)))) - '(highlight ((t (:underline t)))) - '(paren ((t (:inherit zenburn-lowlight-1)))) - '(show-paren-mismatch ((t (:inherit font-lock-warning)))) - '(show-paren-match ((t (:inherit font-lock-keyword)))) - '(match ((t (:weight bold)))) - - `(cursor ((t (:background ,zenburn-fg :foreground ,zenburn-bg)))) - '(hover-highlight ((t (:underline t :foreground "#f8f893")))) - '(menu ((t nil))) - '(mouse ((t (:inherit zenburn-foreground)))) - `(scroll-bar ((t (:background ,zenburn-bg+2)))) - `(tool-bar ((t (:background ,zenburn-bg+2)))) - - '(ido-first-match ((t (:inherit zenburn-primary-1)))) - '(ido-only-match ((t (:inherit zenburn-primary-2)))) - `(ido-subdir ((t (:foreground ,zenburn-yellow)))) - - `(isearch ((t (:foreground ,zenburn-fg :background "#506070")))) - `(isearch-lazy-highlight - ((t (:foreground ,zenburn-fg :background "#1e2320" :weight normal)))) - - '(mtorus-highlight ((t (:inherit zenburn-highlight-bluish)))) - '(mtorus-notify-highlight ((t (:inherit zenburn-primary-1)))) - - '(which-func ((t (:inherit mode-line)))) - - '(apt-utils-normal-package - ((t (:inherit zenburn-primary-1)))) - '(apt-utils-virtual-package - ((t (:inherit zenburn-primary-2)))) - '(apt-utils-field-keyword - ((t (:inherit font-lock-doc)))) - '(apt-utils-field-contents - ((t (:inherit font-lock-comment)))) - '(apt-utils-summary - ((t (:inherit bold)))) - '(apt-utils-description - ((t (:inherit default)))) - '(apt-utils-version - ((t (:inherit zenburn-blue)))) - '(apt-utils-broken - ((t (:inherit font-lock-warning)))) - - '(breakpoint-enabled-bitmap ((t (:inherit zenburn-primary-1)))) - '(breakpoint-disabled-bitmap ((t (:inherit font-lock-comment)))) - - '(calendar-today ((t (:underline nil :inherit zenburn-primary-2)))) - '(diary ((t (:underline nil :inherit zenburn-primary-1)))) - '(holiday ((t (:underline t :inherit zenburn-primary-4)))) - - '(bongo-unfilled-seek-bar ((t (:background "#606060")))) - - '(change-log-date ((t (:inherit zenburn-blue)))) - - '(comint-highlight-input ((t (:inherit zenburn-primary-1)))) - '(comint-highlight-prompt ((t (:inherit zenburn-primary-2)))) - - '(compilation-info ((t (:inherit zenburn-primary-1)))) - '(compilation-warning ((t (:inherit font-lock-warning)))) - - ;; TODO - '(cua-rectangle ((t (:inherit region)))) - - '(custom-button - ((t (:inherit fancy-widget-button)))) - '(custom-button-pressed - ((t (:inherit fancy-widget-button-pressed)))) - '(custom-changed - ((t (:inherit zenburn-blue)))) - '(custom-comment - ((t (:inherit font-lock-doc)))) - '(custom-comment-tag - ((t (:inherit font-lock-doc)))) - '(custom-documentation - ((t (:inherit font-lock-doc)))) - '(custom-link - ((t (:inherit zenburn-yellow :underline t)))) - '(custom-tag - ((t (:inherit zenburn-primary-2)))) - '(custom-group-tag - ((t (:inherit zenburn-primary-1)))) - '(custom-group-tag-1 - ((t (:inherit zenburn-primary-4)))) - '(custom-invalid - ((t (:inherit font-lock-warning)))) - '(custom-modified - ((t (:inherit zenburn-primary-3)))) - '(custom-rogue - ((t (:inhrit font-lock-warning)))) - '(custom-saved - ((t (:underline t)))) - '(custom-set - ((t (:inverse-video t :inherit zenburn-blue)))) - '(custom-state - ((t (:inherit font-lock-comment)))) - '(custom-variable-button - ((t (:weight bold :underline t)))) - '(custom-variable-tag - ((t (:inherit zenburn-primary-2)))) - - '(dictionary-button ((t (:inherit fancy-widget-button)))) - '(dictionary-reference ((t (:inherit zenburn-primary-1)))) - '(dictionary-word-entry ((t (:inherit font-lock-keyword)))) - - '(diff-header ((t (:inherit zenburn-highlight-subtle)))) - '(diff-index ((t (:inherit bold)))) - '(diff-file-header ((t (:inherit bold)))) - '(diff-hunk-header ((t (:inherit zenburn-highlight-subtle)))) - - '(diff-added ((t (:inherit zenburn-primary-3)))) - '(diff-removed ((t (:inherit zenburn-blue)))) - '(diff-context ((t (:inherit font-lock-comment)))) - - `(emms-pbi-song ((t (:foreground ,zenburn-yellow)))) - '(emms-pbi-current ((t (:inherit zenburn-primary-1)))) - '(emms-pbi-mark-marked ((t (:inherit zenburn-primary-2)))) - - '(erc-action ((t (:inherit erc-default)))) - '(erc-bold ((t (:weight bold)))) - '(erc-current-nick ((t (:inherit zenburn-primary-1)))) - '(erc-dangerous-host ((t (:inherit font-lock-warning)))) - `(erc-default ((t (:foreground ,zenburn-fg)))) - '(erc-direct-msg ((t (:inherit erc-default)))) - '(erc-error ((t (:inherit font-lock-warning)))) - '(erc-fool ((t (:inherit zenburn-lowlight-1)))) - '(erc-highlight ((t (:inherit hover-highlight)))) - `(erc-input ((t (:foreground ,zenburn-yellow)))) - '(erc-keyword ((t (:inherit zenburn-primary-1)))) - '(erc-nick-default ((t (:inherit bold)))) - '(erc-nick-msg ((t (:inherit erc-default)))) - '(erc-notice ((t (:inherit zenburn-green)))) - '(erc-pal ((t (:inherit zenburn-primary-3)))) - '(erc-prompt ((t (:inherit zenburn-primary-2)))) - '(erc-timestamp ((t (:inherit zenburn-green+1)))) - '(erc-underline ((t (:inherit underline)))) - - '(circe-highlight-nick-face ((t (:inherit zenburn-primary-1)))) - '(circe-my-message-face ((t (:inherit zenburn-yellow)))) - '(circe-originator-face ((t (:inherit bold)))) - '(circe-prompt-face ((t (:inherit zenburn-primary-1)))) - '(circe-server-face ((t (:inherit font-lock-comment-face)))) - - '(rcirc-my-nick ((t (:inherit zenburn-primary-1)))) - '(rcirc-other-nick ((t (:inherit bold)))) - '(rcirc-bright-nick ((t (:foreground "white" :inherit rcirc-other-nick)))) - '(rcirc-dim-nick ((t (:inherit font-lock-comment)))) - '(rcirc-nick-in-message ((t (:inherit bold)))) - '(rcirc-server ((t (:inherit font-lock-comment)))) - '(rcirc-server-prefix ((t (:inherit font-lock-comment-delimiter)))) - '(rcirc-timestamp ((t (:inherit font-lock-comment)))) - '(rcirc-prompt ((t (:inherit zenburn-primary-1)))) - '(rcirc-mode-line-nick ((t (:inherit zenburn-primary-1)))) - - '(eshell-prompt ((t (:inherit zenburn-primary-1)))) - '(eshell-ls-archive ((t (:foreground "#c3bf9f" :weight bold)))) - '(eshell-ls-backup ((t (:inherit font-lock-comment)))) - '(eshell-ls-clutter ((t (:inherit font-lock-comment)))) - `(eshell-ls-directory ((t (:foreground ,zenburn-blue+1 :weight bold)))) - `(eshell-ls-executable ((t (:foreground ,zenburn-red+1 :weight bold)))) - '(eshell-ls-unreadable ((t (:inherit zenburn-lowlight-1)))) - '(eshell-ls-missing ((t (:inherit font-lock-warning)))) - '(eshell-ls-product ((t (:inherit font-lock-doc)))) - '(eshell-ls-special ((t (:inherit zenburn-primary-1)))) - `(eshell-ls-symlink ((t (:foreground ,zenburn-cyan :weight bold)))) - - '(highlight-current-line ((t (:inherit zenburn-highlight-subtle)))) - - '(ibuffer-deletion ((t (:inherit zenburn-primary-2)))) - '(ibuffer-marked ((t (:inherit zenburn-primary-1)))) - '(ibuffer-special-buffer ((t (:inherit font-lock-doc)))) - '(ibuffer-help-buffer ((t (:inherit font-lock-comment)))) - - '(message-cited-text ((t (:inherit font-lock-comment)))) - ;;`(message-cited-text ((t (:foreground ,zenburn-blue)))) - '(message-header-name ((t (:inherit zenburn-green+1)))) - '(message-header-other ((t (:inherit zenburn-green)))) - '(message-header-to ((t (:inherit zenburn-primary-1)))) - '(message-header-from ((t (:inherit zenburn-primary-1)))) - '(message-header-cc ((t (:inherit zenburn-primary-1)))) - '(message-header-newsgroups ((t (:inherit zenburn-primary-1)))) - '(message-header-subject ((t (:inherit zenburn-primary-2)))) - '(message-header-xheader ((t (:inherit zenburn-green)))) - '(message-mml ((t (:inherit zenburn-primary-1)))) - '(message-separator ((t (:inherit font-lock-comment)))) - - '(gnus-header-name ((t (:inherit message-header-name)))) - '(gnus-header-content ((t (:inherit message-header-other)))) - '(gnus-header-from ((t (:inherit message-header-from)))) - '(gnus-header-subject ((t (:inherit message-header-subject)))) - '(gnus-header-newsgroups ((t (:inherit message-header-other)))) - - `(gnus-x-face ((t (:background ,zenburn-fg :foreground ,zenburn-bg)))) - - ;; (gnus-cite-1 ((t (:inherit message-cited-text)))) - `(gnus-cite-1 ((t (:foreground ,zenburn-blue)))) - `(gnus-cite-2 ((t (:foreground ,zenburn-blue-1)))) - `(gnus-cite-3 ((t (:foreground ,zenburn-blue-2)))) -;; (gnus-cite-4 ((t (:foreground ,zenburn-blue-3)))) -;; (gnus-cite-5 ((t (:foreground ,zenburn-blue-4)))) -;; (gnus-cite-6 ((t (:foreground ,zenburn-red-4)))) -;; (gnus-cite-5 ((t (:foreground ,zenburn-red-3)))) - `(gnus-cite-4 ((t (:foreground ,zenburn-green+2)))) - `(gnus-cite-5 ((t (:foreground ,zenburn-green+1)))) - `(gnus-cite-6 ((t (:foreground ,zenburn-green)))) - `(gnus-cite-7 ((t (:foreground ,zenburn-red)))) - `(gnus-cite-8 ((t (:foreground ,zenburn-red-1)))) - `(gnus-cite-9 ((t (:foreground ,zenburn-red-2)))) - `(gnus-cite-10 ((t (:foreground ,zenburn-yellow-1)))) - `(gnus-cite-11 ((t (:foreground ,zenburn-yellow)))) - - `(gnus-group-news-1-empty ((t (:foreground ,zenburn-yellow)))) - `(gnus-group-news-2-empty ((t (:foreground ,zenburn-green+3)))) - `(gnus-group-news-3-empty ((t (:foreground ,zenburn-green+1)))) - `(gnus-group-news-4-empty ((t (:foreground ,zenburn-blue-2)))) - `(gnus-group-news-5-empty ((t (:foreground ,zenburn-blue-3)))) - `(gnus-group-news-6-empty ((t (:inherit zenburn-lowlight-1)))) - `(gnus-group-news-low-empty ((t (:inherit zenburn-lowlight-1)))) - - '(gnus-group-mail-1-empty ((t (:inherit gnus-group-news-1-empty)))) - '(gnus-group-mail-2-empty ((t (:inherit gnus-group-news-2-empty)))) - '(gnus-group-mail-3-empty ((t (:inherit gnus-group-news-3-empty)))) - '(gnus-group-mail-4-empty ((t (:inherit gnus-group-news-4-empty)))) - '(gnus-group-mail-5-empty ((t (:inherit gnus-group-news-5-empty)))) - '(gnus-group-mail-6-empty ((t (:inherit gnus-group-news-6-empty)))) - '(gnus-group-mail-low-empty ((t (:inherit gnus-group-news-low-empty)))) - - '(gnus-group-news-1 ((t (:bold t :inherit gnus-group-news-1-empty)))) - '(gnus-group-news-2 ((t (:bold t :inherit gnus-group-news-2-empty)))) - '(gnus-group-news-3 ((t (:bold t :inherit gnus-group-news-3-empty)))) - '(gnus-group-news-4 ((t (:bold t :inherit gnus-group-news-4-empty)))) - '(gnus-group-news-5 ((t (:bold t :inherit gnus-group-news-5-empty)))) - '(gnus-group-news-6 ((t (:bold t :inherit gnus-group-news-6-empty)))) - '(gnus-group-news-low ((t (:bold t :inherit gnus-group-news-low-empty)))) - - '(gnus-group-mail-1 ((t (:bold t :inherit gnus-group-mail-1-empty)))) - '(gnus-group-mail-2 ((t (:bold t :inherit gnus-group-mail-2-empty)))) - '(gnus-group-mail-3 ((t (:bold t :inherit gnus-group-mail-3-empty)))) - '(gnus-group-mail-4 ((t (:bold t :inherit gnus-group-mail-4-empty)))) - '(gnus-group-mail-5 ((t (:bold t :inherit gnus-group-mail-5-empty)))) - '(gnus-group-mail-6 ((t (:bold t :inherit gnus-group-mail-6-empty)))) - '(gnus-group-mail-low ((t (:bold t :inherit gnus-group-mail-low-empty)))) - - `(gnus-signature ((t (:foreground ,zenburn-yellow)))) - - '(gnus-summary-selected - ((t (:inherit zenburn-primary-1)))) - '(gnus-summary-cancelled - ((t (:inherit zenburn-highlight-alerting)))) - - '(gnus-summary-low-ticked - ((t (:inherit zenburn-primary-2)))) - '(gnus-summary-normal-ticked - ((t (:inherit zenburn-primary-2)))) - '(gnus-summary-high-ticked - ((t (:inherit zenburn-primary-2)))) - - '(gnus-summary-low-unread - ((t (:inherit zenburn-foreground :weight normal)))) - '(gnus-summary-normal-unread - ((t (:inherit zenburn-foreground :weight normal)))) - '(gnus-summary-high-unread - ((t (:inherit zenburn-foreground :weight bold)))) - - '(gnus-summary-low-read - ((t (:inherit zenburn-green :weight normal)))) - '(gnus-summary-normal-read - ((t (:inherit zenburn-green :weight normal)))) - '(gnus-summary-high-read - ((t (:inherit zenburn-green :weight bold)))) - - '(gnus-summary-low-ancient - ((t (:inherit zenburn-blue :weight normal)))) - '(gnus-summary-normal-ancient - ((t (:inherit zenburn-blue :weight normal)))) - '(gnus-summary-high-ancient - ((t (:inherit zenburn-blue)))) - - '(help-argument-name ((t (:weight bold)))) - - ;; See also the variable definitions at the top of this file - '(imaxima-latex-error ((t (:inherit font-lock-warning)))) - - `(info-xref ((t (:foreground ,zenburn-yellow :weight bold)))) - '(info-xref-visited ((t (:inherit info-xref :weight normal)))) - '(info-header-xref ((t (:inherit info-xref)))) - `(info-menu-star ((t (:foreground ,zenburn-orange :weight bold)))) - `(info-menu-5 ((t (:inherit info-menu-star)))) - '(info-node ((t (:weight bold)))) - '(info-header-node ((t (:weight normal)))) - - '(jabber-roster-user-chatty - ((t (:inherit zenburn-primary-1)))) - '(jabber-roster-user-online - ((t (:inherit zenburn-primary-2)))) - '(jabber-roster-user-away - ((t (:inherit font-lock-doc)))) - '(jabber-roster-user-xa - ((t (:inherit font-lock-comment)))) - '(jabber-roster-user-offline - ((t (:inherit zenburn-lowlight-1)))) - '(jabber-roster-user-dnd - ((t (:inherit zenburn-primary-5)))) - '(jabber-roster-user-error - ((t (:inherit font-lock-warning)))) - - '(jabber-title-small - ((t (:inherit zenburn-title :height 1.2)))) - '(jabber-title-medium - ((t (:inherit jabber-title-small :height 1.2)))) - '(jabber-title-large - ((t (:inherit jabber-title-medium :height 1.2)))) - - '(jabber-chat-prompt-local - ((t (:inherit zenburn-primary-1)))) - '(jabber-chat-prompt-foreign - ((t (:inherit zenburn-primary-2)))) - - '(jabber-rare-time-face - ((t (:inherit zenburn-green+1)))) - - '(jde-java-font-lock-modifier - ((t (:inherit zenburn-primary-2)))) - '(jde-java-font-lock-doc-tag - ((t (:inherit zenburn-primary-1)))) - '(jde-java-font-lock-constant - ((t (:inherit font-lock-constant)))) - '(jde-java-font-lock-package - ((t (:inherit zenburn-primary-3)))) - '(jde-java-font-lock-number - ((t (:inherit font-lock-constant)))) - '(jde-java-font-lock-operator - ((t (:inherit font-lock-keyword)))) - '(jde-java-font-lock-link - ((t (:inherit zenburn-primary-5 :underline t)))) - - '(keywiz-right ((t (:inherit zenburn-primary-1)))) - '(keywiz-wrong ((t (:inherit font-lock-warning)))) - '(keywiz-command ((t (:inherit zenburn-primary-2)))) - - '(font-latex-bold ((t (:inherit bold)))) - '(font-latex-warning ((t (:inherit font-lock-warning)))) - '(font-latex-sedate ((t (:inherit zenburn-primary-1)))) - '(font-latex-title-4 ((t (:inherit zenburn-title)))) - - '(makefile-space ((t (:inherit font-lock-warning)))) - '(makefile-shell ((t (nil)))) - ;; This does not work very well because everything that's highlighted - ;; inside the shell region will get its own box. - ;; (makefile-shell ((t (:background "#4f4f4f" - ;; :box (:line-width 2 :color "#4f4f4f"))))) - - '(nxml-delimited-data ((t (:inherit font-lock-string)))) - '(nxml-name ((t (:inherit zenburn-primary-1)))) - '(nxml-ref ((t (:inherit zenburn-primary-5)))) - '(nxml-delimiter ((t (:inherit default)))) - '(nxml-text ((t (:inherit default)))) - - '(nxml-comment-content - ((t (:inherit font-lock-comment)))) - '(nxml-comment-delimiter - ((t (:inherit nxml-comment-content)))) - '(nxml-processing-instruction-target - ((t (:inherit zenburn-primary-2)))) - '(nxml-processing-instruction-delimiter - ((t (:inherit nxml-processing-instruction-target)))) - '(nxml-processing-instruction-content - ((t (:inherit nxml-processing-instruction-target)))) - '(nxml-cdata-section-CDATA - ((t (:inherit zenburn-primary-4)))) - '(nxml-cdata-section-delimiter - ((t (:inherit nxml-cdata-section-CDATA)))) - '(nxml-cdata-section-content - ((t (:inherit nxml-text)))) - '(nxml-entity-ref-name - ((t (:inherit zenburn-primary-5)))) - '(nxml-entity-ref-delimiter - ((t (:inherit nxml-entity-ref-name)))) - '(nxml-char-ref-number - ((t (:inherit nxml-entity-ref-name)))) - '(nxml-char-ref-delimiter - ((t (:inherit nxml-entity-ref-delimiter)))) - - '(nxml-tag-delimiter ((t (:inherit default)))) - '(nxml-tag-slash ((t (:inherit default)))) - '(nxml-element-local-name ((t (:inherit zenburn-primary-1)))) - '(nxml-element-prefix ((t (:inherit default)))) - '(nxml-element-colon ((t (:inherit default)))) - - '(nxml-attribute-local-name - ((t (:inherit zenburn-primary-3)))) - '(nxml-namespace-attribute-prefix - ((t (:inherit nxml-attribute-local-name)))) - '(nxml-attribute-value - ((t (:inherit font-lock-string)))) - '(nxml-attribute-value-delimiter - ((t (:inherit nxml-attribute-value)))) - '(nxml-attribute-prefix - ((t (:inherit default)))) - '(nxml-namespace-attribute-xmlns - ((t (:inherit nxml-attribute-prefix)))) - '(nxml-attribute-colon - ((t (:inherit default)))) - '(nxml-namespace-attribute-colon - ((t (:inherit nxml-attribute-colon)))) - - '(org-agenda-date-today ((t (:foreground "white" - :slant italic :weight bold))) t) ;; white - '(org-agenda-structure ((t (:inherit font-lock-comment-face)))) ;; zenburn-green - '(org-archived ((t (:foreground "#8f8f8f")))) ;; zenburn-bg slight lighter - '(org-column ((t (:height 98 :family "DejaVu Sans Mono")))) ;; n/a - '(org-checkbox ((t (:background "#5f5f5f" :foreground "white" ;; zenburn-fg on zenburn-bg+2 - :box (:line-width 1 :style released-button))))) ;; - turn checkboxes into buttons - '(org-date ((t (:foreground "#8cd0d3" :underline t)))) ;; zenburn-blue - '(org-deadline-announce ((t (:foreground "#bc8383")))) ;; zenburn-red-1 - '(org-done ((t (:bold t :weight bold :foreground "#afd8af")))) ;; zenburn-green+3 - '(org-formula ((t (:foreground "#d0bf8f")))) ;; zenburn-yellow-2 - '(org-headline-done ((t (:foreground "#afd8af")))) ;; zenburn-green+3 - '(org-hide ((t (:foreground "#282828")))) ;; zenburn-bg slight darker - '(org-level-1 ((t (:foreground "#dfaf8f")))) ;; zenburn-orange - '(org-level-2 ((t (:foreground "#f0dfaf")))) ;; zenburn-yellow - '(org-level-3 ((t (:foreground "#8cd0d3")))) ;; zenburn-blue - '(org-level-4 ((t (:foreground "#93e0e3")))) ;; zenburn-cyan - '(org-level-5 ((t (:foreground "#7cb8bb")))) ;; zenburn-blue-1 - '(org-level-6 ((t (:foreground "#6ca0a3")))) ;; zenburn-blue-2 - '(org-level-7 ((t (:foreground "#5c888b")))) ;; zenburn-blue-3 - '(org-level-8 ((t (:foreground "#4c7073")))) ;; zenburn-blue-4 - '(org-link ((t (:foreground "#d0bf8f" :underline t)))) ;; zenburn-yellow-2 - ;'(org-priority faces TODO - '(org-scheduled ((t (:foreground "#bfebbf")))) ;; zenburn-green+4 - '(org-scheduled-previously ((t (:foreground "#8c5353")))) ;; zenburn-red-4 - '(org-scheduled-today ((t (:foreground "#94bff3")))) ;; zenburn-blue+1 - '(org-special-keyword ((t (:foreground "#e0cf9f")))) ;; zenburn-yellow-1 - '(org-table ((t (:foreground "#9fc59f")))) ;; zenburn-green+2 - '(org-tag ((t (:bold t :weight bold)))) ;; n/a - '(org-time-grid ((t (:foreground "#ffc9a4")))) ;; zenburn-orange slight lighter - '(org-todo ((t (:bold t :foreground "#cc9393" :weight bold)))) ;; zenburn-red - '(org-upcoming-deadline ((t (:inherit font-lock-keyword-face)))) ;; zenburn-fg - '(org-warning ((t (:bold t :foreground "#cc9393" :weight bold))));; zenburn-red - - ;; TODO - '(outline-8 ((t (:inherit default)))) - '(outline-7 ((t (:inherit outline-8 :height 1.0)))) - '(outline-6 ((t (:inherit outline-7 :height 1.0)))) - '(outline-5 ((t (:inherit outline-6 :height 1.0)))) - '(outline-4 ((t (:inherit outline-5 :height 1.0)))) - '(outline-3 ((t (:inherit outline-4 :height 1.0)))) - '(outline-2 ((t (:inherit outline-3 :height 1.0)))) - '(outline-1 ((t (:inherit outline-2 :height 1.0)))) - - '(setnu-line-number ((t (:inherit zenburn-lowlight-2)))) - - '(speedbar-button ((t (:inherit zenburn-primary-1)))) - '(speedbar-file ((t (:inherit zenburn-primary-2)))) - '(speedbar-directory ((t (:inherit zenburn-primary-5)))) - '(speedbar-tag ((t (:inherit font-lock-function-name)))) - '(speedbar-highlight ((t (:underline t)))) - - '(strokes-char ((t (:inherit font-lock-keyword)))) - - '(todoo-item-header - ((t (:inherit zenburn-primary-1)))) - '(todoo-item-assigned-header - ((t (:inherit zenburn-primary-2)))) - `(todoo-sub-item-header - ((t (:foreground ,zenburn-yellow)))) - - '(tuareg-font-lock-governing - ((t (:inherit zenburn-primary-2)))) - '(tuareg-font-lock-interactive-error - ((t (:inherit font-lock-warning)))) - '(tuareg-font-lock-interactive-output - ((t (:inherit zenburn-primary-3)))) - '(tuareg-font-lock-operator - ((t (:inherit font-lock-operator)))) - - '(w3m-form-button - ((t (:inherit widget-button)))) - '(w3m-form-button-pressed - ((t (:inherit widget-button-pressed)))) - '(w3m-form-button-mouse - ((t (:inherit widget-button-pressed)))) - '(w3m-tab-unselected - ((t (:box (:line-width 1 :style released-button))))) - '(w3m-tab-selected - ((t (:box (:line-width 1 :style pressed-button))))) - '(w3m-tab-unselected-retrieving - ((t (:inherit (w3m-tab-unselected widget-inactive))))) - '(w3m-tab-selected-retrieving - ((t (:inherit (w3m-tab-selected widget-inactive))))) - '(w3m-tab-background - ((t (:inherit zenburn-highlight-subtle)))) - '(w3m-anchor - ((t (:inherit zenburn-primary-1)))) - '(w3m-arrived-anchor - ((t (:inherit zenburn-primary-2)))) - '(w3m-image - ((t (:inherit zenburn-primary-4)))) - '(w3m-form - ((t (:inherit widget-field))))) - - (zenburn-make-face-alias-clauses - '(Buffer-menu-buffer-face - apt-utils-broken-face - apt-utils-description-face - apt-utils-field-contents-face - apt-utils-field-keyword-face - apt-utils-normal-package-face - apt-utils-summary-face - apt-utils-version-face - apt-utils-virtual-package-face - breakpoint-disabled-bitmap-face - breakpoint-enabled-bitmap-face - calendar-today-face - change-log-date-face - compilation-info-face - compilation-warning-face - cua-rectangle-face - custom-button-face - custom-button-pressed-face - custom-changed-face - custom-comment-face - custom-comment-tag-face - custom-documentation-face - custom-face-tag-face - custom-group-tag-face - custom-group-tag-face-1 - custom-invalid-face - custom-modified-face - custom-rogue-face - custom-saved-face - custom-set-face - custom-state-face - custom-variable-button-face - custom-variable-tag-face - diary-face - dictionary-button-face - dictionary-reference-face - dictionary-word-entry-face - diff-added-face - diff-context-face - diff-file-header-face - diff-header-face - diff-hunk-header-face - diff-index-face - diff-removed-face - emms-pbi-current-face - emms-pbi-mark-marked-face - emms-pbi-song-face - erc-action-face - erc-bold-face - erc-current-nick-face - erc-dangerous-host-face - erc-default-face - erc-direct-msg-face - erc-error-face - erc-fool-face - erc-highlight-face - erc-input-face - erc-keyword-face - erc-nick-default-face - erc-nick-msg-face - erc-notice-face - erc-pal-face - erc-prompt-face - erc-timestamp-face - erc-underline-face - eshell-ls-archive-face - eshell-ls-backup-face - eshell-ls-clutter-face - eshell-ls-directory-face - eshell-ls-executable-face - eshell-ls-missing-face - eshell-ls-product-face - eshell-ls-special-face - eshell-ls-symlink-face - eshell-ls-unreadable-face - eshell-prompt-face - fancy-widget-button-face - fancy-widget-button-highlight-face - fancy-widget-button-pressed-face - fancy-widget-button-pressed-highlight-face - fancy-widget-documentation-face - fancy-widget-field-face - fancy-widget-inactive-face - fancy-widget-single-line-field-face - font-latex-bold-face - font-latex-sedate-face - font-latex-title-4-face - font-latex-warning-face - font-lock-builtin-face - font-lock-comment-delimiter-face - font-lock-comment-face - font-lock-constant-face - font-lock-doc-face - font-lock-function-name-face - font-lock-keyword-face - font-lock-negation-char-face - font-lock-operator-face - font-lock-preprocessor-face - font-lock-pseudo-keyword-face - font-lock-string-face - font-lock-type-face - font-lock-variable-name-face - font-lock-warning-face - gnus-cite-face-1 - gnus-cite-face-10 - gnus-cite-face-11 - gnus-cite-face-2 - gnus-cite-face-3 - gnus-cite-face-4 - gnus-cite-face-5 - gnus-cite-face-6 - gnus-cite-face-7 - gnus-cite-face-8 - gnus-cite-face-9 - gnus-group-mail-1-empty-face - gnus-group-mail-2-empty-face - gnus-group-mail-3-empty-face - gnus-group-mail-3-face - gnus-group-news-1-empty-face - gnus-group-news-2-empty-face - gnus-group-news-3-empty-face - gnus-header-content-face - gnus-header-from-face - gnus-header-name-face - gnus-header-newsgroups-face - gnus-header-subject-face - gnus-signature-face - gnus-summary-cancelled-face - gnus-summary-high-ancient-face - gnus-summary-high-read-face - gnus-summary-high-ticked-face - gnus-summary-high-unread-face - gnus-summary-low-ancient-face - gnus-summary-low-read-face - gnus-summary-low-ticked-face - gnus-summary-low-unread-face - gnus-summary-normal-ancient-face - gnus-summary-normal-read-face - gnus-summary-normal-ticked-face - gnus-summary-normal-unread-face - gnus-summary-selected-face - highlight-current-line-face - holiday-face - ibuffer-deletion-face - ibuffer-help-buffer-face - ibuffer-marked-face - ibuffer-special-buffer-face - ido-first-match-face - ido-only-match-face - ido-subdir-face - imaxima-latex-error-face - isearch-lazy-highlight-face - jde-java-font-lock-constant-face - jde-java-font-lock-doc-tag-face - jde-java-font-lock-link-face - jde-java-font-lock-modifier-face - jde-java-font-lock-number-face - jde-java-font-lock-operator-face - jde-java-font-lock-package-face - keywiz-command-face - keywiz-right-face - keywiz-wrong-face - makefile-shell-face - makefile-space-face - message-cited-text-face - message-header-cc-face - message-header-from-face - message-header-name-face - message-header-newsgroups-face - message-header-other-face - message-header-subject-face - message-header-to-face - message-header-xheader-face - message-mml-face - message-separator-face - mtorus-highlight-face - mtorus-notify-highlight-face - nxml-attribute-colon-face - nxml-attribute-local-name-face - nxml-attribute-prefix-face - nxml-attribute-value-delimiter-face - nxml-attribute-value-face - nxml-cdata-section-CDATA-face - nxml-cdata-section-content-face - nxml-cdata-section-delimiter-face - nxml-char-ref-delimiter-face - nxml-char-ref-number-face - nxml-comment-content-face - nxml-comment-delimiter-face - nxml-delimited-data-face - nxml-delimiter-face - nxml-element-colon-face - nxml-element-local-name-face - nxml-element-prefix-face - nxml-entity-ref-delimiter-face - nxml-entity-ref-name-face - nxml-name-face - nxml-namespace-attribute-colon-face - nxml-namespace-attribute-prefix-face - nxml-namespace-attribute-xmlns-face - nxml-processing-instruction-content-face - nxml-processing-instruction-delimiter-face - nxml-processing-instruction-target-face - nxml-ref-face - nxml-tag-delimiter-face - nxml-tag-slash-face - nxml-text-face - org-agenda-date-today-face - org-agenda-structure-face - org-archived-face - org-column-face - ;org-checkbox-face - org-date-face - org-deadline-announce-face - org-done-face - org-formula-face - org-headline-done-face - org-hide-face - org-level-1-face - org-level-2-face - org-level-3-face - org-level-4-face - org-level-5-face - org-level-6-face - org-level-7-face - org-level-8-face - org-link-face - ;org-priority-face - org-scheduled-face - org-scheduled-previously-face - org-scheduled-today-face - org-special-keyword-face - org-table-face - org-tag-face - org-time-grid-face - org-todo-face - org-upcoming-deadline-face - org-warning-face - paren-face - plain-widget-button-face - plain-widget-button-pressed-face - plain-widget-documentation-face - plain-widget-field-face - plain-widget-inactive-face - plain-widget-single-line-field-face - setnu-line-number-face - show-paren-match-face - show-paren-mismatch-face - speedbar-button-face - speedbar-directory-face - speedbar-file-face - speedbar-highlight-face - speedbar-tag-face - strokes-char-face - todoo-item-assigned-header-face - todoo-item-header-face - todoo-sub-item-header-face - tuareg-font-lock-governing-face - tuareg-font-lock-interactive-error-face - tuareg-font-lock-interactive-output-face - tuareg-font-lock-operator-face - w3m-anchor-face - w3m-arrived-anchor-face - w3m-form-button-face - w3m-form-button-mouse-face - w3m-form-button-pressed-face - w3m-form-face - w3m-image-face - w3m-tab-background-face - w3m-tab-selected-face - w3m-tab-selected-retrieving-face - w3m-tab-unselected-face - w3m-tab-unselected-retrieving-face - widget-button-face - widget-button-highlight-face - widget-button-pressed-face - widget-button-pressed-highlight-face - widget-documentation-face - widget-field-face - widget-inactive-face - widget-single-line-field-face)) - ))) - -(defalias 'zenburn #'color-theme-zenburn) - -(provide 'zenburn) - -;; Local Variables: -;; time-stamp-format: "%:y-%02m-%02d %02H:%02M" -;; time-stamp-start: "Updated: " -;; time-stamp-end: "$" -;; End: - -;;; zenburn.el ends here. |