Remove some packages
I never actually used them, and some of them were installed only as dependencies.
This commit is contained in:
Gergely Polonkai
parent
5feea2e7f0
commit
27a15c5513
@ -1,53 +0,0 @@
|
|||||||
;;; buffer-move-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "buffer-move" "buffer-move.el" (22387 29375
|
|
||||||
;;;;;; 754161 271000))
|
|
||||||
;;; Generated autoloads from buffer-move.el
|
|
||||||
|
|
||||||
(autoload 'buf-move-up "buffer-move" "\
|
|
||||||
Swap the current buffer and the buffer above the split.
|
|
||||||
If there is no split, ie now window above the current one, an
|
|
||||||
error is signaled.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'buf-move-down "buffer-move" "\
|
|
||||||
Swap the current buffer and the buffer under the split.
|
|
||||||
If there is no split, ie now window under the current one, an
|
|
||||||
error is signaled.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'buf-move-left "buffer-move" "\
|
|
||||||
Swap the current buffer and the buffer on the left of the split.
|
|
||||||
If there is no split, ie now window on the left of the current
|
|
||||||
one, an error is signaled.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'buf-move-right "buffer-move" "\
|
|
||||||
Swap the current buffer and the buffer on the right of the split.
|
|
||||||
If there is no split, ie now window on the right of the current
|
|
||||||
one, an error is signaled.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'buf-move "buffer-move" "\
|
|
||||||
Begin moving the current buffer to different windows.
|
|
||||||
|
|
||||||
Use the arrow keys to move in the desired direction. Pressing
|
|
||||||
any other key exits this function.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; buffer-move-autoloads.el ends here
|
|
||||||
@ -1 +0,0 @@
|
|||||||
(define-package "buffer-move" "20160615.1103" "easily swap buffers" 'nil :url "https://github.com/lukhas/buffer-move" :keywords '("lisp" "convenience"))
|
|
||||||
@ -1,179 +0,0 @@
|
|||||||
;;; buffer-move.el --- easily swap buffers
|
|
||||||
|
|
||||||
;; Copyright (C) 2004-2014 Lucas Bonnet <lucas@rincevent.net>
|
|
||||||
;; Copyright (C) 2014 Mathis Hofer <mathis@fsfe.org>
|
|
||||||
;; Copyright (C) 2014-2015 Geyslan G. Bem <geyslan@gmail.com>
|
|
||||||
|
|
||||||
;; Authors: Lucas Bonnet <lucas@rincevent.net>
|
|
||||||
;; Geyslan G. Bem <geyslan@gmail.com>
|
|
||||||
;; Mathis Hofer <mathis@fsfe.org>
|
|
||||||
;; Keywords: lisp,convenience
|
|
||||||
;; Package-Version: 20160615.1103
|
|
||||||
;; Version: 0.6.2
|
|
||||||
;; URL : https://github.com/lukhas/buffer-move
|
|
||||||
|
|
||||||
;; This program is free software; you can redistribute it and/or
|
|
||||||
;; modify it under the terms of the GNU General Public License
|
|
||||||
;; as published by the Free Software Foundation; either version 2
|
|
||||||
;; of the License, or (at your option) any later version.
|
|
||||||
|
|
||||||
;; This program is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with this program; if not, write to the Free Software
|
|
||||||
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
||||||
;; 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; This file is for lazy people wanting to swap buffers without
|
|
||||||
;; typing C-x b on each window. This is useful when you have :
|
|
||||||
|
|
||||||
;; +--------------+-------------+
|
|
||||||
;; | | |
|
|
||||||
;; | #emacs | #gnus |
|
|
||||||
;; | | |
|
|
||||||
;; +--------------+-------------+
|
|
||||||
;; | |
|
|
||||||
;; | .emacs |
|
|
||||||
;; | |
|
|
||||||
;; +----------------------------+
|
|
||||||
|
|
||||||
;; and you want to have :
|
|
||||||
|
|
||||||
;; +--------------+-------------+
|
|
||||||
;; | | |
|
|
||||||
;; | #gnus | .emacs |
|
|
||||||
;; | | |
|
|
||||||
;; +--------------+-------------+
|
|
||||||
;; | |
|
|
||||||
;; | #emacs |
|
|
||||||
;; | |
|
|
||||||
;; +----------------------------+
|
|
||||||
|
|
||||||
;; With buffer-move, just go in #gnus, do buf-move-left, go to #emacs
|
|
||||||
;; (which now should be on top right) and do buf-move-down.
|
|
||||||
|
|
||||||
;; To use it, simply put a (require 'buffer-move) in your ~/.emacs and
|
|
||||||
;; define some keybindings. For example, i use :
|
|
||||||
|
|
||||||
;; (global-set-key (kbd "<C-S-up>") 'buf-move-up)
|
|
||||||
;; (global-set-key (kbd "<C-S-down>") 'buf-move-down)
|
|
||||||
;; (global-set-key (kbd "<C-S-left>") 'buf-move-left)
|
|
||||||
;; (global-set-key (kbd "<C-S-right>") 'buf-move-right)
|
|
||||||
|
|
||||||
;; Alternatively, you may let the current window switch back to the previous
|
|
||||||
;; buffer, instead of swapping the buffers of both windows. Set the
|
|
||||||
;; following customization variable to 'move to activate this behavior:
|
|
||||||
|
|
||||||
;; (setq buffer-move-behavior 'move)
|
|
||||||
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
|
|
||||||
(require 'windmove)
|
|
||||||
|
|
||||||
|
|
||||||
(defconst buffer-move-version "0.6.1"
|
|
||||||
"Version of buffer-move.el")
|
|
||||||
|
|
||||||
(defgroup buffer-move nil
|
|
||||||
"Swap buffers without typing C-x b on each window"
|
|
||||||
:group 'tools)
|
|
||||||
|
|
||||||
(defcustom buffer-move-behavior 'swap
|
|
||||||
"If set to 'swap (default), the buffers will be exchanged
|
|
||||||
(i.e. swapped), if set to 'move, the current window is switch back to the
|
|
||||||
previously displayed buffer (i.e. the buffer is moved)."
|
|
||||||
:group 'buffer-move
|
|
||||||
:type 'symbol)
|
|
||||||
|
|
||||||
(defcustom buffer-move-stay-after-swap nil
|
|
||||||
"If set to non-nil, point will stay in the current window
|
|
||||||
so it will not be moved when swapping buffers. This setting
|
|
||||||
only has effect if `buffer-move-behavior' is set to 'swap."
|
|
||||||
:group 'buffer-move
|
|
||||||
:type 'boolean)
|
|
||||||
|
|
||||||
(defun buf-move-to (direction)
|
|
||||||
"Helper function to move the current buffer to the window in the given
|
|
||||||
direction (with must be 'up, 'down', 'left or 'right). An error is
|
|
||||||
thrown, if no window exists in this direction."
|
|
||||||
(let* ((other-win (windmove-find-other-window direction))
|
|
||||||
(buf-this-buf (window-buffer (selected-window))))
|
|
||||||
(if (null other-win)
|
|
||||||
(error "No window in this direction")
|
|
||||||
(if (window-dedicated-p other-win)
|
|
||||||
(error "The window in this direction is dedicated"))
|
|
||||||
(if (string-match "^ \\*Minibuf" (buffer-name (window-buffer other-win)))
|
|
||||||
(error "The window in this direction is the Minibuf"))
|
|
||||||
(if (eq buffer-move-behavior 'move)
|
|
||||||
;; switch selected window to previous buffer (moving)
|
|
||||||
(switch-to-prev-buffer (selected-window))
|
|
||||||
|
|
||||||
;; switch selected window to buffer of other window (swapping)
|
|
||||||
(set-window-buffer (selected-window) (window-buffer other-win))
|
|
||||||
)
|
|
||||||
|
|
||||||
;; switch other window to this buffer
|
|
||||||
(set-window-buffer other-win buf-this-buf)
|
|
||||||
|
|
||||||
(when (or (null buffer-move-stay-after-swap)
|
|
||||||
(eq buffer-move-behavior 'move))
|
|
||||||
(select-window other-win)))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun buf-move-up ()
|
|
||||||
"Swap the current buffer and the buffer above the split.
|
|
||||||
If there is no split, ie now window above the current one, an
|
|
||||||
error is signaled."
|
|
||||||
;; "Switches between the current buffer, and the buffer above the
|
|
||||||
;; split, if possible."
|
|
||||||
(interactive)
|
|
||||||
(buf-move-to 'up))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun buf-move-down ()
|
|
||||||
"Swap the current buffer and the buffer under the split.
|
|
||||||
If there is no split, ie now window under the current one, an
|
|
||||||
error is signaled."
|
|
||||||
(interactive)
|
|
||||||
(buf-move-to 'down))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun buf-move-left ()
|
|
||||||
"Swap the current buffer and the buffer on the left of the split.
|
|
||||||
If there is no split, ie now window on the left of the current
|
|
||||||
one, an error is signaled."
|
|
||||||
(interactive)
|
|
||||||
(buf-move-to 'left))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun buf-move-right ()
|
|
||||||
"Swap the current buffer and the buffer on the right of the split.
|
|
||||||
If there is no split, ie now window on the right of the current
|
|
||||||
one, an error is signaled."
|
|
||||||
(interactive)
|
|
||||||
(buf-move-to 'right))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun buf-move ()
|
|
||||||
"Begin moving the current buffer to different windows.
|
|
||||||
|
|
||||||
Use the arrow keys to move in the desired direction. Pressing
|
|
||||||
any other key exits this function."
|
|
||||||
(interactive)
|
|
||||||
(let ((map (make-sparse-keymap)))
|
|
||||||
(dolist (x '(("<up>" . buf-move-up)
|
|
||||||
("<left>" . buf-move-left)
|
|
||||||
("<down>" . buf-move-down)
|
|
||||||
("<right>" . buf-move-right)))
|
|
||||||
(define-key map (read-kbd-macro (car x)) (cdr x)))
|
|
||||||
(set-transient-map map t)))
|
|
||||||
|
|
||||||
(provide 'buffer-move)
|
|
||||||
;;; buffer-move.el ends here
|
|
||||||
@ -1,22 +0,0 @@
|
|||||||
;;; django-manage-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "django-manage" "django-manage.el" (22501 5677
|
|
||||||
;;;;;; 768491 198000))
|
|
||||||
;;; Generated autoloads from django-manage.el
|
|
||||||
|
|
||||||
(autoload 'django-manage "django-manage" "\
|
|
||||||
Minor mode for handling Django's manage.py
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; django-manage-autoloads.el ends here
|
|
||||||
@ -1 +0,0 @@
|
|||||||
(define-package "django-manage" "20160818.1912" "Django minor mode for commanding manage.py" '((hydra "0.13.2")) :keywords '("languages"))
|
|
||||||
@ -1,319 +0,0 @@
|
|||||||
;;; django-manage.el --- Django minor mode for commanding manage.py
|
|
||||||
|
|
||||||
;; Copyright (C) 2015 Daniel Gopar
|
|
||||||
|
|
||||||
;; Author: Daniel Gopar <gopardaniel@yahoo.com>
|
|
||||||
;; Package-Requires: ((hydra "0.13.2"))
|
|
||||||
;; Package-Version: 20160818.1912
|
|
||||||
;; Version: 0.1
|
|
||||||
;; Keywords: languages
|
|
||||||
|
|
||||||
;; This file is NOT part of GNU Emacs.
|
|
||||||
|
|
||||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation, either version 3 of the License, or
|
|
||||||
;; (at your option) any later version.
|
|
||||||
|
|
||||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; 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, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; Simple package to be to be able to control `manage.py', the standard
|
|
||||||
;; file that every Django project comes with. You are able to call any
|
|
||||||
;; command with `django-manage-command' plus it comes with code
|
|
||||||
;; completion so third party plugins will also be completed.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(condition-case nil
|
|
||||||
(require 'python)
|
|
||||||
(error
|
|
||||||
(require 'python-mode)))
|
|
||||||
(require 'hydra)
|
|
||||||
|
|
||||||
(defcustom django-manage-shell-preference 'pyshell
|
|
||||||
"What shell to use."
|
|
||||||
:type 'symbol
|
|
||||||
:options '(eshell term pyshell)
|
|
||||||
:group 'shell)
|
|
||||||
|
|
||||||
(defcustom django-manage-server-ipaddr "127.0.0.1"
|
|
||||||
"What address Django will use when running the dev server."
|
|
||||||
:type 'string
|
|
||||||
:group 'server)
|
|
||||||
|
|
||||||
(defcustom django-manage-server-port "8000"
|
|
||||||
"What port Django will use when running the dev server."
|
|
||||||
:type 'string
|
|
||||||
:group 'server)
|
|
||||||
|
|
||||||
(defcustom django-manage-prompt-for-command nil
|
|
||||||
"When non-nil will ask for confirmation on command.
|
|
||||||
Will affect every function other than `django-manage-command'."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'django-manage)
|
|
||||||
|
|
||||||
(defcustom django-manage-root ""
|
|
||||||
"The directory where 'manage.py' lives."
|
|
||||||
:type 'string
|
|
||||||
:group 'django-manage)
|
|
||||||
(make-local-variable 'django-manage-root)
|
|
||||||
|
|
||||||
(defun django-manage-root ()
|
|
||||||
"Return the root directory of Django project."
|
|
||||||
;; Check if projectile is in use, and if it is. Return root directory
|
|
||||||
(if (not (string= django-manage-root ""))
|
|
||||||
django-manage-root
|
|
||||||
(if (fboundp 'projectile-project-root)
|
|
||||||
(projectile-project-root)
|
|
||||||
;; Try looking for the directory holding 'manage.py'
|
|
||||||
(locate-dominating-file default-directory "manage.py"))))
|
|
||||||
|
|
||||||
(defun django-manage-python-command ()
|
|
||||||
"Return Python version to use with args."
|
|
||||||
(if (boundp 'python-shell-interpreter)
|
|
||||||
(concat python-shell-interpreter " " python-shell-interpreter-args)
|
|
||||||
;; For old python.el
|
|
||||||
(mapconcat 'identity (cons python-python-command python-python-command-args) " ")))
|
|
||||||
|
|
||||||
(defun django-manage-get-commands ()
|
|
||||||
"Return list of django commands."
|
|
||||||
(let ((help-output
|
|
||||||
(shell-command-to-string (concat python-shell-interpreter " "
|
|
||||||
(shell-quote-argument (django-manage-root)) "manage.py -h"))))
|
|
||||||
(setq dj-commands-str
|
|
||||||
(with-temp-buffer
|
|
||||||
(progn
|
|
||||||
(insert help-output)
|
|
||||||
(beginning-of-buffer)
|
|
||||||
(delete-region (point) (search-forward "Available subcommands:" nil nil nil))
|
|
||||||
;; cleanup [auth] and stuff
|
|
||||||
(beginning-of-buffer)
|
|
||||||
(save-excursion
|
|
||||||
(replace-regexp "\\[.*\\]" ""))
|
|
||||||
(buffer-string))))
|
|
||||||
;; get a list of commands from the output of manage.py -h
|
|
||||||
;; What would be the pattern to optimize this ?
|
|
||||||
(setq dj-commands-str (s-split "\n" dj-commands-str))
|
|
||||||
(setq dj-commands-str (-remove (lambda (x) (string= x "")) dj-commands-str))
|
|
||||||
(setq dj-commands-str (mapcar (lambda (x) (s-trim x)) dj-commands-str))
|
|
||||||
(sort dj-commands-str 'string-lessp)))
|
|
||||||
|
|
||||||
(defun django-manage-command (command &optional no-prompt)
|
|
||||||
"Allow to run any `manage.py' command.
|
|
||||||
Argument COMMAND command for django to run.
|
|
||||||
Optional Argument NO-PROMPT if non-nil will *not* ask if you wish to pass extra arguments."
|
|
||||||
;; nil nil: enable user to exit with any command. Still, he can not edit a completed choice.
|
|
||||||
(interactive (list (completing-read "Command: " (django-manage-get-commands) nil nil)))
|
|
||||||
(if (not no-prompt)
|
|
||||||
;; Now ask to edit the command. How to do the two actions at once ?
|
|
||||||
(setq command (read-shell-command "Run command like this: " command)))
|
|
||||||
(compile (concat (django-manage-python-command) " "
|
|
||||||
(shell-quote-argument (django-manage-root)) "manage.py " command)))
|
|
||||||
|
|
||||||
(defun django-manage-makemigrations (&optional app-name)
|
|
||||||
"Run \"makemigrations app-name\", will prompt for \"app-name\".
|
|
||||||
You can leave blank to simply run \"makemigrations\".
|
|
||||||
To choose arguments call `django-manage-command'.
|
|
||||||
Optional argument APP-NAME name of django app create migrations."
|
|
||||||
(interactive "sName: ")
|
|
||||||
(django-manage-command (concat "makemigrations " app-name)
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-flush ()
|
|
||||||
"Run \"flush --noinput\". To choose arguments call `django-manage-command'."
|
|
||||||
(interactive)
|
|
||||||
(django-manage-command "flush --noinput"
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-runserver ()
|
|
||||||
"Start the development server. To change what address and port to use,
|
|
||||||
customize `django-manage-server-ipaddr' and `django-manage-server-port'
|
|
||||||
If you want to pass arguments, then call `django-manage-command'"
|
|
||||||
(interactive)
|
|
||||||
(let ((parent-dir (file-name-base (substring (django-manage-root) 0 -1))))
|
|
||||||
(compile (concat (django-manage-python-command) " "
|
|
||||||
(shell-quote-argument (django-manage-root)) "manage.py runserver "
|
|
||||||
django-manage-server-ipaddr ":" django-manage-server-port))
|
|
||||||
(with-current-buffer "*compilation*"
|
|
||||||
(rename-buffer (format "*runserver[%s]*" parent-dir)))))
|
|
||||||
|
|
||||||
(defun django-manage-migrate ()
|
|
||||||
"Run \"migrate\". To choose arguments call `django-manage-command'."
|
|
||||||
(interactive)
|
|
||||||
(django-manage-command "migrate"
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-assets-rebuild ()
|
|
||||||
"Run \"assets rebuild\". To choose arguments call `django-manage-command'."
|
|
||||||
(interactive)
|
|
||||||
(django-manage-command "assets rebuild"
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-startapp (name)
|
|
||||||
"Run \"startapp name\". Will prompt for name of app.
|
|
||||||
To choose arguments call `django-manage-command'.
|
|
||||||
Argument NAME name of app to create."
|
|
||||||
(interactive "sName:")
|
|
||||||
(django-manage-command (concat "startapp " name)
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-makemessages ()
|
|
||||||
"Run \"makemessages --all --symlinks\".
|
|
||||||
To pass arguments call `django-manage-command'."
|
|
||||||
(interactive)
|
|
||||||
(django-manage-command "makemessages --all --symlinks"
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-compilemessages ()
|
|
||||||
"Run \"compilemessages\". To pass arguments call `django-manage-command'."
|
|
||||||
(interactive)
|
|
||||||
(django-manage-command "compilemessages"
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage-test (name)
|
|
||||||
"Run \"test name\". Will prompt for Django app name to test.
|
|
||||||
To pass arguments call `django-manage-command'.
|
|
||||||
Argument NAME name of django app to test."
|
|
||||||
(interactive "sTest app:")
|
|
||||||
(django-manage-command (concat "test " name)
|
|
||||||
(not django-manage-prompt-for-command)))
|
|
||||||
|
|
||||||
(defun django-manage--prep-shell (pref-shell)
|
|
||||||
"Prepare the shell with users preference.
|
|
||||||
Argument PREF-SHELL users shell of choice"
|
|
||||||
;; If a preexisting shell buffer exists return that one. If not create it
|
|
||||||
(let* ((parent-dir (file-name-base (substring (django-manage-root) 0 -1)))
|
|
||||||
(default-directory (django-manage-root))
|
|
||||||
(buffer-shell-name
|
|
||||||
(format (if (string= pref-shell "shell") "*Django Shell[%s]*" "*Django DBshell[%s]*") parent-dir)))
|
|
||||||
;; If it exists return it
|
|
||||||
(if (get-buffer buffer-shell-name)
|
|
||||||
(switch-to-buffer buffer-shell-name)
|
|
||||||
;; Shell didn't exist, so let's create it
|
|
||||||
(if (eq 'term django-manage-shell-preference)
|
|
||||||
(term (concat (django-manage-python-command) " "
|
|
||||||
(shell-quote-argument (django-manage-root)) "manage.py " pref-shell)))
|
|
||||||
(if (eq 'eshell django-manage-shell-preference)
|
|
||||||
(progn
|
|
||||||
(unless (get-buffer eshell-buffer-name)
|
|
||||||
(eshell))
|
|
||||||
(insert (concat (django-manage-python-command) " "
|
|
||||||
(shell-quote-argument (django-manage-root)) "manage.py " pref-shell))
|
|
||||||
(eshell-send-input)))
|
|
||||||
(if (eq 'pyshell django-manage-shell-preference)
|
|
||||||
(let ((setup-code "os.environ.setdefault(\"DJANGO_SETTINGS_MODULE\", \"%s.settings\")")
|
|
||||||
(cmd ";from django.core.management import execute_from_command_line")
|
|
||||||
(exe (if (string= pref-shell "shell")
|
|
||||||
";import django;django.setup()"
|
|
||||||
(format ";execute_from_command_line(['manage.py', '%s'])" pref-shell))))
|
|
||||||
(run-python (python-shell-parse-command))
|
|
||||||
(python-shell-send-string (concat (format setup-code parent-dir) cmd exe))
|
|
||||||
(switch-to-buffer (python-shell-get-buffer))))
|
|
||||||
(rename-buffer buffer-shell-name))))
|
|
||||||
|
|
||||||
(defun django-manage-shell ()
|
|
||||||
"Start Python shell with Django already configured."
|
|
||||||
(interactive)
|
|
||||||
(django-manage--prep-shell "shell"))
|
|
||||||
|
|
||||||
(defun django-manage-dbshell ()
|
|
||||||
"Start Database shell."
|
|
||||||
(interactive)
|
|
||||||
(django-manage--prep-shell "dbshell"))
|
|
||||||
|
|
||||||
(defun django-manage-insert-transpy (from to &optional buffer)
|
|
||||||
"Wraps highlighted region in _(...) for i18n.
|
|
||||||
Argument FROM start point TO wrap.
|
|
||||||
Optional argument BUFFER end point to wrap."
|
|
||||||
;; From http://garage.pimentech.net/libcommonDjango_django_emacs/
|
|
||||||
;; Modified a little
|
|
||||||
(interactive "*r")
|
|
||||||
(save-excursion
|
|
||||||
(save-restriction
|
|
||||||
(narrow-to-region from to)
|
|
||||||
(goto-char from)
|
|
||||||
(iso-iso2sgml from to)
|
|
||||||
(insert "_(")
|
|
||||||
(goto-char (point-max))
|
|
||||||
(insert ")")
|
|
||||||
(point-max))))
|
|
||||||
|
|
||||||
(defhydra django-manage-hydra (:color blue
|
|
||||||
:hint nil)
|
|
||||||
"
|
|
||||||
Manage.py
|
|
||||||
--------------------------------------------------
|
|
||||||
|
|
||||||
_mm_: Enter manage.py commnand _r_: runserver _f_: Flush _t_: Run rest
|
|
||||||
_ma_: Makemigrations _sa_: Start new app _i_: Insert transpy
|
|
||||||
_mg_: Migrate _ss_: Run shell _a_: Rebuild Assets
|
|
||||||
_me_: Make messages _sd_: Run DB Shell _c_: Compile messages
|
|
||||||
|
|
||||||
_q_: Cancel
|
|
||||||
|
|
||||||
"
|
|
||||||
("mm" django-manage-command)
|
|
||||||
("ma" django-manage-makemigrations)
|
|
||||||
("mg" django-manage-migrate)
|
|
||||||
("me" django-manage-makemessages)
|
|
||||||
|
|
||||||
("r" django-manage-runserver "Start server")
|
|
||||||
("sa" django-manage-startapp)
|
|
||||||
("ss" django-manage-shell)
|
|
||||||
("sd" django-manage-dbshell)
|
|
||||||
|
|
||||||
("f" django-manage-flush)
|
|
||||||
("a" django-manage-assets-rebuild)
|
|
||||||
("c" django-manage-compilemessages)
|
|
||||||
("t" django-manage-test)
|
|
||||||
|
|
||||||
("i" django-manage-insert-transpy)
|
|
||||||
("q" nil "cancel"))
|
|
||||||
|
|
||||||
(defvar django-manage-map
|
|
||||||
(let ((map (make-keymap)))
|
|
||||||
(define-key map (kbd "C-c C-x") 'django-manage-hydra/body)
|
|
||||||
map))
|
|
||||||
|
|
||||||
(defun django-manage-setup ()
|
|
||||||
"Determine whether to start minor mode or not."
|
|
||||||
(when (and (stringp buffer-file-name)
|
|
||||||
(locate-dominating-file default-directory "manage.py"))
|
|
||||||
(django-manage)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(define-minor-mode django-manage
|
|
||||||
"Minor mode for handling Django's manage.py"
|
|
||||||
:lighter " Manage"
|
|
||||||
:keymap django-manage-map)
|
|
||||||
|
|
||||||
(easy-menu-define django-manage-menu django-manage-map "Django menu"
|
|
||||||
'("Django"
|
|
||||||
["Start an app" django-manage-startapp t]
|
|
||||||
["Run tests" django-manage-test t]
|
|
||||||
["Make migrations" django-manage-makemigrations t]
|
|
||||||
["Flush database" django-manage-flush t]
|
|
||||||
["Runserver" django-manage-runserver t]
|
|
||||||
["Run database migrations" django-manage-migrate t]
|
|
||||||
["Rebuild assets" django-manage-assets-rebuild t]
|
|
||||||
["Make translations" django-manage-makemessages t]
|
|
||||||
["Compile translations" django-manage-compilemessages t]
|
|
||||||
["Open Python shell" django-manage-shell t]
|
|
||||||
["Open database shell" django-manage-dbshell t]
|
|
||||||
["Run other command" django-manage-command t]
|
|
||||||
"-"
|
|
||||||
["Insert translation mark" django-manage-insert-transpy t]))
|
|
||||||
|
|
||||||
(easy-menu-add django-manage-menu django-manage-map)
|
|
||||||
|
|
||||||
(provide 'django-manage)
|
|
||||||
|
|
||||||
;;; django-manage.el ends here
|
|
||||||
@ -1,159 +0,0 @@
|
|||||||
;;; erlang-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "erlang" "erlang.el" (22523 21259 84519 501000))
|
|
||||||
;;; Generated autoloads from erlang.el
|
|
||||||
|
|
||||||
(autoload 'erlang-mode "erlang" "\
|
|
||||||
Major mode for editing Erlang source files in Emacs.
|
|
||||||
It knows about syntax and comment, it can indent code, it is capable
|
|
||||||
of fontifying the source file, the TAGS commands are aware of Erlang
|
|
||||||
modules, and the Erlang man pages can be accessed.
|
|
||||||
|
|
||||||
Should this module, \"erlang.el\", be installed properly, Erlang mode
|
|
||||||
is activated whenever an Erlang source or header file is loaded into
|
|
||||||
Emacs. To indicate this, the mode line should contain the word
|
|
||||||
\"Erlang\".
|
|
||||||
|
|
||||||
The main feature of Erlang mode is indentation, press TAB and the
|
|
||||||
current line will be indented correctly.
|
|
||||||
|
|
||||||
Comments starting with only one `%' are indented to the column stored
|
|
||||||
in the variable `comment-column'. Comments starting with two `%':s
|
|
||||||
are indented with the same indentation as code. Comments starting
|
|
||||||
with at least three `%':s are indented to the first column.
|
|
||||||
|
|
||||||
However, Erlang mode contains much more, this is a list of the most
|
|
||||||
useful commands:
|
|
||||||
TAB - Indent the line.
|
|
||||||
C-c C-q - Indent current function.
|
|
||||||
M-; - Create a comment at the end of the line.
|
|
||||||
M-q - Fill a comment, i.e. wrap lines so that they (hopefully)
|
|
||||||
will look better.
|
|
||||||
M-a - Goto the beginning of an Erlang clause.
|
|
||||||
M-C-a - Ditto for function.
|
|
||||||
M-e - Goto the end of an Erlang clause.
|
|
||||||
M-C-e - Ditto for function.
|
|
||||||
M-h - Mark current Erlang clause.
|
|
||||||
M-C-h - Ditto for function.
|
|
||||||
C-c C-z - Start, or switch to, an inferior Erlang shell.
|
|
||||||
C-c C-k - Compile current file.
|
|
||||||
C-x ` - Next error.
|
|
||||||
, - Electric comma.
|
|
||||||
; - Electric semicolon.
|
|
||||||
|
|
||||||
Erlang mode check the name of the file against the module name when
|
|
||||||
saving, whenever a mismatch occurs Erlang mode offers to modify the
|
|
||||||
source.
|
|
||||||
|
|
||||||
The variable `erlang-electric-commands' controls the electric
|
|
||||||
commands. To deactivate all of them, set it to nil.
|
|
||||||
|
|
||||||
There exists a large number of commands and variables in the Erlang
|
|
||||||
module. Please press `M-x apropos RET erlang RET' to see a complete
|
|
||||||
list. Press `C-h f name-of-function RET' and `C-h v name-of-variable
|
|
||||||
RET'to see the full description of functions and variables,
|
|
||||||
respectively.
|
|
||||||
|
|
||||||
On entry to this mode the contents of the hook `erlang-mode-hook' is
|
|
||||||
executed.
|
|
||||||
|
|
||||||
Please see the beginning of the file `erlang.el' for more information
|
|
||||||
and examples of hooks.
|
|
||||||
|
|
||||||
Other commands:
|
|
||||||
\\{erlang-mode-map}
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(dolist (r '("\\.erl$" "\\.app\\.src$" "\\.escript" "\\.hrl$" "\\.xrl$" "\\.yrl" "/ebin/.+\\.app")) (add-to-list 'auto-mode-alist (cons r 'erlang-mode)))
|
|
||||||
|
|
||||||
(autoload 'erlang-find-tag "erlang" "\
|
|
||||||
Like `find-tag'. Capable of retrieving Erlang modules.
|
|
||||||
|
|
||||||
Tags can be given on the forms `tag', `module:', `module:tag'.
|
|
||||||
|
|
||||||
\(fn MODTAGNAME &optional NEXT-P REGEXP-P)" t nil)
|
|
||||||
|
|
||||||
(autoload 'erlang-find-tag-other-window "erlang" "\
|
|
||||||
Like `find-tag-other-window' but aware of Erlang modules.
|
|
||||||
|
|
||||||
\(fn TAGNAME &optional NEXT-P REGEXP-P)" t nil)
|
|
||||||
|
|
||||||
(autoload 'erlang-shell "erlang" "\
|
|
||||||
Start a new Erlang shell.
|
|
||||||
|
|
||||||
The variable `erlang-shell-function' decides which method to use,
|
|
||||||
default is to start a new Erlang host. It is possible that, in the
|
|
||||||
future, a new shell on an already running host will be started.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
(autoload 'run-erlang "erlang" "Start a new Erlang shell." t)
|
|
||||||
|
|
||||||
(autoload 'erlang-compile "erlang" "\
|
|
||||||
Compile Erlang module in current buffer.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'inferior-erlang "erlang" "\
|
|
||||||
Run an inferior Erlang.
|
|
||||||
With prefix command, prompt for command to start Erlang with.
|
|
||||||
|
|
||||||
This is just like running Erlang in a normal shell, except that
|
|
||||||
an Emacs buffer is used for input and output.
|
|
||||||
\\<comint-mode-map>
|
|
||||||
The command line history can be accessed with \\[comint-previous-input] and \\[comint-next-input].
|
|
||||||
The history is saved between sessions.
|
|
||||||
|
|
||||||
Entry to this mode calls the functions in the variables
|
|
||||||
`comint-mode-hook' and `erlang-shell-mode-hook' with no arguments.
|
|
||||||
|
|
||||||
The following commands imitate the usual Unix interrupt and
|
|
||||||
editing control characters:
|
|
||||||
\\{erlang-shell-mode-map}
|
|
||||||
|
|
||||||
\(fn &optional COMMAND)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "erlang-edoc" "erlang-edoc.el" (22523 21259
|
|
||||||
;;;;;; 104519 648000))
|
|
||||||
;;; Generated autoloads from erlang-edoc.el
|
|
||||||
|
|
||||||
(autoload 'erlang-edoc-mode "erlang-edoc" "\
|
|
||||||
Toggle Erlang-Edoc mode on or off.
|
|
||||||
With a prefix argument ARG, enable Erlang-Edoc mode if ARG is
|
|
||||||
positive, and disable it otherwise. If called from Lisp, enable
|
|
||||||
the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
|
|
||||||
\\{erlang-edoc-mode-map}
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "erlang-start" "erlang-start.el" (22523 21259
|
|
||||||
;;;;;; 64519 353000))
|
|
||||||
;;; Generated autoloads from erlang-start.el
|
|
||||||
|
|
||||||
(let ((a '("\\.erl\\'" . erlang-mode)) (b '("\\.hrl\\'" . erlang-mode))) (or (assoc (car a) auto-mode-alist) (setq auto-mode-alist (cons a auto-mode-alist))) (or (assoc (car b) auto-mode-alist) (setq auto-mode-alist (cons b auto-mode-alist))))
|
|
||||||
|
|
||||||
(add-to-list 'interpreter-mode-alist (cons "escript" 'erlang-mode))
|
|
||||||
|
|
||||||
(let ((erl-ext '(".jam" ".vee" ".beam"))) (while erl-ext (let ((cie completion-ignored-extensions)) (while (and cie (not (string-equal (car cie) (car erl-ext)))) (setq cie (cdr cie))) (if (null cie) (setq completion-ignored-extensions (cons (car erl-ext) completion-ignored-extensions)))) (setq erl-ext (cdr erl-ext))))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("erlang-eunit.el" "erlang-flymake.el"
|
|
||||||
;;;;;; "erlang-pkg.el" "erlang-skels-old.el" "erlang-skels.el" "erlang-test.el"
|
|
||||||
;;;;;; "erlang_appwiz.el") (22523 21259 100519 619000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; erlang-autoloads.el ends here
|
|
||||||
@ -1,172 +0,0 @@
|
|||||||
;;; erlang-edoc.el --- EDoc support for Erlang mode -*- lexical-binding: t; -*-
|
|
||||||
|
|
||||||
;; %CopyrightBegin%
|
|
||||||
;;
|
|
||||||
;; Copyright Ericsson AB 1996-2016. All Rights Reserved.
|
|
||||||
;;
|
|
||||||
;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
||||||
;; you may not use this file except in compliance with the License.
|
|
||||||
;; You may obtain a copy of the License at
|
|
||||||
;;
|
|
||||||
;; http://www.apache.org/licenses/LICENSE-2.0
|
|
||||||
;;
|
|
||||||
;; Unless required by applicable law or agreed to in writing, software
|
|
||||||
;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
||||||
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
||||||
;; See the License for the specific language governing permissions and
|
|
||||||
;; limitations under the License.
|
|
||||||
;;
|
|
||||||
;; %CopyrightEnd%
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; Ref: http://www.erlang.org/doc/apps/edoc/users_guide.html
|
|
||||||
;;
|
|
||||||
;; To use: (add-hook 'erlang-mode-hook 'erlang-edoc-mode)
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(defcustom erlang-edoc-indent-level 2
|
|
||||||
"Indentation level of xhtml in Erlang edoc."
|
|
||||||
:safe 'integerp
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defvar erlang-edoc-generic-tags
|
|
||||||
'("clear" "docfile" "end" "headerfile" "todo" "TODO" "type")
|
|
||||||
"Tags that can be used anywhere within a module.")
|
|
||||||
|
|
||||||
(defvar erlang-edoc-overview-tags
|
|
||||||
'("author" "copyright" "reference" "see" "since" "title" "version")
|
|
||||||
"Tags that can be used in an overview file.")
|
|
||||||
|
|
||||||
(defvar erlang-edoc-module-tags
|
|
||||||
'("author" "copyright" "deprecated" "doc" "hidden" "private" "reference"
|
|
||||||
"see" "since" "version")
|
|
||||||
"Tags that can be used before a module declaration.")
|
|
||||||
|
|
||||||
(defvar erlang-edoc-function-tags
|
|
||||||
'("deprecated" "doc" "equiv" "hidden" "private" "see" "since" "spec"
|
|
||||||
"throws" "type")
|
|
||||||
"Tags that can be used before a function definition.")
|
|
||||||
|
|
||||||
(defvar erlang-edoc-predefined-macros
|
|
||||||
'("date" "docRoot" "link" "module" "package" "section" "time"
|
|
||||||
"type" "version"))
|
|
||||||
|
|
||||||
(defface erlang-edoc-tag '((t (:inherit font-lock-constant-face)))
|
|
||||||
"Face used to highlight edoc tags."
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defface erlang-edoc-macro '((t (:inherit font-lock-preprocessor-face)))
|
|
||||||
"Face used to highlight edoc macros."
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defface erlang-edoc-verbatim
|
|
||||||
'((t (:family "Monospace" :inherit font-lock-keyword-face)))
|
|
||||||
"Face used to highlight verbatim text."
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defface erlang-edoc-todo '((t (:inherit font-lock-warning-face)))
|
|
||||||
"Face used to highlight edoc macros."
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defface erlang-edoc-heading '((t (:inherit bold)))
|
|
||||||
"Face used to highlight edoc headings."
|
|
||||||
:group 'erlang)
|
|
||||||
|
|
||||||
(defvar erlang-edoc-font-lock-keywords
|
|
||||||
'(("^%+\\s-*\\(@\\w+\\)\\_>" 1 'erlang-edoc-tag prepend)
|
|
||||||
("^%+\\s-*" ("{\\(@\\w+\\)\\_>" nil nil (1 'erlang-edoc-macro prepend)))
|
|
||||||
("^%+\\s-*" ("\\(?:@@\\)*\\(@[@{}]\\)" nil nil (1 'escape-glyph prepend)))
|
|
||||||
("^%+\\s-*@\\(deprecated\\)\\_>" 1 font-lock-warning-face prepend)
|
|
||||||
;; http://www.erlang.org/doc/apps/edoc/chapter.html#Wiki_notation
|
|
||||||
("^%+\\s-*" ("[^`]`\\([^`]?\\|[^`].*?[^']\\)'"
|
|
||||||
(forward-char -1) nil (1 'erlang-edoc-verbatim prepend)))
|
|
||||||
("^%+\\s-*" ("\\[\\(\\(?:https?\\|file\\|ftp\\)://[^][]+\\)\\]"
|
|
||||||
nil nil (1 'link prepend)))
|
|
||||||
("^%+\\s-*\\(?:\\(?1:@todo\\|@TODO\\)\\_>\\|\\(?1:TODO\\):\\)"
|
|
||||||
1 'erlang-edoc-todo prepend)
|
|
||||||
("^%+\\s-*\\(\\(=\\{2,4\\}\\)[^=\n].*[^=\n]\\2\\)\\s-*$"
|
|
||||||
1 'erlang-edoc-heading prepend)))
|
|
||||||
|
|
||||||
(defun erlang-edoc-xml-context ()
|
|
||||||
"Parse edoc x(ht)ml context at comment start of current line."
|
|
||||||
(eval-and-compile (require 'xmltok))
|
|
||||||
(save-excursion
|
|
||||||
(beginning-of-line)
|
|
||||||
(when (looking-at "^%+\\s-*")
|
|
||||||
(let ((pt (match-end 0)) context)
|
|
||||||
(forward-comment (- (point)))
|
|
||||||
(while (< (point) pt)
|
|
||||||
(xmltok-forward)
|
|
||||||
(cond ((eq xmltok-type 'start-tag)
|
|
||||||
(push (cons xmltok-type xmltok-start) context))
|
|
||||||
((eq xmltok-type 'end-tag)
|
|
||||||
(pop context))))
|
|
||||||
(goto-char pt)
|
|
||||||
(xmltok-forward)
|
|
||||||
(push (car (memq xmltok-type '(start-tag end-tag))) context)
|
|
||||||
context))))
|
|
||||||
|
|
||||||
(defun erlang-edoc-indent-line ()
|
|
||||||
(let ((context (erlang-edoc-xml-context)))
|
|
||||||
(when context
|
|
||||||
(save-excursion
|
|
||||||
(beginning-of-line)
|
|
||||||
(re-search-forward "^%+\\s-*" (line-end-position))
|
|
||||||
(when (or (car context) (cadr context))
|
|
||||||
(let ((pad (when (cadr context)
|
|
||||||
(save-excursion
|
|
||||||
(goto-char (cdr (cadr context)))
|
|
||||||
(- (current-column)
|
|
||||||
(progn
|
|
||||||
(beginning-of-line)
|
|
||||||
(skip-chars-forward "%")
|
|
||||||
(current-column)))))))
|
|
||||||
(just-one-space (cond ((not pad) 1)
|
|
||||||
((eq (car context) 'end-tag) pad)
|
|
||||||
(t (+ erlang-edoc-indent-level pad)))))))
|
|
||||||
(when (looking-back "^%*\\s-*" (line-beginning-position))
|
|
||||||
(re-search-forward "\\=%*\\s-*")))))
|
|
||||||
|
|
||||||
(defun erlang-edoc-before-module-declaration-p ()
|
|
||||||
(save-excursion
|
|
||||||
(beginning-of-line)
|
|
||||||
(forward-comment (point-max))
|
|
||||||
(or (eobp) (re-search-forward "^-module\\s-*(" nil t))))
|
|
||||||
|
|
||||||
(defun erlang-edoc-completion-at-point ()
|
|
||||||
(when (eq (syntax-ppss-context (syntax-ppss)) 'comment)
|
|
||||||
(save-excursion
|
|
||||||
(skip-syntax-backward "w_")
|
|
||||||
(when (= (preceding-char) ?@)
|
|
||||||
(let* ((is-tag (looking-back "^%+\\s-*@" (line-beginning-position)))
|
|
||||||
(beg (point))
|
|
||||||
(end (progn (skip-syntax-forward "w_") (point)))
|
|
||||||
(table (cond
|
|
||||||
((not is-tag)
|
|
||||||
erlang-edoc-predefined-macros)
|
|
||||||
((erlang-edoc-before-module-declaration-p)
|
|
||||||
(append erlang-edoc-module-tags
|
|
||||||
erlang-edoc-generic-tags))
|
|
||||||
(t (append erlang-edoc-function-tags
|
|
||||||
erlang-edoc-generic-tags)))))
|
|
||||||
(list beg end table))))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(define-minor-mode erlang-edoc-mode nil
|
|
||||||
:lighter " EDoc"
|
|
||||||
(cond (erlang-edoc-mode
|
|
||||||
(add-hook 'erlang-indent-line-hook #'erlang-edoc-indent-line nil t)
|
|
||||||
(font-lock-add-keywords nil erlang-edoc-font-lock-keywords t)
|
|
||||||
(add-hook 'completion-at-point-functions
|
|
||||||
#'erlang-edoc-completion-at-point nil t))
|
|
||||||
(t
|
|
||||||
(remove-hook 'erlang-indent-line-hook #'erlang-edoc-indent-line t)
|
|
||||||
(font-lock-remove-keywords nil erlang-edoc-font-lock-keywords)
|
|
||||||
(remove-hook 'completion-at-point-functions
|
|
||||||
#'erlang-edoc-completion-at-point t)))
|
|
||||||
(jit-lock-refontify))
|
|
||||||
|
|
||||||
(provide 'erlang-edoc)
|
|
||||||
;;; erlang-edoc.el ends here
|
|
||||||
@ -1,453 +0,0 @@
|
|||||||
;;
|
|
||||||
;; %CopyrightBegin%
|
|
||||||
;;
|
|
||||||
;; Copyright Ericsson AB 2009-2016. All Rights Reserved.
|
|
||||||
;;
|
|
||||||
;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
||||||
;; you may not use this file except in compliance with the License.
|
|
||||||
;; You may obtain a copy of the License at
|
|
||||||
;;
|
|
||||||
;; http://www.apache.org/licenses/LICENSE-2.0
|
|
||||||
;;
|
|
||||||
;; Unless required by applicable law or agreed to in writing, software
|
|
||||||
;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
||||||
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
||||||
;; See the License for the specific language governing permissions and
|
|
||||||
;; limitations under the License.
|
|
||||||
;;
|
|
||||||
;; %CopyrightEnd%
|
|
||||||
;;;
|
|
||||||
;;; Purpose: Provide EUnit utilities.
|
|
||||||
;;;
|
|
||||||
;;; Author: Klas Johansson
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
(defvar erlang-eunit-src-candidate-dirs '("../src" ".")
|
|
||||||
"*Name of directories which to search for source files matching
|
|
||||||
an EUnit test file. The first directory in the list will be used,
|
|
||||||
if there is no match.")
|
|
||||||
|
|
||||||
(defvar erlang-eunit-test-candidate-dirs '("../test" ".")
|
|
||||||
"*Name of directories which to search for EUnit test files matching
|
|
||||||
a source file. The first directory in the list will be used,
|
|
||||||
if there is no match.")
|
|
||||||
|
|
||||||
(defvar erlang-eunit-autosave nil
|
|
||||||
"*Set to non-nil to automtically save unsaved buffers before running tests.
|
|
||||||
This is useful, reducing the save-compile-load-test cycle to one keychord.")
|
|
||||||
|
|
||||||
(defvar erlang-eunit-recent-info '((mode . nil) (module . nil) (test . nil) (cover . nil))
|
|
||||||
"Info about the most recent running of an EUnit test representation.")
|
|
||||||
|
|
||||||
(defvar erlang-error-regexp-alist
|
|
||||||
'(("^\\([^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\)[:) \t]" . (1 2)))
|
|
||||||
"*Patterns for matching Erlang errors.")
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Switch between src/EUnit test buffers
|
|
||||||
;;;
|
|
||||||
(defun erlang-eunit-toggle-src-and-test-file-other-window ()
|
|
||||||
"Switch to the src file if the EUnit test file is the current
|
|
||||||
buffer and vice versa"
|
|
||||||
(interactive)
|
|
||||||
(if (erlang-eunit-test-file-p buffer-file-name)
|
|
||||||
(erlang-eunit-open-src-file-other-window buffer-file-name)
|
|
||||||
(erlang-eunit-open-test-file-other-window buffer-file-name)))
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Open the EUnit test file which corresponds to a src file
|
|
||||||
;;;
|
|
||||||
(defun erlang-eunit-open-test-file-other-window (src-file-path)
|
|
||||||
"Open the EUnit test file which corresponds to a src file"
|
|
||||||
(find-file-other-window (erlang-eunit-test-filename src-file-path)))
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Open the src file which corresponds to the an EUnit test file
|
|
||||||
;;;
|
|
||||||
(defun erlang-eunit-open-src-file-other-window (test-file-path)
|
|
||||||
"Open the src file which corresponds to the an EUnit test file"
|
|
||||||
(find-file-other-window (erlang-eunit-src-filename test-file-path)))
|
|
||||||
|
|
||||||
;;; Return the name and path of the EUnit test file
|
|
||||||
;;, (input may be either the source filename itself or the EUnit test filename)
|
|
||||||
(defun erlang-eunit-test-filename (file-path)
|
|
||||||
(if (erlang-eunit-test-file-p file-path)
|
|
||||||
file-path
|
|
||||||
(erlang-eunit-rewrite-filename file-path erlang-eunit-test-candidate-dirs)))
|
|
||||||
|
|
||||||
;;; Return the name and path of the source file
|
|
||||||
;;, (input may be either the source filename itself or the EUnit test filename)
|
|
||||||
(defun erlang-eunit-src-filename (file-path)
|
|
||||||
(if (erlang-eunit-src-file-p file-path)
|
|
||||||
file-path
|
|
||||||
(erlang-eunit-rewrite-filename file-path erlang-eunit-src-candidate-dirs)))
|
|
||||||
|
|
||||||
;;; Rewrite a filename from the src or test filename to the other
|
|
||||||
(defun erlang-eunit-rewrite-filename (orig-file-path candidate-dirs)
|
|
||||||
(or (erlang-eunit-locate-buddy orig-file-path candidate-dirs)
|
|
||||||
(erlang-eunit-buddy-file-path orig-file-path (car candidate-dirs))))
|
|
||||||
|
|
||||||
;;; Search for a file's buddy file (a source file's EUnit test file,
|
|
||||||
;;; or an EUnit test file's source file) in a list of candidate
|
|
||||||
;;; directories.
|
|
||||||
(defun erlang-eunit-locate-buddy (orig-file-path candidate-dirs)
|
|
||||||
(when candidate-dirs
|
|
||||||
(let ((buddy-file-path (erlang-eunit-buddy-file-path
|
|
||||||
orig-file-path
|
|
||||||
(car candidate-dirs))))
|
|
||||||
(if (file-readable-p buddy-file-path)
|
|
||||||
buddy-file-path
|
|
||||||
(erlang-eunit-locate-buddy orig-file-path (cdr candidate-dirs))))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-buddy-file-path (orig-file-path buddy-dir-name)
|
|
||||||
(let* ((orig-dir-name (file-name-directory orig-file-path))
|
|
||||||
(buddy-dir-name (file-truename
|
|
||||||
(filename-join orig-dir-name buddy-dir-name)))
|
|
||||||
(buddy-base-name (erlang-eunit-buddy-basename orig-file-path)))
|
|
||||||
(filename-join buddy-dir-name buddy-base-name)))
|
|
||||||
|
|
||||||
;;; Return the basename of the buddy file:
|
|
||||||
;;; /tmp/foo/src/x.erl --> x_tests.erl
|
|
||||||
;;; /tmp/foo/test/x_tests.erl --> x.erl
|
|
||||||
(defun erlang-eunit-buddy-basename (file-path)
|
|
||||||
(let ((src-module-name (erlang-eunit-source-module-name file-path)))
|
|
||||||
(cond
|
|
||||||
((erlang-eunit-src-file-p file-path)
|
|
||||||
(concat src-module-name "_tests.erl"))
|
|
||||||
((erlang-eunit-test-file-p file-path)
|
|
||||||
(concat src-module-name ".erl")))))
|
|
||||||
|
|
||||||
;;; Checks whether a file is a source file or not
|
|
||||||
(defun erlang-eunit-src-file-p (file-path)
|
|
||||||
(not (erlang-eunit-test-file-p file-path)))
|
|
||||||
|
|
||||||
;;; Checks whether a file is a EUnit test file or not
|
|
||||||
(defun erlang-eunit-test-file-p (file-path)
|
|
||||||
(erlang-eunit-string-match-p "^\\(.+\\)_tests.erl$" file-path))
|
|
||||||
|
|
||||||
;;; Return the module name of the source file
|
|
||||||
;;; /tmp/foo/src/x.erl --> x
|
|
||||||
;;; /tmp/foo/test/x_tests.erl --> x
|
|
||||||
(defun erlang-eunit-source-module-name (file-path)
|
|
||||||
(interactive)
|
|
||||||
(let ((module-name (erlang-eunit-module-name file-path)))
|
|
||||||
(if (string-match "^\\(.+\\)_tests$" module-name)
|
|
||||||
(substring module-name (match-beginning 1) (match-end 1))
|
|
||||||
module-name)))
|
|
||||||
|
|
||||||
;;; Return the module name of the file
|
|
||||||
;;; /tmp/foo/src/x.erl --> x
|
|
||||||
;;; /tmp/foo/test/x_tests.erl --> x_tests
|
|
||||||
(defun erlang-eunit-module-name (file-path)
|
|
||||||
(interactive)
|
|
||||||
(file-name-sans-extension (file-name-nondirectory file-path)))
|
|
||||||
|
|
||||||
;;; Older emacsen don't have string-match-p.
|
|
||||||
(defun erlang-eunit-string-match-p (regexp string &optional start)
|
|
||||||
(if (fboundp 'string-match-p) ;; appeared in emacs 23
|
|
||||||
(string-match-p regexp string start)
|
|
||||||
(save-match-data ;; fallback for earlier versions of emacs
|
|
||||||
(string-match regexp string start))))
|
|
||||||
|
|
||||||
;;; Join filenames
|
|
||||||
(defun filename-join (dir file)
|
|
||||||
(if (or (= (elt file 0) ?/)
|
|
||||||
(= (car (last (append dir nil))) ?/))
|
|
||||||
(concat dir file)
|
|
||||||
(concat dir "/" file)))
|
|
||||||
|
|
||||||
;;; Get info about the most recent running of EUnit
|
|
||||||
(defun erlang-eunit-recent (key)
|
|
||||||
(cdr (assq key erlang-eunit-recent-info)))
|
|
||||||
|
|
||||||
;;; Record info about the most recent running of EUnit
|
|
||||||
;;; Known modes are 'module-mode and 'test-mode
|
|
||||||
(defun erlang-eunit-record-recent (mode module test)
|
|
||||||
(setcdr (assq 'mode erlang-eunit-recent-info) mode)
|
|
||||||
(setcdr (assq 'module erlang-eunit-recent-info) module)
|
|
||||||
(setcdr (assq 'test erlang-eunit-recent-info) test))
|
|
||||||
|
|
||||||
;;; Record whether the most recent running of EUnit included cover
|
|
||||||
;;; compilation
|
|
||||||
(defun erlang-eunit-record-recent-compile (under-cover)
|
|
||||||
(setcdr (assq 'cover erlang-eunit-recent-info) under-cover))
|
|
||||||
|
|
||||||
;;; Determine options for EUnit.
|
|
||||||
(defun erlang-eunit-opts ()
|
|
||||||
(if current-prefix-arg ", [verbose]" ""))
|
|
||||||
|
|
||||||
;;; Determine current test function
|
|
||||||
(defun erlang-eunit-current-test ()
|
|
||||||
(save-excursion
|
|
||||||
(erlang-end-of-function 1)
|
|
||||||
(erlang-beginning-of-function 1)
|
|
||||||
(erlang-name-of-function)))
|
|
||||||
|
|
||||||
(defun erlang-eunit-simple-test-p (test-name)
|
|
||||||
(if (erlang-eunit-string-match-p "^\\(.+\\)_test$" test-name) t nil))
|
|
||||||
|
|
||||||
(defun erlang-eunit-test-generator-p (test-name)
|
|
||||||
(if (erlang-eunit-string-match-p "^\\(.+\\)_test_$" test-name) t nil))
|
|
||||||
|
|
||||||
;;; Run one EUnit test
|
|
||||||
(defun erlang-eunit-run-test (module-name test-name)
|
|
||||||
(let ((command
|
|
||||||
(cond ((erlang-eunit-simple-test-p test-name)
|
|
||||||
(format "eunit:test({%s, %s}%s)."
|
|
||||||
module-name test-name (erlang-eunit-opts)))
|
|
||||||
((erlang-eunit-test-generator-p test-name)
|
|
||||||
(format "eunit:test({generator, %s, %s}%s)."
|
|
||||||
module-name test-name (erlang-eunit-opts)))
|
|
||||||
(t (format "%% WARNING: '%s' is not a test function" test-name)))))
|
|
||||||
(erlang-eunit-record-recent 'test-mode module-name test-name)
|
|
||||||
(erlang-eunit-inferior-erlang-send-command command)))
|
|
||||||
|
|
||||||
;;; Run EUnit tests for the current module
|
|
||||||
(defun erlang-eunit-run-module-tests (module-name)
|
|
||||||
(let ((command (format "eunit:test(%s%s)." module-name (erlang-eunit-opts))))
|
|
||||||
(erlang-eunit-record-recent 'module-mode module-name nil)
|
|
||||||
(erlang-eunit-inferior-erlang-send-command command)))
|
|
||||||
|
|
||||||
(defun erlang-eunit-compile-and-run-recent ()
|
|
||||||
"Compile the source and test files and repeat the most recent EUnit test run.
|
|
||||||
|
|
||||||
With prefix arg, compiles for debug and runs tests with the verbose flag set."
|
|
||||||
(interactive)
|
|
||||||
(case (erlang-eunit-recent 'mode)
|
|
||||||
('test-mode
|
|
||||||
(erlang-eunit-compile-and-test
|
|
||||||
'erlang-eunit-run-test (list (erlang-eunit-recent 'module)
|
|
||||||
(erlang-eunit-recent 'test))))
|
|
||||||
('module-mode
|
|
||||||
(erlang-eunit-compile-and-test
|
|
||||||
'erlang-eunit-run-module-tests (list (erlang-eunit-recent 'module))
|
|
||||||
(erlang-eunit-recent 'cover)))
|
|
||||||
(t (error "EUnit has not yet been run. Please run a test first."))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-cover-compile ()
|
|
||||||
"Cover compile current module."
|
|
||||||
(interactive)
|
|
||||||
(let* ((erlang-compile-extra-opts
|
|
||||||
(append (list 'debug_info) erlang-compile-extra-opts))
|
|
||||||
(module-name
|
|
||||||
(erlang-add-quotes-if-needed
|
|
||||||
(erlang-eunit-module-name buffer-file-name)))
|
|
||||||
(compile-command
|
|
||||||
(format "cover:compile_beam(%s)." module-name)))
|
|
||||||
(erlang-compile)
|
|
||||||
(if (erlang-eunit-last-compilation-successful-p)
|
|
||||||
(erlang-eunit-inferior-erlang-send-command compile-command))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-analyze-coverage ()
|
|
||||||
"Analyze the data collected by cover tool for the module in the
|
|
||||||
current buffer.
|
|
||||||
|
|
||||||
Assumes that the module has been cover compiled prior to this
|
|
||||||
call. This function will do two things: print the number of
|
|
||||||
covered and uncovered functions in the erlang shell and display a
|
|
||||||
new buffer called *<module name> coverage* which shows the source
|
|
||||||
code along with the coverage analysis results."
|
|
||||||
(interactive)
|
|
||||||
(let* ((module-name (erlang-add-quotes-if-needed
|
|
||||||
(erlang-eunit-module-name buffer-file-name)))
|
|
||||||
(tmp-filename (make-temp-file "cover"))
|
|
||||||
(analyze-command (format "cover:analyze_to_file(%s, \"%s\"). "
|
|
||||||
module-name tmp-filename))
|
|
||||||
(buf-name (format "*%s coverage*" module-name)))
|
|
||||||
(erlang-eunit-inferior-erlang-send-command analyze-command)
|
|
||||||
;; The purpose of the following snippet is to get the result of the
|
|
||||||
;; analysis from a file into a new buffer (or an old, if one with
|
|
||||||
;; the specified name already exists). Also we want the erlang-mode
|
|
||||||
;; *and* view-mode to be enabled.
|
|
||||||
(save-excursion
|
|
||||||
(let ((buf (get-buffer-create (format "*%s coverage*" module-name))))
|
|
||||||
(set-buffer buf)
|
|
||||||
(setq buffer-read-only nil)
|
|
||||||
(insert-file-contents tmp-filename nil nil nil t)
|
|
||||||
(if (= (buffer-size) 0)
|
|
||||||
(kill-buffer buf)
|
|
||||||
;; FIXME: this would be a good place to enable (emacs-mode)
|
|
||||||
;; to get some nice syntax highlighting in the
|
|
||||||
;; coverage report, but it doesn't play well with
|
|
||||||
;; flymake. Leave it off for now.
|
|
||||||
(view-buffer buf))))
|
|
||||||
(delete-file tmp-filename)))
|
|
||||||
|
|
||||||
(defun erlang-eunit-compile-and-run-current-test ()
|
|
||||||
"Compile the source and test files and run the current EUnit test.
|
|
||||||
|
|
||||||
With prefix arg, compiles for debug and runs tests with the verbose flag set."
|
|
||||||
(interactive)
|
|
||||||
(let ((module-name (erlang-add-quotes-if-needed
|
|
||||||
(erlang-eunit-module-name buffer-file-name)))
|
|
||||||
(test-name (erlang-eunit-current-test)))
|
|
||||||
(erlang-eunit-compile-and-test
|
|
||||||
'erlang-eunit-run-test (list module-name test-name))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-compile-and-run-module-tests ()
|
|
||||||
"Compile the source and test files and run all EUnit tests in the module.
|
|
||||||
|
|
||||||
With prefix arg, compiles for debug and runs tests with the verbose flag set."
|
|
||||||
(interactive)
|
|
||||||
(let ((module-name (erlang-add-quotes-if-needed
|
|
||||||
(erlang-eunit-source-module-name buffer-file-name))))
|
|
||||||
(erlang-eunit-compile-and-test
|
|
||||||
'erlang-eunit-run-module-tests (list module-name))))
|
|
||||||
|
|
||||||
;;; Compile source and EUnit test file and finally run EUnit tests for
|
|
||||||
;;; the current module
|
|
||||||
(defun erlang-eunit-compile-and-test (test-fun test-args &optional under-cover)
|
|
||||||
"Compile the source and test files and run the EUnit test suite.
|
|
||||||
|
|
||||||
If under-cover is set to t, the module under test is compile for
|
|
||||||
code coverage analysis. If under-cover is left out or not set,
|
|
||||||
coverage analysis is disabled. The result of the code coverage
|
|
||||||
is both printed to the erlang shell (the number of covered vs
|
|
||||||
uncovered functions in a module) and written to a buffer called
|
|
||||||
*<module> coverage* (which shows the source code for the module
|
|
||||||
and the number of times each line is covered).
|
|
||||||
With prefix arg, compiles for debug and runs tests with the verbose flag set."
|
|
||||||
(erlang-eunit-record-recent-compile under-cover)
|
|
||||||
(let ((src-filename (erlang-eunit-src-filename buffer-file-name))
|
|
||||||
(test-filename (erlang-eunit-test-filename buffer-file-name)))
|
|
||||||
|
|
||||||
;; The purpose of out-maneuvering `save-some-buffers', as is done
|
|
||||||
;; below, is to ask the question about saving buffers only once,
|
|
||||||
;; instead of possibly several: one for each file to compile,
|
|
||||||
;; for instance for both x.erl and x_tests.erl.
|
|
||||||
(save-some-buffers erlang-eunit-autosave)
|
|
||||||
(flet ((save-some-buffers (&optional any) nil))
|
|
||||||
|
|
||||||
;; Compilation of the source file is mandatory (the file must
|
|
||||||
;; exist, otherwise the procedure is aborted). Compilation of the
|
|
||||||
;; test file on the other hand, is optional, since eunit tests may
|
|
||||||
;; be placed in the source file instead. Any compilation error
|
|
||||||
;; will prevent the subsequent steps to be run (hence the `and')
|
|
||||||
(and (erlang-eunit-compile-file src-filename under-cover)
|
|
||||||
(if (file-readable-p test-filename)
|
|
||||||
(erlang-eunit-compile-file test-filename)
|
|
||||||
t)
|
|
||||||
(apply test-fun test-args)
|
|
||||||
(if under-cover
|
|
||||||
(save-excursion
|
|
||||||
(set-buffer (find-file-noselect src-filename))
|
|
||||||
(erlang-eunit-analyze-coverage)))))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-compile-and-run-module-tests-under-cover ()
|
|
||||||
"Compile the source and test files and run the EUnit test suite and measure
|
|
||||||
code coverage.
|
|
||||||
|
|
||||||
With prefix arg, compiles for debug and runs tests with the verbose flag set."
|
|
||||||
(interactive)
|
|
||||||
(let ((module-name (erlang-add-quotes-if-needed
|
|
||||||
(erlang-eunit-source-module-name buffer-file-name))))
|
|
||||||
(erlang-eunit-compile-and-test
|
|
||||||
'erlang-eunit-run-module-tests (list module-name) t)))
|
|
||||||
|
|
||||||
(defun erlang-eunit-compile-file (file-path &optional under-cover)
|
|
||||||
(if (file-readable-p file-path)
|
|
||||||
(save-excursion
|
|
||||||
(set-buffer (find-file-noselect file-path))
|
|
||||||
;; In order to run a code coverage analysis on a
|
|
||||||
;; module, we have two options:
|
|
||||||
;;
|
|
||||||
;; * either compile the module with cover:compile instead of the
|
|
||||||
;; regular compiler
|
|
||||||
;;
|
|
||||||
;; * or first compile the module with the regular compiler (but
|
|
||||||
;; *with* debug_info) and then compile it for coverage
|
|
||||||
;; analysis using cover:compile_beam.
|
|
||||||
;;
|
|
||||||
;; We could accomplish the first by changing the
|
|
||||||
;; erlang-compile-erlang-function to cover:compile, but there's
|
|
||||||
;; a risk that that's used for other purposes. Therefore, a
|
|
||||||
;; safer alternative (although with more steps) is to add
|
|
||||||
;; debug_info to the list of compiler options and go for the
|
|
||||||
;; second alternative.
|
|
||||||
(if under-cover
|
|
||||||
(erlang-eunit-cover-compile)
|
|
||||||
(erlang-compile))
|
|
||||||
(erlang-eunit-last-compilation-successful-p))
|
|
||||||
(let ((msg (format "Could not read %s" file-path)))
|
|
||||||
(erlang-eunit-inferior-erlang-send-command
|
|
||||||
(format "%% WARNING: %s" msg))
|
|
||||||
(error msg))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-last-compilation-successful-p ()
|
|
||||||
(save-excursion
|
|
||||||
(set-buffer inferior-erlang-buffer)
|
|
||||||
(goto-char compilation-parsing-end)
|
|
||||||
(erlang-eunit-all-list-elems-fulfill-p
|
|
||||||
(lambda (re) (let ((continue t)
|
|
||||||
(result t))
|
|
||||||
(while continue ; ignore warnings, stop at errors
|
|
||||||
(if (re-search-forward re (point-max) t)
|
|
||||||
(if (erlang-eunit-is-compilation-warning)
|
|
||||||
t
|
|
||||||
(setq result nil)
|
|
||||||
(setq continue nil))
|
|
||||||
(setq result t)
|
|
||||||
(setq continue nil)))
|
|
||||||
result))
|
|
||||||
(mapcar (lambda (e) (car e)) erlang-error-regexp-alist))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-is-compilation-warning ()
|
|
||||||
(erlang-eunit-string-match-p
|
|
||||||
"[0-9]+: Warning:"
|
|
||||||
(buffer-substring (line-beginning-position) (line-end-position))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-all-list-elems-fulfill-p (pred list)
|
|
||||||
(let ((matches-p t))
|
|
||||||
(while (and list matches-p)
|
|
||||||
(if (not (funcall pred (car list)))
|
|
||||||
(setq matches-p nil))
|
|
||||||
(setq list (cdr list)))
|
|
||||||
matches-p))
|
|
||||||
|
|
||||||
;;; Evaluate a command in an erlang buffer
|
|
||||||
(defun erlang-eunit-inferior-erlang-send-command (command)
|
|
||||||
"Evaluate a command in an erlang buffer."
|
|
||||||
(interactive "P")
|
|
||||||
(inferior-erlang-prepare-for-input)
|
|
||||||
(inferior-erlang-send-command command)
|
|
||||||
(sit-for 0) ;; redisplay
|
|
||||||
(inferior-erlang-wait-prompt))
|
|
||||||
|
|
||||||
|
|
||||||
;;;====================================================================
|
|
||||||
;;; Key bindings
|
|
||||||
;;;====================================================================
|
|
||||||
|
|
||||||
(defconst erlang-eunit-key-bindings
|
|
||||||
'(("\C-c\C-et" erlang-eunit-toggle-src-and-test-file-other-window)
|
|
||||||
("\C-c\C-ek" erlang-eunit-compile-and-run-module-tests)
|
|
||||||
("\C-c\C-ej" erlang-eunit-compile-and-run-current-test)
|
|
||||||
("\C-c\C-el" erlang-eunit-compile-and-run-recent)
|
|
||||||
("\C-c\C-ec" erlang-eunit-compile-and-run-module-tests-under-cover)
|
|
||||||
("\C-c\C-ev" erlang-eunit-cover-compile)
|
|
||||||
("\C-c\C-ea" erlang-eunit-analyze-coverage)))
|
|
||||||
|
|
||||||
(defun erlang-eunit-add-key-bindings ()
|
|
||||||
(dolist (binding erlang-eunit-key-bindings)
|
|
||||||
(erlang-eunit-bind-key (car binding) (cadr binding))))
|
|
||||||
|
|
||||||
(defun erlang-eunit-bind-key (key function)
|
|
||||||
(erlang-eunit-ensure-keymap-for-key key)
|
|
||||||
(local-set-key key function))
|
|
||||||
|
|
||||||
(defun erlang-eunit-ensure-keymap-for-key (key-seq)
|
|
||||||
(let ((prefix-keys (butlast (append key-seq nil)))
|
|
||||||
(prefix-seq ""))
|
|
||||||
(while prefix-keys
|
|
||||||
(setq prefix-seq (concat prefix-seq (make-string 1 (car prefix-keys))))
|
|
||||||
(setq prefix-keys (cdr prefix-keys))
|
|
||||||
(if (not (keymapp (lookup-key (current-local-map) prefix-seq)))
|
|
||||||
(local-set-key prefix-seq (make-sparse-keymap))))))
|
|
||||||
|
|
||||||
(add-hook 'erlang-mode-hook 'erlang-eunit-add-key-bindings)
|
|
||||||
|
|
||||||
|
|
||||||
(provide 'erlang-eunit)
|
|
||||||
;; erlang-eunit ends here
|
|
||||||
@ -1,103 +0,0 @@
|
|||||||
;; erlang-flymake.el
|
|
||||||
;;
|
|
||||||
;; Syntax check erlang source code on the fly (integrates with flymake).
|
|
||||||
;;
|
|
||||||
;; Start using flymake with erlang by putting the following somewhere
|
|
||||||
;; in your .emacs file:
|
|
||||||
;;
|
|
||||||
;; (require 'erlang-flymake)
|
|
||||||
;;
|
|
||||||
;; Flymake is rather eager and does its syntax checks frequently by
|
|
||||||
;; default and if you are bothered by this, you might want to put the
|
|
||||||
;; following in your .emacs as well:
|
|
||||||
;;
|
|
||||||
;; (erlang-flymake-only-on-save)
|
|
||||||
;;
|
|
||||||
;; There are a couple of variables which control the compilation options:
|
|
||||||
;; * erlang-flymake-get-code-path-dirs-function
|
|
||||||
;; * erlang-flymake-get-include-dirs-function
|
|
||||||
;; * erlang-flymake-extra-opts
|
|
||||||
;;
|
|
||||||
;; This code is inspired by http://www.emacswiki.org/emacs/FlymakeErlang.
|
|
||||||
|
|
||||||
(require 'flymake)
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
(defvar erlang-flymake-command
|
|
||||||
"erlc"
|
|
||||||
"The command that will be used to perform the syntax check")
|
|
||||||
|
|
||||||
(defvar erlang-flymake-get-code-path-dirs-function
|
|
||||||
'erlang-flymake-get-code-path-dirs
|
|
||||||
"Return a list of ebin directories to add to the code path.")
|
|
||||||
|
|
||||||
(defvar erlang-flymake-get-include-dirs-function
|
|
||||||
'erlang-flymake-get-include-dirs
|
|
||||||
"Return a list of include directories to add to the compiler options.")
|
|
||||||
|
|
||||||
(defvar erlang-flymake-extra-opts
|
|
||||||
(list "+warn_obsolete_guard"
|
|
||||||
"+warn_unused_import"
|
|
||||||
"+warn_shadow_vars"
|
|
||||||
"+warn_export_vars"
|
|
||||||
"+strong_validation"
|
|
||||||
"+report")
|
|
||||||
"A list of options that will be passed to the compiler")
|
|
||||||
|
|
||||||
(defun erlang-flymake-only-on-save ()
|
|
||||||
"Trigger flymake only when the buffer is saved (disables syntax
|
|
||||||
check on newline and when there are no changes)."
|
|
||||||
(interactive)
|
|
||||||
;; There doesn't seem to be a way of disabling this; set to the
|
|
||||||
;; largest int available as a workaround (most-positive-fixnum
|
|
||||||
;; equates to 8.5 years on my machine, so it ought to be enough ;-) )
|
|
||||||
(setq flymake-no-changes-timeout most-positive-fixnum)
|
|
||||||
(setq flymake-start-syntax-check-on-newline nil))
|
|
||||||
|
|
||||||
|
|
||||||
(defun erlang-flymake-get-code-path-dirs ()
|
|
||||||
(list (concat (erlang-flymake-get-app-dir) "ebin")))
|
|
||||||
|
|
||||||
(defun erlang-flymake-get-include-dirs ()
|
|
||||||
(list (concat (erlang-flymake-get-app-dir) "include")
|
|
||||||
(concat (erlang-flymake-get-app-dir) "deps")))
|
|
||||||
|
|
||||||
(defun erlang-flymake-get-app-dir ()
|
|
||||||
(let ((src-path (file-name-directory (buffer-file-name))))
|
|
||||||
(file-name-directory (directory-file-name src-path))))
|
|
||||||
|
|
||||||
(defun erlang-flymake-init ()
|
|
||||||
(let* ((temp-file
|
|
||||||
(flet ((flymake-get-temp-dir () (erlang-flymake-temp-dir)))
|
|
||||||
(flymake-init-create-temp-buffer-copy
|
|
||||||
'flymake-create-temp-with-folder-structure)))
|
|
||||||
(code-dir-opts
|
|
||||||
(erlang-flymake-flatten
|
|
||||||
(mapcar (lambda (dir) (list "-pa" dir))
|
|
||||||
(funcall erlang-flymake-get-code-path-dirs-function))))
|
|
||||||
(inc-dir-opts
|
|
||||||
(erlang-flymake-flatten
|
|
||||||
(mapcar (lambda (dir) (list "-I" dir))
|
|
||||||
(funcall erlang-flymake-get-include-dirs-function))))
|
|
||||||
(compile-opts
|
|
||||||
(append inc-dir-opts
|
|
||||||
code-dir-opts
|
|
||||||
erlang-flymake-extra-opts)))
|
|
||||||
(list erlang-flymake-command (append compile-opts (list temp-file)))))
|
|
||||||
|
|
||||||
(defun erlang-flymake-temp-dir ()
|
|
||||||
;; Squeeze the user's name in there in order to make sure that files
|
|
||||||
;; for two users who are working on the same computer (like a linux
|
|
||||||
;; box) don't collide
|
|
||||||
(format "%s/flymake-%s" temporary-file-directory user-login-name))
|
|
||||||
|
|
||||||
(defun erlang-flymake-flatten (list)
|
|
||||||
(apply #'append list))
|
|
||||||
|
|
||||||
(add-to-list 'flymake-allowed-file-name-masks
|
|
||||||
'("\\.erl\\'" erlang-flymake-init))
|
|
||||||
(add-hook 'erlang-mode-hook 'flymake-mode)
|
|
||||||
|
|
||||||
(provide 'erlang-flymake)
|
|
||||||
;; erlang-flymake ends here
|
|
||||||
@ -1,4 +0,0 @@
|
|||||||
(define-package "erlang" "20161007.57" "Erlang major mode" 'nil)
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,125 +0,0 @@
|
|||||||
;; erlang-start.el --- Load this file to initialize the Erlang package.
|
|
||||||
|
|
||||||
;; Copyright (C) 1998 Ericsson Telecom AB
|
|
||||||
|
|
||||||
;; Author: Anders Lindgren
|
|
||||||
;; Version: 2.3
|
|
||||||
;; Keywords: erlang, languages, processes
|
|
||||||
;; Created: 1996-09-18
|
|
||||||
;; Date: 1998-03-16
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; Introduction:
|
|
||||||
;; ------------
|
|
||||||
;;
|
|
||||||
;; This package provides support for the programming language Erlang.
|
|
||||||
;; The package provides an editing mode with lots of bells and
|
|
||||||
;; whistles, compilation support, and it makes it possible for the
|
|
||||||
;; user to start Erlang shells that run inside Emacs.
|
|
||||||
;;
|
|
||||||
;; See the Erlang distribution for full documentation of this package.
|
|
||||||
|
|
||||||
;; Installation:
|
|
||||||
;; ------------
|
|
||||||
;;
|
|
||||||
;; Place this file in Emacs load path, byte-compile it, and add the
|
|
||||||
;; following line to the appropriate init file:
|
|
||||||
;;
|
|
||||||
;; (require 'erlang-start)
|
|
||||||
;;
|
|
||||||
;; The full documentation contains much more extensive description of
|
|
||||||
;; the installation procedure.
|
|
||||||
|
|
||||||
;; Reporting Bugs:
|
|
||||||
;; --------------
|
|
||||||
;;
|
|
||||||
;; Please send bug reports to the following email address:
|
|
||||||
;; support@erlang.ericsson.se
|
|
||||||
;;
|
|
||||||
;; Please state as exactly as possible:
|
|
||||||
;; - Version number of Erlang Mode (see the menu), Emacs, Erlang,
|
|
||||||
;; and of any other relevant software.
|
|
||||||
;; - What the expected result was.
|
|
||||||
;; - What you did, preferably in a repeatable step-by-step form.
|
|
||||||
;; - A description of the unexpected result.
|
|
||||||
;; - Relevant pieces of Erlang code causing the problem.
|
|
||||||
;; - Personal Emacs customisations, if any.
|
|
||||||
;;
|
|
||||||
;; Should the Emacs generate an error, please set the emacs variable
|
|
||||||
;; `debug-on-error' to `t'. Repeat the error and enclose the debug
|
|
||||||
;; information in your bug-report.
|
|
||||||
;;
|
|
||||||
;; To set the variable you can use the following command:
|
|
||||||
;; M-x set-variable RET debug-on-error RET t RET
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Declare functions in "erlang.el".
|
|
||||||
;;
|
|
||||||
|
|
||||||
(autoload 'erlang-mode "erlang" "Major mode for editing Erlang code." t)
|
|
||||||
(autoload 'erlang-version "erlang"
|
|
||||||
"Return the current version of Erlang mode." t)
|
|
||||||
(autoload 'erlang-shell "erlang" "Start a new Erlang shell." t)
|
|
||||||
(autoload 'run-erlang "erlang" "Start a new Erlang shell." t)
|
|
||||||
|
|
||||||
(autoload 'erlang-compile "erlang"
|
|
||||||
"Compile Erlang module in current buffer." t)
|
|
||||||
|
|
||||||
(autoload 'erlang-man-module "erlang"
|
|
||||||
"Find manual page for MODULE." t)
|
|
||||||
(autoload 'erlang-man-function "erlang"
|
|
||||||
"Find manual page for NAME, where NAME is module:function." t)
|
|
||||||
|
|
||||||
(autoload 'erlang-find-tag "erlang"
|
|
||||||
"Like `find-tag'. Capable of retreiving Erlang modules.")
|
|
||||||
(autoload 'erlang-find-tag-other-window "erlang"
|
|
||||||
"Like `find-tag-other-window'. Capable of retreiving Erlang modules.")
|
|
||||||
|
|
||||||
(autoload 'erlang-edoc-mode "erlang-edoc" "Toggle Erlang-Edoc mode on or off." t)
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Associate files extensions ".erl" and ".hrl" with Erlang mode.
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(let ((a '("\\.erl\\'" . erlang-mode))
|
|
||||||
(b '("\\.hrl\\'" . erlang-mode)))
|
|
||||||
(or (assoc (car a) auto-mode-alist)
|
|
||||||
(setq auto-mode-alist (cons a auto-mode-alist)))
|
|
||||||
(or (assoc (car b) auto-mode-alist)
|
|
||||||
(setq auto-mode-alist (cons b auto-mode-alist))))
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Associate files using interpreter "escript" with Erlang mode.
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(add-to-list 'interpreter-mode-alist (cons "escript" 'erlang-mode))
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Ignore files ending in ".jam", ".vee", and ".beam" when performing
|
|
||||||
;; file completion.
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(let ((erl-ext '(".jam" ".vee" ".beam")))
|
|
||||||
(while erl-ext
|
|
||||||
(let ((cie completion-ignored-extensions))
|
|
||||||
(while (and cie (not (string-equal (car cie) (car erl-ext))))
|
|
||||||
(setq cie (cdr cie)))
|
|
||||||
(if (null cie)
|
|
||||||
(setq completion-ignored-extensions
|
|
||||||
(cons (car erl-ext) completion-ignored-extensions))))
|
|
||||||
(setq erl-ext (cdr erl-ext))))
|
|
||||||
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; The end.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(provide 'erlang-start)
|
|
||||||
|
|
||||||
;; erlang-start.el ends here.
|
|
||||||
@ -1,184 +0,0 @@
|
|||||||
;;; erlang-test.el -*- lexical-binding: t; coding: utf-8-unix -*-
|
|
||||||
|
|
||||||
;;; Unit tests for erlang.el.
|
|
||||||
|
|
||||||
;; Author: Johan Claesson
|
|
||||||
;; Created: 2016-05-07
|
|
||||||
;; Keywords: erlang, languages
|
|
||||||
|
|
||||||
;; %CopyrightBegin%
|
|
||||||
;;
|
|
||||||
;; Copyright Ericsson AB 2016. All Rights Reserved.
|
|
||||||
;;
|
|
||||||
;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
||||||
;; you may not use this file except in compliance with the License.
|
|
||||||
;; You may obtain a copy of the License at
|
|
||||||
;;
|
|
||||||
;; http://www.apache.org/licenses/LICENSE-2.0
|
|
||||||
;;
|
|
||||||
;; Unless required by applicable law or agreed to in writing, software
|
|
||||||
;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
||||||
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
||||||
;; See the License for the specific language governing permissions and
|
|
||||||
;; limitations under the License.
|
|
||||||
;;
|
|
||||||
;; %CopyrightEnd%
|
|
||||||
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; This library require GNU Emacs 25 or later.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'ert)
|
|
||||||
(require 'cl-lib)
|
|
||||||
(require 'erlang)
|
|
||||||
|
|
||||||
(defvar erlang-test-code
|
|
||||||
'((nil . "-module(erlang_test).")
|
|
||||||
(nil . "-import(lists, [map/2]).")
|
|
||||||
(nil . "-compile(export_all).")
|
|
||||||
("SYMBOL" . "-define(SYMBOL, value).")
|
|
||||||
("MACRO" . "-define(MACRO(X), X + X).")
|
|
||||||
("struct" . "-record(struct, {until,maps,are,everywhere}).")
|
|
||||||
("function". "function() -> #struct{}."))
|
|
||||||
"Alist of erlang test code.
|
|
||||||
Each entry have the format (TAGNAME . ERLANG_CODE). If TAGNAME
|
|
||||||
is nil there is no definitions in the ERLANG_CODE. The
|
|
||||||
ERLANG_CODE is a single line of erlang code. These lines will be
|
|
||||||
concatenated to form an erlang file to test on.")
|
|
||||||
|
|
||||||
|
|
||||||
(ert-deftest erlang-test-tags ()
|
|
||||||
(let* ((dir (make-temp-file "erlang-test" t))
|
|
||||||
(erlang-file (expand-file-name "erlang_test.erl" dir))
|
|
||||||
(tags-file (expand-file-name "TAGS" dir))
|
|
||||||
(old-tags-file-name (default-value 'tags-file-name))
|
|
||||||
(old-tags-table-list (default-value 'tags-table-list))
|
|
||||||
tags-file-name
|
|
||||||
tags-table-list
|
|
||||||
tags-table-set-list
|
|
||||||
erlang-buffer
|
|
||||||
erlang-mode-hook
|
|
||||||
prog-mode-hook
|
|
||||||
erlang-shell-mode-hook
|
|
||||||
tags-add-tables)
|
|
||||||
(unwind-protect
|
|
||||||
(progn
|
|
||||||
(setq-default tags-file-name nil)
|
|
||||||
(setq-default tags-table-list nil)
|
|
||||||
(erlang-test-create-erlang-file erlang-file)
|
|
||||||
(erlang-test-compile-tags erlang-file tags-file)
|
|
||||||
(setq erlang-buffer (find-file-noselect erlang-file))
|
|
||||||
(with-current-buffer erlang-buffer
|
|
||||||
(setq-local tags-file-name tags-file))
|
|
||||||
;; Setting global tags-file-name is a workaround for
|
|
||||||
;; GNU Emacs bug#23164.
|
|
||||||
(setq tags-file-name tags-file)
|
|
||||||
(erlang-test-complete-at-point tags-file)
|
|
||||||
(erlang-test-completion-table)
|
|
||||||
(erlang-test-xref-find-definitions erlang-file erlang-buffer))
|
|
||||||
(when (buffer-live-p erlang-buffer)
|
|
||||||
(kill-buffer erlang-buffer))
|
|
||||||
(let ((tags-buffer (find-buffer-visiting tags-file)))
|
|
||||||
(when (buffer-live-p tags-buffer)
|
|
||||||
(kill-buffer tags-buffer)))
|
|
||||||
(when (file-exists-p dir)
|
|
||||||
(delete-directory dir t))
|
|
||||||
(setq-default tags-file-name old-tags-file-name)
|
|
||||||
(setq-default tags-table-list old-tags-table-list))))
|
|
||||||
|
|
||||||
(defun erlang-test-create-erlang-file (erlang-file)
|
|
||||||
(with-temp-file erlang-file
|
|
||||||
(cl-loop for (_ . code) in erlang-test-code
|
|
||||||
do (insert code "\n"))))
|
|
||||||
|
|
||||||
(defun erlang-test-compile-tags (erlang-file tags-file)
|
|
||||||
(should (zerop (call-process "etags" nil nil nil
|
|
||||||
"-o" tags-file
|
|
||||||
erlang-file))))
|
|
||||||
|
|
||||||
(defun erlang-test-completion-table ()
|
|
||||||
(let ((erlang-replace-etags-tags-completion-table t))
|
|
||||||
(setq tags-completion-table nil)
|
|
||||||
(tags-completion-table))
|
|
||||||
(should (equal (sort tags-completion-table #'string-lessp)
|
|
||||||
(sort (erlang-expected-completion-table) #'string-lessp))))
|
|
||||||
|
|
||||||
(defun erlang-expected-completion-table ()
|
|
||||||
(append (cl-loop for (symbol . _) in erlang-test-code
|
|
||||||
when (stringp symbol)
|
|
||||||
append (list symbol (concat "erlang_test:" symbol)))
|
|
||||||
(list "erlang_test:" "erlang_test:module_info")))
|
|
||||||
|
|
||||||
(defun erlang-test-xref-find-definitions (erlang-file erlang-buffer)
|
|
||||||
(cl-loop for (tagname . code) in erlang-test-code
|
|
||||||
for line = 1 then (1+ line)
|
|
||||||
do (when tagname
|
|
||||||
(switch-to-buffer erlang-buffer)
|
|
||||||
(xref-find-definitions tagname)
|
|
||||||
(erlang-test-verify-pos erlang-file line)
|
|
||||||
(xref-find-definitions (concat "erlang_test:" tagname))
|
|
||||||
(erlang-test-verify-pos erlang-file line)))
|
|
||||||
(xref-find-definitions "erlang_test:")
|
|
||||||
(erlang-test-verify-pos erlang-file 1))
|
|
||||||
|
|
||||||
(defun erlang-test-verify-pos (expected-file expected-line)
|
|
||||||
(should (string-equal (file-truename expected-file)
|
|
||||||
(file-truename (buffer-file-name))))
|
|
||||||
(should (eq expected-line (line-number-at-pos)))
|
|
||||||
(should (= (point-at-bol) (point))))
|
|
||||||
|
|
||||||
(defun erlang-test-complete-at-point (tags-file)
|
|
||||||
(with-temp-buffer
|
|
||||||
(erlang-mode)
|
|
||||||
(setq-local tags-file-name tags-file)
|
|
||||||
(insert "\nerlang_test:fun")
|
|
||||||
(erlang-complete-tag)
|
|
||||||
(should (looking-back "erlang_test:function"))
|
|
||||||
(insert "\nfun")
|
|
||||||
(erlang-complete-tag)
|
|
||||||
(should (looking-back "function"))
|
|
||||||
(insert "\nerlang_")
|
|
||||||
(erlang-complete-tag)
|
|
||||||
(should (looking-back "erlang_test:"))))
|
|
||||||
|
|
||||||
|
|
||||||
(ert-deftest erlang-test-compile-options ()
|
|
||||||
(erlang-test-format-opt t
|
|
||||||
"t")
|
|
||||||
(erlang-test-format-opt nil
|
|
||||||
"nil")
|
|
||||||
(erlang-test-format-opt (cons 1 2)
|
|
||||||
"{1, 2}")
|
|
||||||
(erlang-test-format-opt (list 1)
|
|
||||||
"[1]")
|
|
||||||
(erlang-test-format-opt (list 1 2)
|
|
||||||
"[1, 2]")
|
|
||||||
(erlang-test-format-opt (list 1 2 3)
|
|
||||||
"[1, 2, 3]")
|
|
||||||
(erlang-test-format-opt 'symbol
|
|
||||||
"symbol")
|
|
||||||
(erlang-test-format-opt "string"
|
|
||||||
"\"string\"")
|
|
||||||
(erlang-test-format-opt []
|
|
||||||
"{}")
|
|
||||||
(erlang-test-format-opt [1]
|
|
||||||
"{1}")
|
|
||||||
(erlang-test-format-opt [1 2]
|
|
||||||
"{1, 2}")
|
|
||||||
(erlang-test-format-opt [1 2 (3 [4 5 6] 7)]
|
|
||||||
"{1, 2, [3, {4, 5, 6}, 7]}"))
|
|
||||||
|
|
||||||
(defun erlang-test-format-opt (elisp &optional expected-erlang)
|
|
||||||
(let ((erlang (inferior-erlang-format-opt elisp)))
|
|
||||||
(message "%s -> %s" elisp erlang)
|
|
||||||
(when expected-erlang
|
|
||||||
(should (equal erlang expected-erlang)))
|
|
||||||
erlang))
|
|
||||||
|
|
||||||
|
|
||||||
(provide 'erlang-test)
|
|
||||||
|
|
||||||
;;; erlang-test.el ends here
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,65 +0,0 @@
|
|||||||
;;; fiplr-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "fiplr" "fiplr.el" (22297 19831 573825 595000))
|
|
||||||
;;; Generated autoloads from fiplr.el
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-file "fiplr" "\
|
|
||||||
Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-file-other-window "fiplr" "\
|
|
||||||
Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
file is opened using `find-file-other-window'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-file-other-frame "fiplr" "\
|
|
||||||
Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
file is opened using `find-file-other-frame'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-directory "fiplr" "\
|
|
||||||
Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-directory-other-window "fiplr" "\
|
|
||||||
Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
directory is opened using `dired-other-window'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-find-directory-other-frame "fiplr" "\
|
|
||||||
Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
directory is opened using `dired-other-frame'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'fiplr-clear-cache "fiplr" "\
|
|
||||||
Clears the internal caches used by fiplr so the project is searched again.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("fiplr-pkg.el") (22297 19831 829667 665000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; fiplr-autoloads.el ends here
|
|
||||||
@ -1,6 +0,0 @@
|
|||||||
(define-package "fiplr" "20140723.2345" "Fuzzy Search for Files in Projects"
|
|
||||||
'((grizzl "0.1.0")
|
|
||||||
(cl-lib "0.1")))
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
@ -1,346 +0,0 @@
|
|||||||
;;; fiplr.el --- Fuzzy finder for files in a project.
|
|
||||||
|
|
||||||
;; Copyright © 2013 Chris Corbyn
|
|
||||||
;;
|
|
||||||
;; Author: Chris Corbyn <chris@w3style.co.uk>
|
|
||||||
;; URL: https://github.com/d11wtq/fiplr
|
|
||||||
;; Version: 0.2.8
|
|
||||||
;; Keywords: convenience, usability, project
|
|
||||||
|
|
||||||
;; This file is NOT part of GNU Emacs.
|
|
||||||
|
|
||||||
;;; --- License
|
|
||||||
|
|
||||||
;; Licensed under the same terms as Emacs.
|
|
||||||
|
|
||||||
;;; --- Commentary
|
|
||||||
|
|
||||||
;; Overview:
|
|
||||||
;;
|
|
||||||
;; Fiplr makes it really easy to find files anywhere within your entire
|
|
||||||
;; project by using a cached directory tree and delegating to grizzl.el
|
|
||||||
;; while you search the tree.
|
|
||||||
;;
|
|
||||||
;; M-x fiplr-find-file
|
|
||||||
;;
|
|
||||||
;; By default it looks through all the parent directories of the file you're
|
|
||||||
;; editing until it finds a .git, .hg, .bzr or .svn directory. You can
|
|
||||||
;; customize this list of root markers by setting `fiplr-root-markers'.
|
|
||||||
;;
|
|
||||||
;; (setq fiplr-root-markers '(".git" ".svn"))
|
|
||||||
;;
|
|
||||||
;; Some files are ignored from the directory tree because they are not text
|
|
||||||
;; files, or simply to speed up the search. The default list can be
|
|
||||||
;; customized by setting `fiplr-ignored-globs'.
|
|
||||||
;;
|
|
||||||
;; (setq fiplr-ignored-globs '((directories (".git" ".svn"))
|
|
||||||
;; (files ("*.jpg" "*.png" "*.zip" "*~"))))
|
|
||||||
;;
|
|
||||||
;; These globs are used by the UNIX `find' command's -name flag.
|
|
||||||
;;
|
|
||||||
;; Usage:
|
|
||||||
;;
|
|
||||||
;; Find files: M-x fiplr-find-file
|
|
||||||
;; Find directories: M-x fiplr-find-directory
|
|
||||||
;; Clear caches: M-x fiplr-clear-cache
|
|
||||||
;;
|
|
||||||
;; For convenience, bind "C-x f" to `fiplr-find-file':
|
|
||||||
;;
|
|
||||||
;; (global-set-key (kbd "C-x f") 'fiplr-find-file)
|
|
||||||
;;
|
|
||||||
;; Because fiplr caches the project tree, you may sometimes wish to clear the
|
|
||||||
;; cache while searching. Use "C-c r" to do this.
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl-lib)
|
|
||||||
(require 'grizzl))
|
|
||||||
|
|
||||||
;;; --- Package Configuration
|
|
||||||
|
|
||||||
(defvar *fiplr-caches* '((files) (directories))
|
|
||||||
"Internal caches used by fiplr.")
|
|
||||||
|
|
||||||
(defvar *fiplr-default-root-markers* '(".git" ".svn" ".hg" ".bzr")
|
|
||||||
"A list of files/directories to look for that mark a project root.")
|
|
||||||
|
|
||||||
(defvar *fiplr-default-ignored-globs*
|
|
||||||
'((directories (".git" ".svn" ".hg" ".bzr"))
|
|
||||||
(files (".#*" "*~" "*.so" "*.jpg" "*.png" "*.gif" "*.pdf" "*.gz" "*.zip")))
|
|
||||||
"An alist of files and directories to exclude from searches.")
|
|
||||||
|
|
||||||
(defgroup fiplr nil
|
|
||||||
"Configuration options for fiplr - find in project."
|
|
||||||
:group 'convenience)
|
|
||||||
|
|
||||||
(defcustom fiplr-root-markers *fiplr-default-root-markers*
|
|
||||||
"A list of files or directories that are found at the root of a project."
|
|
||||||
:type '(repeat string)
|
|
||||||
:group 'fiplr)
|
|
||||||
|
|
||||||
(defcustom fiplr-ignored-globs *fiplr-default-ignored-globs*
|
|
||||||
"An alist of glob patterns to exclude from search results."
|
|
||||||
:type '(alist :key-type symbol :value-type (repeat string))
|
|
||||||
:group 'fiplr)
|
|
||||||
|
|
||||||
(defcustom fiplr-list-files-function 'fiplr-list-files
|
|
||||||
"A function receiving DIR, TYPE and IGNORED, returning a list of files.
|
|
||||||
|
|
||||||
DIR is the directory under which to locate files (recursively).
|
|
||||||
TYPE is one of the symboles 'FILES or 'DIRECTORIES.
|
|
||||||
IGNORED is an alist of glob patterns to exclude. Its keys are 'DIRECTORIES
|
|
||||||
and 'FILES, so that entire directories can be excluded.
|
|
||||||
|
|
||||||
This setting allows for cross-platform compatibility by abstracting away the
|
|
||||||
details of locating files in a directory tree. The default uses a GNU/BSD
|
|
||||||
compatible `find' command.
|
|
||||||
|
|
||||||
This function is only invoked once, when building the search index."
|
|
||||||
:type 'function
|
|
||||||
:group 'fiplr)
|
|
||||||
|
|
||||||
;;; --- Public Functions
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-file ()
|
|
||||||
"Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-file-in-directory (fiplr-root) fiplr-ignored-globs))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-file-other-window ()
|
|
||||||
"Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
file is opened using `find-file-other-window'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-file-in-directory (fiplr-root) fiplr-ignored-globs
|
|
||||||
#'find-file-other-window))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-file-other-frame ()
|
|
||||||
"Runs a completing prompt to find a file from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
file is opened using `find-file-other-frame'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-file-in-directory (fiplr-root) fiplr-ignored-globs
|
|
||||||
#'find-file-other-frame))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-directory ()
|
|
||||||
"Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-directory-in-directory (fiplr-root) fiplr-ignored-globs))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-directory-other-window ()
|
|
||||||
"Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
directory is opened using `dired-other-window'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-directory-in-directory (fiplr-root) fiplr-ignored-globs
|
|
||||||
#'dired-other-window))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-find-directory-other-frame ()
|
|
||||||
"Runs a completing prompt to find a directory from the project.
|
|
||||||
The root of the project is the return value of `fiplr-root'. The
|
|
||||||
directory is opened using `dired-other-frame'."
|
|
||||||
(interactive)
|
|
||||||
(fiplr-find-directory-in-directory (fiplr-root) fiplr-ignored-globs
|
|
||||||
#'dired-other-frame))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun fiplr-clear-cache ()
|
|
||||||
"Clears the internal caches used by fiplr so the project is searched again."
|
|
||||||
(interactive)
|
|
||||||
(setq *fiplr-caches*
|
|
||||||
(list (list 'files)
|
|
||||||
(list 'directories))))
|
|
||||||
|
|
||||||
;;; --- Minor Mode Definition
|
|
||||||
|
|
||||||
(defvar *fiplr-keymap* (make-sparse-keymap)
|
|
||||||
"Internal keymap used by the minor-mode in fiplr.")
|
|
||||||
|
|
||||||
(define-key *fiplr-keymap* (kbd "C-c r") 'fiplr-reload-list)
|
|
||||||
|
|
||||||
(define-minor-mode fiplr-mode
|
|
||||||
"Toggle the internal mode used by fiplr."
|
|
||||||
nil
|
|
||||||
" fiplr"
|
|
||||||
*fiplr-keymap*)
|
|
||||||
|
|
||||||
;;; --- Private Macros
|
|
||||||
|
|
||||||
(defmacro fiplr-cache (type)
|
|
||||||
"Get the internal cache used by fiplr for files of TYPE."
|
|
||||||
`(cdr (assoc ,type *fiplr-caches*)))
|
|
||||||
|
|
||||||
;;; --- Private Functions
|
|
||||||
|
|
||||||
(defun fiplr-root ()
|
|
||||||
"Locate the root of the project by walking up the directory tree.
|
|
||||||
The first directory containing one of fiplr-root-markers is the root.
|
|
||||||
If no root marker is found, the current working directory is used."
|
|
||||||
(let ((cwd (if (buffer-file-name)
|
|
||||||
(directory-file-name
|
|
||||||
(file-name-directory (buffer-file-name)))
|
|
||||||
(file-truename "."))))
|
|
||||||
(or (fiplr-find-root cwd fiplr-root-markers)
|
|
||||||
cwd)))
|
|
||||||
|
|
||||||
(defun fiplr-find-root (path root-markers)
|
|
||||||
"Tail-recursive part of project-root."
|
|
||||||
(let* ((this-dir (file-name-as-directory (file-truename path)))
|
|
||||||
(parent-dir (expand-file-name (concat this-dir "..")))
|
|
||||||
(system-root-dir (expand-file-name "/")))
|
|
||||||
(cond
|
|
||||||
((fiplr-root-p path root-markers) this-dir)
|
|
||||||
((equal system-root-dir this-dir) nil)
|
|
||||||
(t (fiplr-find-root parent-dir root-markers)))))
|
|
||||||
|
|
||||||
(defun fiplr-anyp (pred seq)
|
|
||||||
"True if any value in SEQ matches PRED."
|
|
||||||
(catch 'found
|
|
||||||
(cl-map nil (lambda (v)
|
|
||||||
(when (funcall pred v)
|
|
||||||
(throw 'found v)))
|
|
||||||
seq)))
|
|
||||||
|
|
||||||
(defun fiplr-root-p (path root-markers)
|
|
||||||
"Predicate to check if the given directory is a project root."
|
|
||||||
(let ((dir (file-name-as-directory path)))
|
|
||||||
(fiplr-anyp (lambda (marker)
|
|
||||||
(file-exists-p (concat dir marker)))
|
|
||||||
root-markers)))
|
|
||||||
|
|
||||||
(defun fiplr-list-files-shell-command (type path ignored-globs)
|
|
||||||
"Builds the `find' command to locate all project files & directories.
|
|
||||||
|
|
||||||
PATH is the base directory to recurse from.
|
|
||||||
IGNORED-GLOBS is an alist with keys 'DIRECTORIES and 'FILES."
|
|
||||||
(let* ((type-abbrev
|
|
||||||
(lambda (assoc-type)
|
|
||||||
(cl-case assoc-type
|
|
||||||
('directories "d")
|
|
||||||
('files "f"))))
|
|
||||||
(name-matcher
|
|
||||||
(lambda (glob)
|
|
||||||
(mapconcat 'identity
|
|
||||||
`("-name" ,(shell-quote-argument glob))
|
|
||||||
" ")))
|
|
||||||
(grouped-name-matchers
|
|
||||||
(lambda (type)
|
|
||||||
(mapconcat 'identity
|
|
||||||
`(,(shell-quote-argument "(")
|
|
||||||
,(mapconcat (lambda (v) (funcall name-matcher v))
|
|
||||||
(cadr (assoc type ignored-globs))
|
|
||||||
" -o ")
|
|
||||||
,(shell-quote-argument ")"))
|
|
||||||
" ")))
|
|
||||||
(matcher
|
|
||||||
(lambda (assoc-type)
|
|
||||||
(mapconcat 'identity
|
|
||||||
`(,(shell-quote-argument "(")
|
|
||||||
"-type"
|
|
||||||
,(funcall type-abbrev assoc-type)
|
|
||||||
,(funcall grouped-name-matchers assoc-type)
|
|
||||||
,(shell-quote-argument ")"))
|
|
||||||
" "))))
|
|
||||||
(mapconcat 'identity
|
|
||||||
`("find"
|
|
||||||
"-L"
|
|
||||||
,(shell-quote-argument (directory-file-name path))
|
|
||||||
,(funcall matcher 'directories)
|
|
||||||
"-prune"
|
|
||||||
"-o"
|
|
||||||
"-not"
|
|
||||||
,(funcall matcher 'files)
|
|
||||||
"-type"
|
|
||||||
,(funcall type-abbrev type)
|
|
||||||
"-print")
|
|
||||||
" ")))
|
|
||||||
|
|
||||||
(defun fiplr-list-files (type path ignored-globs)
|
|
||||||
"Expands to a flat list of files/directories found under PATH.
|
|
||||||
The first parameter TYPE is the symbol 'DIRECTORIES or 'FILES."
|
|
||||||
(let* ((prefix (file-name-as-directory (file-truename path)))
|
|
||||||
(prefix-length (length prefix))
|
|
||||||
(list-string
|
|
||||||
(shell-command-to-string (fiplr-list-files-shell-command
|
|
||||||
type
|
|
||||||
prefix
|
|
||||||
ignored-globs))))
|
|
||||||
(reverse (cl-reduce (lambda (acc file)
|
|
||||||
(if (> (length file) prefix-length)
|
|
||||||
(cons (substring file prefix-length) acc)
|
|
||||||
acc))
|
|
||||||
(split-string list-string "[\r\n]+" t)
|
|
||||||
:initial-value '()))))
|
|
||||||
|
|
||||||
(defun fiplr-reload-list ()
|
|
||||||
"Clear caches and reload the file listing."
|
|
||||||
(interactive)
|
|
||||||
(when (minibufferp)
|
|
||||||
(exit-minibuffer))
|
|
||||||
(fiplr-clear-cache)
|
|
||||||
(funcall last-command))
|
|
||||||
|
|
||||||
(defun fiplr-report-progress (n total)
|
|
||||||
"Show the number of files processed in the message area."
|
|
||||||
(when (= 0 (mod n 1000))
|
|
||||||
(message (format "Indexing (%d/%d)" n total))))
|
|
||||||
|
|
||||||
(defun fiplr-find-file-in-directory
|
|
||||||
(path ignored-globs &optional find-file-function)
|
|
||||||
"Locate a file under the specified PATH.
|
|
||||||
If the directory has been searched previously, the cache is used.
|
|
||||||
Use FIND-FILE-FUNCTION to open the selected file, or `find-file'
|
|
||||||
if FIND-FILE-FUNCTION is `nil'."
|
|
||||||
(let* ((root-dir (file-name-as-directory path))
|
|
||||||
(index (fiplr-get-index 'files root-dir ignored-globs))
|
|
||||||
(file (minibuffer-with-setup-hook
|
|
||||||
(lambda ()
|
|
||||||
(fiplr-mode 1))
|
|
||||||
(grizzl-completing-read (format "Find in project (%s)" root-dir)
|
|
||||||
index))))
|
|
||||||
(if (eq this-command 'fiplr-reload-list) ; exited for reload
|
|
||||||
(fiplr-reload-list)
|
|
||||||
(funcall (or find-file-function #'find-file)
|
|
||||||
(concat root-dir file)))))
|
|
||||||
|
|
||||||
(defun fiplr-find-directory-in-directory
|
|
||||||
(path ignored-globs &optional dired-function)
|
|
||||||
"Locate a directory and run dired under the specified PATH.
|
|
||||||
If the directory has been searched previously, the cache is used.
|
|
||||||
Use DIRED-FUNCTION to open the selected file, or `dired' if
|
|
||||||
DIRED-FUNCTION is `nil'."
|
|
||||||
(let* ((root-dir (file-name-as-directory path))
|
|
||||||
(index (fiplr-get-index 'directories root-dir ignored-globs))
|
|
||||||
(dir (minibuffer-with-setup-hook
|
|
||||||
(lambda ()
|
|
||||||
(fiplr-mode 1))
|
|
||||||
(grizzl-completing-read (format "Dired in project (%s)" root-dir)
|
|
||||||
index))))
|
|
||||||
(if (eq this-command 'fiplr-reload-list) ; exited for reload
|
|
||||||
(fiplr-reload-list)
|
|
||||||
(funcall (or dired-function #'dired) (concat root-dir dir)))))
|
|
||||||
|
|
||||||
(defun fiplr-get-index (type path ignored-globs)
|
|
||||||
"Internal function to lazily get a fiplr fuzzy search index."
|
|
||||||
(let ((fiplr-cache-key (cons path ignored-globs)))
|
|
||||||
(unless (assoc fiplr-cache-key (fiplr-cache type))
|
|
||||||
(message (format "Scanning... (%s)" path))
|
|
||||||
(push (cons fiplr-cache-key
|
|
||||||
(grizzl-make-index (funcall fiplr-list-files-function
|
|
||||||
type
|
|
||||||
path
|
|
||||||
ignored-globs)
|
|
||||||
:progress-fn #'fiplr-report-progress))
|
|
||||||
(fiplr-cache type)))
|
|
||||||
(cdr (assoc fiplr-cache-key (fiplr-cache type)))))
|
|
||||||
|
|
||||||
(provide 'fiplr)
|
|
||||||
|
|
||||||
;;; fiplr.el ends here
|
|
||||||
@ -1,269 +0,0 @@
|
|||||||
;;; gh-api.el --- api definition for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'json)
|
|
||||||
|
|
||||||
(require 'gh-profile)
|
|
||||||
(require 'gh-url)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-cache)
|
|
||||||
|
|
||||||
(require 'logito)
|
|
||||||
|
|
||||||
(defgroup gh-api nil
|
|
||||||
"Github API."
|
|
||||||
:group 'gh)
|
|
||||||
|
|
||||||
(defcustom gh-api-username-filter 'gh-api-enterprise-username-filter
|
|
||||||
"Filter to apply to usernames to build URL components"
|
|
||||||
:type 'function
|
|
||||||
:group 'gh-api)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api ()
|
|
||||||
((sync :initarg :sync :initform t)
|
|
||||||
(cache :initarg :cache :initform nil)
|
|
||||||
(base :initarg :base :type string)
|
|
||||||
(profile :initarg :profile :type string)
|
|
||||||
(auth :initarg :auth :initform nil)
|
|
||||||
(data-format :initarg :data-format)
|
|
||||||
(num-retries :initarg :num-retries :initform 0)
|
|
||||||
(log :initarg :log :initform nil)
|
|
||||||
(cache-cls :initform gh-cache :allocation :class))
|
|
||||||
"Github API")
|
|
||||||
|
|
||||||
(defmethod logito-log ((api gh-api) level tag string &rest objects)
|
|
||||||
(apply 'logito-log (oref api :log) level tag string objects))
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((api gh-api) &rest args)
|
|
||||||
(call-next-method))
|
|
||||||
|
|
||||||
(defmethod gh-api-set-default-auth ((api gh-api) auth)
|
|
||||||
(let ((auth (or (oref api :auth) auth))
|
|
||||||
(cache (oref api :cache))
|
|
||||||
(classname (symbol-name (funcall (if (fboundp 'eieio-object-class)
|
|
||||||
'eieio-object-class
|
|
||||||
'object-class)
|
|
||||||
api))))
|
|
||||||
(oset api :auth auth)
|
|
||||||
(unless (or (null cache)
|
|
||||||
(and (eieio-object-p cache)
|
|
||||||
(object-of-class-p cache 'gh-cache)))
|
|
||||||
(oset api :cache (make-instance
|
|
||||||
(oref api cache-cls)
|
|
||||||
:object-name
|
|
||||||
(format "gh/%s/%s"
|
|
||||||
classname
|
|
||||||
(gh-api-get-username api)))))))
|
|
||||||
|
|
||||||
(defmethod gh-api-expand-resource ((api gh-api)
|
|
||||||
resource)
|
|
||||||
resource)
|
|
||||||
|
|
||||||
(defun gh-api-enterprise-username-filter (username)
|
|
||||||
(replace-regexp-in-string (regexp-quote ".") "-" username))
|
|
||||||
|
|
||||||
(defmethod gh-api-get-username ((api gh-api))
|
|
||||||
(let ((username (oref (oref api :auth) :username)))
|
|
||||||
(funcall gh-api-username-filter username)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-v3 (gh-api)
|
|
||||||
((data-format :initarg :data-format :initform :json))
|
|
||||||
"Github API v3")
|
|
||||||
|
|
||||||
(defcustom gh-api-v3-authenticator 'gh-oauth-authenticator
|
|
||||||
"Authenticator for Github API v3"
|
|
||||||
:type '(choice (const :tag "Password" gh-password-authenticator)
|
|
||||||
(const :tag "OAuth" gh-oauth-authenticator))
|
|
||||||
:group 'gh-api)
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((api gh-api-v3) &rest args)
|
|
||||||
(call-next-method)
|
|
||||||
(let ((gh-profile-current-profile (gh-profile-current-profile)))
|
|
||||||
(oset api :profile (gh-profile-current-profile))
|
|
||||||
(oset api :base (gh-profile-url))
|
|
||||||
(gh-api-set-default-auth api
|
|
||||||
(or (oref api :auth)
|
|
||||||
(funcall gh-api-v3-authenticator "auth")))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-request (gh-url-request)
|
|
||||||
((default-response-cls :allocation :class :initform gh-api-response)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-response (gh-url-response)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defun gh-api-json-decode (repr)
|
|
||||||
(if (or (null repr) (string= repr ""))
|
|
||||||
'empty
|
|
||||||
(let ((json-array-type 'list))
|
|
||||||
(json-read-from-string repr))))
|
|
||||||
|
|
||||||
(defun gh-api-json-encode (json)
|
|
||||||
(json-encode-list json))
|
|
||||||
|
|
||||||
(defmethod gh-url-response-set-data ((resp gh-api-response) data)
|
|
||||||
(call-next-method resp (gh-api-json-decode data)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-paged-request (gh-api-request)
|
|
||||||
((default-response-cls :allocation :class :initform gh-api-paged-response)
|
|
||||||
(page-limit :initarg :page-limit :initform -1)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-paged-response (gh-api-response)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod gh-api-paging-links ((resp gh-api-paged-response))
|
|
||||||
(let ((links-header (cdr (assoc "Link" (oref resp :headers)))))
|
|
||||||
(when links-header
|
|
||||||
(loop for item in (split-string links-header ", ")
|
|
||||||
when (string-match "^<\\(.*\\)>; rel=\"\\(.*\\)\"" item)
|
|
||||||
collect (cons (match-string 2 item)
|
|
||||||
(match-string 1 item))))))
|
|
||||||
|
|
||||||
(defmethod gh-url-response-set-data ((resp gh-api-paged-response) data)
|
|
||||||
(let ((previous-data (oref resp :data))
|
|
||||||
(next (cdr (assoc "next" (gh-api-paging-links resp)))))
|
|
||||||
(call-next-method)
|
|
||||||
(oset resp :data (append previous-data (oref resp :data)))
|
|
||||||
(when (and next (not (equal 304 (oref resp :http-status))))
|
|
||||||
(let* ((req (oref resp :-req))
|
|
||||||
(last-page-limit (oref req :page-limit))
|
|
||||||
(this-page-limit (if (numberp last-page-limit) (- last-page-limit 1) -1)))
|
|
||||||
(oset req :page-limit this-page-limit)
|
|
||||||
(unless (eq (oref req :page-limit) 0)
|
|
||||||
;; We use an explicit check for 0 since -1 indicates that
|
|
||||||
;; paging should continue forever.
|
|
||||||
(oset resp :data-received nil)
|
|
||||||
(oset req :url next)
|
|
||||||
;; Params need to be set to nil because the next uri will
|
|
||||||
;; already have query params. If params are non-nil this will
|
|
||||||
;; cause another set of params to be added to the end of the
|
|
||||||
;; string which will override the params that are set in the
|
|
||||||
;; next link.
|
|
||||||
(oset req :query nil)
|
|
||||||
(gh-url-run-request req resp))))))
|
|
||||||
|
|
||||||
(defmethod gh-api-authenticated-request
|
|
||||||
((api gh-api) transformer method resource &optional data params page-limit)
|
|
||||||
(let* ((fmt (oref api :data-format))
|
|
||||||
(headers (cond ((eq fmt :form)
|
|
||||||
'(("Content-Type" .
|
|
||||||
"application/x-www-form-urlencoded")))
|
|
||||||
((eq fmt :json)
|
|
||||||
'(("Content-Type" .
|
|
||||||
"application/json")))))
|
|
||||||
(cache (oref api :cache))
|
|
||||||
(key (list resource
|
|
||||||
method
|
|
||||||
(sha1 (format "%s" transformer))))
|
|
||||||
(cache-key (and cache
|
|
||||||
(member method (oref cache safe-methods))
|
|
||||||
key))
|
|
||||||
(has-value (and cache-key (pcache-has cache cache-key)))
|
|
||||||
(value (and has-value (pcache-get cache cache-key)))
|
|
||||||
(is-outdated (and has-value (gh-cache-outdated-p cache cache-key)))
|
|
||||||
(etag (and is-outdated (gh-cache-etag cache cache-key)))
|
|
||||||
(req
|
|
||||||
(and (or (not has-value)
|
|
||||||
is-outdated)
|
|
||||||
(gh-auth-modify-request
|
|
||||||
(oref api :auth)
|
|
||||||
;; TODO: use gh-api-paged-request only when needed
|
|
||||||
(make-instance 'gh-api-paged-request
|
|
||||||
:method method
|
|
||||||
:url (concat (oref api :base)
|
|
||||||
(gh-api-expand-resource
|
|
||||||
api resource))
|
|
||||||
:query params
|
|
||||||
:headers (if etag
|
|
||||||
(cons (cons "If-None-Match" etag)
|
|
||||||
headers)
|
|
||||||
headers)
|
|
||||||
:data (or (and (eq fmt :json)
|
|
||||||
(gh-api-json-encode data))
|
|
||||||
(and (eq fmt :form)
|
|
||||||
(gh-url-form-encode data))
|
|
||||||
"")
|
|
||||||
:page-limit page-limit)))))
|
|
||||||
(cond ((and has-value ;; got value from cache
|
|
||||||
(not is-outdated))
|
|
||||||
(make-instance 'gh-api-response :data-received t :data value))
|
|
||||||
(cache-key ;; no value, but cache exists and method is safe
|
|
||||||
(let ((resp (make-instance (oref req default-response-cls)
|
|
||||||
:transform transformer)))
|
|
||||||
(gh-url-run-request req resp)
|
|
||||||
(gh-url-add-response-callback
|
|
||||||
resp (make-instance 'gh-api-callback :cache cache :key cache-key
|
|
||||||
:revive etag))
|
|
||||||
resp))
|
|
||||||
(cache ;; unsafe method, cache exists
|
|
||||||
(pcache-invalidate cache key)
|
|
||||||
(gh-url-run-request req (make-instance
|
|
||||||
(oref req default-response-cls)
|
|
||||||
:transform transformer)))
|
|
||||||
(t ;; no cache involved
|
|
||||||
(gh-url-run-request req (make-instance
|
|
||||||
(oref req default-response-cls)
|
|
||||||
:transform transformer))))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-api-callback (gh-url-callback)
|
|
||||||
((cache :initarg :cache)
|
|
||||||
(key :initarg :key)
|
|
||||||
(revive :initarg :revive)))
|
|
||||||
|
|
||||||
(defmethod gh-url-callback-run ((cb gh-api-callback) resp)
|
|
||||||
(let ((cache (oref cb :cache))
|
|
||||||
(key (oref cb :key)))
|
|
||||||
(if (and (oref cb :revive) (equal (oref resp :http-status) 304))
|
|
||||||
(progn
|
|
||||||
(gh-cache-revive cache key)
|
|
||||||
(oset resp :data (pcache-get cache key)))
|
|
||||||
(pcache-put cache key (oref resp :data))
|
|
||||||
(gh-cache-set-etag cache key
|
|
||||||
(cdr (assoc "ETag" (oref resp :headers)))))))
|
|
||||||
|
|
||||||
(define-obsolete-function-alias 'gh-api-add-response-callback
|
|
||||||
'gh-url-add-response-callback "0.6.0")
|
|
||||||
|
|
||||||
(provide 'gh-api)
|
|
||||||
;;; gh-api.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,174 +0,0 @@
|
|||||||
;;; gh-auth.el --- authentication for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-profile)
|
|
||||||
(require 'gh-common)
|
|
||||||
(require 'gh-url)
|
|
||||||
|
|
||||||
(defgroup gh-auth nil
|
|
||||||
"Github authentication."
|
|
||||||
:group 'gh)
|
|
||||||
|
|
||||||
(defvar gh-auth-alist nil)
|
|
||||||
|
|
||||||
(defun gh-auth-remember (profile key value)
|
|
||||||
(let ((cell (assoc profile gh-auth-alist)))
|
|
||||||
(when (not cell)
|
|
||||||
(setq cell (cons profile nil))
|
|
||||||
(setq gh-auth-alist (append gh-auth-alist (list cell))))
|
|
||||||
(setcdr cell (plist-put (cdr cell) key value))))
|
|
||||||
|
|
||||||
(defun gh-auth-get-username ()
|
|
||||||
(let* ((profile (gh-profile-current-profile))
|
|
||||||
(user (or (plist-get (cdr (assoc profile gh-auth-alist)) :username)
|
|
||||||
(plist-get (cdr (assoc profile gh-profile-alist)) :username)
|
|
||||||
(gh-config "user"))))
|
|
||||||
(when (not user)
|
|
||||||
(setq user (read-string "GitHub username: "))
|
|
||||||
(gh-set-config "user" user))
|
|
||||||
(gh-auth-remember profile :username user)
|
|
||||||
user))
|
|
||||||
|
|
||||||
(defun gh-auth-get-password (&optional remember)
|
|
||||||
(let* ((profile (gh-profile-current-profile))
|
|
||||||
(pass (or (plist-get (cdr (assoc profile gh-auth-alist)) :password)
|
|
||||||
(plist-get (cdr (assoc profile gh-profile-alist)) :password)
|
|
||||||
(gh-config "password"))))
|
|
||||||
(when (not pass)
|
|
||||||
(setq pass (read-passwd "GitHub password: "))
|
|
||||||
(gh-set-config "password" pass))
|
|
||||||
(when remember
|
|
||||||
(gh-auth-remember profile :password pass))
|
|
||||||
pass))
|
|
||||||
|
|
||||||
(declare-function 'gh-oauth-auth-new "gh-oauth")
|
|
||||||
|
|
||||||
(defun gh-auth-get-oauth-token ()
|
|
||||||
(let* ((profile (gh-profile-current-profile))
|
|
||||||
(token (or (plist-get (cdr (assoc profile gh-auth-alist)) :token)
|
|
||||||
(plist-get (cdr (assoc profile gh-profile-alist)) :token)
|
|
||||||
(gh-config "oauth-token"))))
|
|
||||||
(when (not token)
|
|
||||||
(let* ((api (make-instance 'gh-oauth-api))
|
|
||||||
(tok (and (fboundp 'gh-oauth-auth-new)
|
|
||||||
(oref (oref (funcall 'gh-oauth-auth-new api
|
|
||||||
'(user repo gist)) :data)
|
|
||||||
:token))))
|
|
||||||
(setq token (or tok (read-string "GitHub OAuth token: ")))
|
|
||||||
(gh-set-config "oauth-token" token)))
|
|
||||||
(gh-auth-remember profile :token token)
|
|
||||||
token))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-authenticator ()
|
|
||||||
((username :initarg :username :initform nil))
|
|
||||||
"Abstract authenticator")
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((auth gh-authenticator) &rest args)
|
|
||||||
(call-next-method)
|
|
||||||
(or (oref auth :username)
|
|
||||||
(oset auth :username (gh-auth-get-username))))
|
|
||||||
|
|
||||||
(defmethod gh-auth-modify-request ((auth gh-authenticator) req)
|
|
||||||
req)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-auth-2fa-callback (gh-url-callback)
|
|
||||||
((req :initarg :req :initform nil))
|
|
||||||
"2-factor callback")
|
|
||||||
|
|
||||||
(defmethod gh-url-callback-run ((cb gh-auth-2fa-callback) resp)
|
|
||||||
(when (equal (oref resp :http-status) 401)
|
|
||||||
(let* ((otp-header "X-GitHub-OTP")
|
|
||||||
(h (assoc otp-header (oref resp :headers))))
|
|
||||||
(when (and h (string-prefix-p "required;" (cdr h)))
|
|
||||||
(let ((otp (read-from-minibuffer "Enter dual-factor auth code: "))
|
|
||||||
(req (oref cb :req)))
|
|
||||||
;; reset resp
|
|
||||||
(oset resp :data nil)
|
|
||||||
(oset resp :data-received nil)
|
|
||||||
|
|
||||||
(object-add-to-list req :headers
|
|
||||||
(cons otp-header otp))
|
|
||||||
(gh-url-run-request req resp))))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-password-authenticator (gh-authenticator)
|
|
||||||
((password :initarg :password :protection :private :initform nil)
|
|
||||||
(remember :allocation :class :initform t)
|
|
||||||
|
|
||||||
(2fa-cls :initform gh-auth-2fa-callback :allocation :class))
|
|
||||||
"Password-based authenticator")
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((auth gh-password-authenticator) &rest args)
|
|
||||||
(call-next-method)
|
|
||||||
(or (oref auth :password)
|
|
||||||
(oset auth :password (gh-auth-get-password (oref auth remember)))))
|
|
||||||
|
|
||||||
(defmethod gh-auth-modify-request ((auth gh-password-authenticator) req)
|
|
||||||
(object-add-to-list req :headers
|
|
||||||
(cons "Authorization"
|
|
||||||
(concat "Basic "
|
|
||||||
(base64-encode-string
|
|
||||||
(format "%s:%s" (oref auth :username)
|
|
||||||
(encode-coding-string
|
|
||||||
(oref auth :password) 'utf-8))))))
|
|
||||||
(object-add-to-list req :install-callbacks
|
|
||||||
(make-instance (oref auth 2fa-cls) :req req))
|
|
||||||
req)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-oauth-authenticator (gh-authenticator)
|
|
||||||
((token :initarg :token :protection :private :initform nil))
|
|
||||||
"Oauth-based authenticator")
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((auth gh-oauth-authenticator) &rest args)
|
|
||||||
(call-next-method)
|
|
||||||
(or (oref auth :token)
|
|
||||||
(oset auth :token (gh-auth-get-oauth-token))))
|
|
||||||
|
|
||||||
(defmethod gh-auth-modify-request ((auth gh-oauth-authenticator) req)
|
|
||||||
(object-add-to-list req :headers
|
|
||||||
(cons "Authorization"
|
|
||||||
(format "token %s" (oref auth :token))))
|
|
||||||
req)
|
|
||||||
|
|
||||||
(provide 'gh-auth)
|
|
||||||
;; to avoid circular dependencies...
|
|
||||||
(require 'gh-oauth)
|
|
||||||
;;; gh-auth.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,255 +0,0 @@
|
|||||||
;;; gh-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-api" "gh-api.el" (22454 5329 956436 690000))
|
|
||||||
;;; Generated autoloads from gh-api.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api 'nil "gh-api" "Github API")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-v3 '(gh-api) "gh-api" "Github API v3")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-request '(gh-url-request) "gh-api" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-response '(gh-url-response) "gh-api" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-paged-request '(gh-api-request) "gh-api" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-paged-response '(gh-api-response) "gh-api" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-api-callback '(gh-url-callback) "gh-api" nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-auth" "gh-auth.el" (22454 5330 384446 754000))
|
|
||||||
;;; Generated autoloads from gh-auth.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-authenticator 'nil "gh-auth" "Abstract authenticator")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-auth-2fa-callback '(gh-url-callback) "gh-auth" "2-factor callback")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-password-authenticator '(gh-authenticator) "gh-auth" "Password-based authenticator")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-oauth-authenticator '(gh-authenticator) "gh-auth" "Oauth-based authenticator")
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-cache" "gh-cache.el" (22454 5330 226443
|
|
||||||
;;;;;; 38000))
|
|
||||||
;;; Generated autoloads from gh-cache.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-cache '(pcache-repository) "gh-cache" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-cache-entry '(pcache-entry) "gh-cache" nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-comments" "gh-comments.el" (22454 5329
|
|
||||||
;;;;;; 753431 916000))
|
|
||||||
;;; Generated autoloads from gh-comments.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-comments-api-mixin 'nil "gh-comments" :abstract)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-common" "gh-common.el" (22454 5330 91439
|
|
||||||
;;;;;; 864000))
|
|
||||||
;;; Generated autoloads from gh-common.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(autoload 'gh-marshal-default-spec "gh-common" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn SLOT)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'gh-defclass "gh-common" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn NAME SUPERCLASS SLOTS &rest OPTIONS-AND-DOC)" nil t)
|
|
||||||
|
|
||||||
(gh-defclass gh-object nil nil)
|
|
||||||
|
|
||||||
(gh-defclass gh-ref-object (gh-object) ((id :initarg :id) (url :initarg :url) (html-url :initarg :html-url)))
|
|
||||||
|
|
||||||
(gh-defclass gh-user (gh-ref-object) ((login :initarg :login) (gravatar-url :initarg :gravatar-url)) "Github user object")
|
|
||||||
|
|
||||||
(gh-defclass gh-comment (gh-ref-object) ((body :initarg :body) (user :initarg :user :initform nil :marshal-type gh-user) (created-at :initarg :created_at) (updated-at :initarg :updated_at)) "Github comment object")
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-gist" "gh-gist.el" (22454 5329 821433 515000))
|
|
||||||
;;; Generated autoloads from gh-gist.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-gist-api '(gh-api-v3) "gh-gist" "Gist API")
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-gist-stub (gh-object) ((files :initarg :files :type list :initform nil :marshal-type (list gh-gist-gist-file)) (public :initarg :public :marshal-type bool) (description :initarg :description)) "Class for user-created gist objects")
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-history-change (gh-object) ((total :initarg :total) (additions :initarg :additions) (deletions :initarg :deletions)))
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-history-entry (gh-object) ((user :initarg :user :initform nil :marshal-type gh-user) (version :initarg :version) (committed :initarg :committed :marshal ((alist . committed_at))) (change :initarg :change :marshal ((alist . change_status)) :marshal-type gh-gist-history-change) (url :initarg :url)))
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-fork-entry (gh-ref-object) ((user :initarg :user :initform nil :marshal-type gh-user) (created :initarg :created :marshal ((alist . created_at))) (updated :initarg :updated :marshal ((alist . updated_at)))))
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-gist (gh-ref-object gh-gist-gist-stub) ((date :initarg :date :marshal ((alist . created_at))) (update :initarg :update :marshal ((alist . updated_at))) (push-url :initarg :push-url :marshal ((alist . git_push_url))) (pull-url :initarg :pull-url :marshal ((alist . git_pull_url))) (comments :initarg :comments) (user :initarg :user :initform nil :marshal-type gh-user :marshal ((alist . owner))) (history :initarg :history :initform nil :type list :marshal-type (list gh-gist-history-entry)) (forks :initarg :forks :initform nil :type list :marshal-type (list gh-gist-fork-entry))) "Gist object")
|
|
||||||
|
|
||||||
(gh-defclass gh-gist-gist-file (gh-object) ((filename :initarg :filename) (size :initarg :size) (url :initarg :url :marshal ((alist . raw_url))) (content :initarg :content)))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-issue-comments" "gh-issue-comments.el"
|
|
||||||
;;;;;; (22454 5330 158441 440000))
|
|
||||||
;;; Generated autoloads from gh-issue-comments.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-issues" "gh-issues.el" (22454 5330 260443
|
|
||||||
;;;;;; 838000))
|
|
||||||
;;; Generated autoloads from gh-issues.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-issues-api '(gh-api-v3 gh-comments-api-mixin) "gh-issues" "Github Issues api")
|
|
||||||
|
|
||||||
(gh-defclass gh-issues-issue (gh-ref-object) ((number :initarg :number) (state :initarg :state) (title :initarg :title) (body :initarg :body) (user :initarg :user :initform nil :marshal-type gh-user) (labels :initarg :labels :initform nil :marshal-type (list gh-issues-label)) (assignee :initarg :assignee :initform nil :marshal-type gh-user) (milestone :initarg :milestone :initform nil :marshal-type gh-issues-milestone) (comments :initarg :comments :initform 0) (pull-request :initarg :pull-request :marshal-type gh-issues-pull-request) (closed-at :initarg :created-at) (created-at :initarg :created-at) (updated-at :initarg :updated-at)) "issues request")
|
|
||||||
|
|
||||||
(gh-defclass gh-issues-pull-request (gh-object) ((html-url :initarg :html-url) (diff-url :initarg :diff-url) (patch-url :initarg :patch-url)))
|
|
||||||
|
|
||||||
(gh-defclass gh-issues-label (gh-ref-object) ((name :initarg :name) (color :initarg :color)))
|
|
||||||
|
|
||||||
(gh-defclass gh-issues-milestone (gh-ref-object) ((number :initarg :number) (state :initarg :state) (title :initarg :title) (description :initarg :description) (creator :initarg :creator :initform nil :marshal-type gh-user) (open-issues :initarg :open-issues) (closed-issues :initarg :closed-issues) (created-at :initarg :created-at) (due-on :initarg :due-on)) "github milestone")
|
|
||||||
|
|
||||||
(gh-defclass gh-issues-comment (gh-comment) nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-oauth" "gh-oauth.el" (22454 5329 791432
|
|
||||||
;;;;;; 810000))
|
|
||||||
;;; Generated autoloads from gh-oauth.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-oauth-api '(gh-api-v3) "gh-oauth" "OAuth API")
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-oauth-password-authenticator '(gh-password-authenticator) "gh-oauth" nil)
|
|
||||||
|
|
||||||
(gh-defclass gh-oauth-authorization (gh-ref-object) ((scopes :initarg :scopes) (token :initarg :token) (app :initarg :app :initform nil :marshal-type gh-oauth-app) (updated-at :initarg :updated-at) (created-at :initarg :created-at)))
|
|
||||||
|
|
||||||
(gh-defclass gh-oauth-app (gh-object) ((url :initarg :url) (name :initarg :name)))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-orgs" "gh-orgs.el" (22454 5330 124440 640000))
|
|
||||||
;;; Generated autoloads from gh-orgs.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-orgs-api '(gh-api-v3) "gh-orgs" "Orgs API")
|
|
||||||
|
|
||||||
(gh-defclass gh-orgs-org-stub (gh-ref-object) ((login :initarg :login) (avatar-url :initarg :avatar-url) (description :initarg :description)))
|
|
||||||
|
|
||||||
(gh-defclass gh-orgs-plan (gh-object) ((name :initarg :name) (space :initarg :space) (private-repos :initarg :private-repos)))
|
|
||||||
|
|
||||||
(gh-defclass gh-orgs-org (gh-orgs-org-stub) ((name :initarg :name) (company :initarg :company) (blog :initarg :blog) (location :initarg :location) (email :initarg :email) (public-repos :initarg :public-repos) (public-gists :initarg :public-gists) (followers :initarg :followers) (following :initarg :following) (created-at :initarg :created-at) (type :initarg :type) (total-private-repos :initarg :total-private-repos) (owned-private-repos :initarg :owned-private-repos) (private-gists :initarg :private-gists) (disk-usage :initarg :disk-usage) (collaborators :initarg :collaborators) (billing-email :initarg :billing-email) (plan :initarg :plan :initform nil :marshal-type gh-orgs-plan)) "Class for GitHub organizations")
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-pull-comments" "gh-pull-comments.el" (22454
|
|
||||||
;;;;;; 5330 339445 696000))
|
|
||||||
;;; Generated autoloads from gh-pull-comments.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-pulls" "gh-pulls.el" (22454 5330 294444
|
|
||||||
;;;;;; 637000))
|
|
||||||
;;; Generated autoloads from gh-pulls.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-pulls-cache '(gh-cache) "gh-pulls" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-pulls-api '(gh-api-v3 gh-comments-api-mixin) "gh-pulls" "Git pull requests API")
|
|
||||||
|
|
||||||
(gh-defclass gh-pulls-comment (gh-comment) ((path :initarg :path) (diff-hunk :initarg :diff-hunk) (position :initarg :position) (original-position :initarg :original-position) (commit-id :initarg :commit-id) (original-commit-id :initarg :original-commit-id) (in-reply-to :initarg :in-reply-to :initform nil)))
|
|
||||||
|
|
||||||
(gh-defclass gh-pulls-request-stub (gh-ref-object) ((diff-url :initarg :diff-url) (patch-url :initarg :patch-url) (issue-url :initarg :issue-url) (number :initarg :number) (state :initarg :state) (title :initarg :title) (body :initarg :body) (created-at :initarg :created-at) (updated-at :initarg :updated-at) (closed-at :initarg :closed-at) (merged-at :initarg :merged-at) (head :initarg :head :initform nil :marshal-type gh-repos-ref) (base :initarg :base :initform nil :marshal-type gh-repos-ref)))
|
|
||||||
|
|
||||||
(gh-defclass gh-pulls-request (gh-pulls-request-stub) ((merged :initarg :merged) (mergeable :initarg :mergeable) (merged-by :initarg :merged-by) (comments :initarg :comments) (user :initarg :user :initform nil :marshal-type gh-user) (commits :initarg :commits) (additions :initarg :additions) (deletions :initarg :deletions) (changed-files :initarg :changed-files)) "Git pull requests API")
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-repos" "gh-repos.el" (22454 5330 192442
|
|
||||||
;;;;;; 239000))
|
|
||||||
;;; Generated autoloads from gh-repos.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-repos-api '(gh-api-v3) "gh-repos" "Repos API")
|
|
||||||
|
|
||||||
(gh-defclass gh-repos-repo-stub (gh-object) ((name :initarg :name) (description :initarg :description) (homepage :initarg :homepage) (private :initarg :private)) "Class for user-created repository objects")
|
|
||||||
|
|
||||||
(gh-defclass gh-repos-repo (gh-ref-object gh-repos-repo-stub) ((clone-url :initarg :clone-url) (git-url :initarg :git-url) (ssh-url :initarg :ssh-url) (svn-url :initarg :svn-url) (mirror-url :initarg :mirror-url) (owner :initarg :owner :initform nil :marshal-type gh-user) (full-name :initarg :full-name) (language :initarg :language) (fork :initarg :fork) (forks :initarg :forks) (forks-count :initarg :forks-count) (watchers :initarg :watchers) (watchers-count :initarg :watchers-count) (stargazers-count :initarg :stargazers-count) (size :initarg :size) (master-branch :initarg :master-branch) (open-issues :initarg :open-issues) (pushed-at :initarg :pushed-at) (created-at :initarg :created-at) (updated-at :initarg :updated-at) (organisation :initarg :organisation :initform nil :marshal-type gh-user) (parent :initarg :parent :marshal-type gh-repos-repo) (source :initarg :source :marshal-type gh-repos-repo) (has-issues :initarg :has-issues) (has-wiki :initarg :has-wiki) (has-downloads :initarg :has-downloads)) "Class for GitHub repositories")
|
|
||||||
|
|
||||||
(gh-defclass gh-repos-ref (gh-object) ((label :initarg :label) (ref :initarg :ref :initform nil) (sha :initarg :sha :initform nil) (user :initarg :user :initform nil :marshal-type gh-user) (repo :initarg :repo :initform nil :marshal-type gh-repos-repo)))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-search" "gh-search.el" (22454 5329 866434
|
|
||||||
;;;;;; 573000))
|
|
||||||
;;; Generated autoloads from gh-search.el
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-search-api '(gh-api-v3) "gh-search" nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-url" "gh-url.el" (22454 5329 685430 317000))
|
|
||||||
;;; Generated autoloads from gh-url.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-url-request 'nil "gh-url" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-url-response 'nil "gh-url" nil)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-url-callback 'nil "gh-url" nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "gh-users" "gh-users.el" (22454 5330 46438
|
|
||||||
;;;;;; 806000))
|
|
||||||
;;; Generated autoloads from gh-users.el
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(eieio-defclass-autoload 'gh-users-api '(gh-api-v3) "gh-users" "Users API")
|
|
||||||
|
|
||||||
(gh-defclass gh-users-user (gh-user) ((gravatar-id :initarg :gravatar-id) (html-url :initarg :html-url) (followers-url :initarg :followers-url) (following-url :initarg :following-url) (gists-url :initarg :gists-url) (starred-url :initarg :starred-url) (subscriptions-url :initarg :subscriptions-url) (organizations-url :initarg :organizations-url) (repos-url :initarg :repos-url) (events-url :initarg :events-url) (received-events-url :initarg :received-events-url) (type :initarg :type) (site-admin :initarg :site-admin) (name :initarg :name) (company :initarg :company) (blog :initarg :blog) (location :initarg :location) (email :initarg :email) (hireable :initarg :hireable) (bio :initarg :bio) (public-repos :initarg :public-repos) (public-gists :initarg :public-gists) (followers :initarg :followers) (following :initarg :following) (created-at :initarg :created-at) (update-at :initarg :update-at)))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("gh-pkg.el" "gh-profile.el" "gh.el") (22454
|
|
||||||
;;;;;; 5330 1437 747000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; gh-autoloads.el ends here
|
|
||||||
@ -1,138 +0,0 @@
|
|||||||
;;; gh-cache.el --- caching for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'pcache)
|
|
||||||
|
|
||||||
(defconst gh-cache-outdated-expiration-delay (* 60 60 24))
|
|
||||||
|
|
||||||
(defconst gh-cache-internal-version-constant 4)
|
|
||||||
|
|
||||||
(defconst gh-cache-version-constant
|
|
||||||
(format "%s/gh-%s" pcache-version-constant gh-cache-internal-version-constant))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-cache (pcache-repository)
|
|
||||||
((version-constant :allocation :class)
|
|
||||||
(entries :initarg :entries :initform (make-hash-table :test 'equal))
|
|
||||||
(safe-methods :allocation :class :initform ("HEAD" "GET" "OPTIONS" "TRACE"))
|
|
||||||
(invalidation-chain :allocation :class :initform nil)
|
|
||||||
|
|
||||||
(entry-cls :initarg :entry-cls :initform gh-cache-entry)))
|
|
||||||
|
|
||||||
(oset-default 'gh-cache version-constant gh-cache-version-constant)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-cache-entry (pcache-entry)
|
|
||||||
((etag :initarg :etag :initform nil)
|
|
||||||
(outdated :initarg :outdated :initform nil)
|
|
||||||
;; (ttl :initarg :ttl :initform 0)
|
|
||||||
))
|
|
||||||
|
|
||||||
(defmethod pcache-invalidate :after ((cache gh-cache) key)
|
|
||||||
(let ((resource (car key)))
|
|
||||||
(pcache-map cache #'(lambda (k v)
|
|
||||||
(when (equal (car k) resource)
|
|
||||||
(pcache-invalidate cache k))))
|
|
||||||
(dolist (next (oref cache invalidation-chain))
|
|
||||||
(let ((nextresource
|
|
||||||
(replace-regexp-in-string (car next) (cdr next) resource)))
|
|
||||||
(when (not (equal nextresource resource))
|
|
||||||
(pcache-map cache #'(lambda (k v)
|
|
||||||
(when (equal (car k) nextresource)
|
|
||||||
(pcache-invalidate cache k)))))))))
|
|
||||||
|
|
||||||
(defmethod pcache-get ((cache gh-cache) key &optional default)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(if (not entry)
|
|
||||||
default
|
|
||||||
(unless (pcache-entry-valid-p entry)
|
|
||||||
(oset entry :outdated t))
|
|
||||||
(oref entry :value))))
|
|
||||||
|
|
||||||
(defmethod pcache-has ((cache pcache-repository) key)
|
|
||||||
(let* ((default (make-symbol ":nil"))
|
|
||||||
(table (oref cache :entries))
|
|
||||||
(entry (gethash key table default)))
|
|
||||||
(not (eq entry default))))
|
|
||||||
|
|
||||||
(defmethod pcache-purge-invalid ((cache gh-cache))
|
|
||||||
(let ((table (oref cache :entries)))
|
|
||||||
(maphash #'(lambda (k e)
|
|
||||||
(unless (gh-cache-expired-p e)
|
|
||||||
(remhash k table)))
|
|
||||||
table)
|
|
||||||
(pcache-save cache)))
|
|
||||||
|
|
||||||
(defmethod gh-cache-outdated-p ((cache gh-cache) key)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(and entry
|
|
||||||
(oref entry :outdated))))
|
|
||||||
|
|
||||||
(defmethod gh-cache-expired-p ((cache gh-cache) key)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(and (gh-cache-outdated-p cache key)
|
|
||||||
(not
|
|
||||||
(let ((time (float-time (current-time))))
|
|
||||||
(< time (+ gh-cache-outdated-expiration-delay
|
|
||||||
(oref entry :timestamp))))))))
|
|
||||||
|
|
||||||
(defmethod gh-cache-revive ((cache gh-cache) key)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(and entry
|
|
||||||
(oset entry :outdated nil)
|
|
||||||
(oset entry :timestamp (float-time (current-time)))
|
|
||||||
t)))
|
|
||||||
|
|
||||||
(defmethod gh-cache-etag ((cache gh-cache) key)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(and entry
|
|
||||||
(oref entry :etag))))
|
|
||||||
|
|
||||||
(defmethod gh-cache-set-etag ((cache gh-cache) key etag)
|
|
||||||
(let* ((table (oref cache :entries))
|
|
||||||
(entry (gethash key table)))
|
|
||||||
(and entry
|
|
||||||
(oset entry :etag etag))))
|
|
||||||
|
|
||||||
(provide 'gh-cache)
|
|
||||||
;;; gh-cache.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,71 +0,0 @@
|
|||||||
;;; gh-comments.el --- support for comment-enabled APIs
|
|
||||||
|
|
||||||
;; Copyright (C) 2014-2015 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <hodiquey@vmware.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-common)
|
|
||||||
(require 'gh-api)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-comments-api-mixin ()
|
|
||||||
((comment-cls :allocation :class :initform gh-comment))
|
|
||||||
:abstract t)
|
|
||||||
|
|
||||||
(defmethod gh-comments-list ((api gh-comments-api-mixin) base)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api comment-cls)) "GET"
|
|
||||||
(format "%s/comments" (gh-ref-object-base base))))
|
|
||||||
|
|
||||||
(defmethod gh-comments-get ((api gh-comments-api-mixin) base comment-id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api comment-cls)) "GET"
|
|
||||||
(format "%s/comments/%s" (gh-ref-object-base base) comment-id)))
|
|
||||||
|
|
||||||
(defmethod gh-comments-update ((api gh-comments-api-mixin) base comment-id comment)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api comment-cls)) "PATCH"
|
|
||||||
(format "%s/comments/%s" (gh-ref-object-base base) comment-id)
|
|
||||||
(gh-comment-req-to-update comment)))
|
|
||||||
|
|
||||||
(defmethod gh-comments-new ((api gh-comments-api-mixin) base comment)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api comment-cls)) "POST"
|
|
||||||
(format "%s/comments" (gh-ref-object-base base))
|
|
||||||
(gh-comment-req-to-update comment)))
|
|
||||||
|
|
||||||
(defmethod gh-comments-delete ((api gh-comments-api-mixin) base comment-id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "DELETE"
|
|
||||||
(format "%s/comments/%s" (gh-ref-object-base base) comment-id)))
|
|
||||||
|
|
||||||
(provide 'gh-comments)
|
|
||||||
;;; gh-comments.el ends here
|
|
||||||
@ -1,152 +0,0 @@
|
|||||||
;;; gh-common.el --- common objects for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'dash)
|
|
||||||
(require 'marshal)
|
|
||||||
(require 's)
|
|
||||||
(require 'gh-profile)
|
|
||||||
|
|
||||||
(defgroup gh nil
|
|
||||||
"Github API client libraries."
|
|
||||||
:group 'applications)
|
|
||||||
|
|
||||||
;;; Helper functions
|
|
||||||
|
|
||||||
(defun gh-read (obj field)
|
|
||||||
(cdr (assoc field obj)))
|
|
||||||
|
|
||||||
(defun gh-namespaced-key (key)
|
|
||||||
(let ((profile (gh-profile-current-profile)))
|
|
||||||
(concat "github."
|
|
||||||
(if (string= profile gh-profile-default-profile)
|
|
||||||
""
|
|
||||||
(concat profile "."))
|
|
||||||
key)))
|
|
||||||
|
|
||||||
(defun gh-config (key)
|
|
||||||
"Returns a GitHub specific value from the global Git config."
|
|
||||||
(let ((strip (lambda (string)
|
|
||||||
(if (> (length string) 0)
|
|
||||||
(substring string 0 (- (length string) 1))))))
|
|
||||||
(funcall strip (gh-command-to-string "config" (gh-namespaced-key key)))))
|
|
||||||
|
|
||||||
(defun gh-set-config (key value)
|
|
||||||
"Sets a GitHub specific value to the global Git config."
|
|
||||||
(gh-command-to-string "config" "--global" (gh-namespaced-key key) value))
|
|
||||||
|
|
||||||
(defun gh-command-to-string (&rest args)
|
|
||||||
(let ((git (executable-find "git")))
|
|
||||||
(with-output-to-string
|
|
||||||
(apply 'process-file git nil standard-output nil args))))
|
|
||||||
|
|
||||||
;;; Base classes for common objects
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun gh-marshal-default-spec (slot)
|
|
||||||
(let ((slot-name (symbol-name slot)))
|
|
||||||
(list (cons 'alist
|
|
||||||
(intern (s-replace "-" "_" slot-name))))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defmacro gh-defclass (name superclass slots &rest options-and-doc)
|
|
||||||
`(marshal-defclass ,name ,superclass ,slots ,@options-and-doc
|
|
||||||
:marshal-default-spec gh-marshal-default-spec))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-object ()
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod gh-object-read :static ((obj gh-object) data)
|
|
||||||
(let ((target (if (object-p obj) obj
|
|
||||||
(make-instance obj))))
|
|
||||||
(when data
|
|
||||||
(gh-object-read-into target data))
|
|
||||||
target))
|
|
||||||
|
|
||||||
(defmethod gh-object-reader :static ((obj gh-object))
|
|
||||||
(apply-partially 'gh-object-read obj))
|
|
||||||
|
|
||||||
(defmethod gh-object-list-read :static ((obj gh-object) data)
|
|
||||||
(mapcar (gh-object-reader obj) data))
|
|
||||||
|
|
||||||
(defmethod gh-object-list-reader :static ((obj gh-object))
|
|
||||||
(apply-partially 'gh-object-list-read obj))
|
|
||||||
|
|
||||||
(defmethod gh-object-read-into ((obj gh-object) data)
|
|
||||||
(unmarshal obj data 'alist))
|
|
||||||
|
|
||||||
(defmethod slot-unbound ((obj gh-object) cls slot-name fn)
|
|
||||||
(if (eq fn 'oref) nil
|
|
||||||
(call-next-method)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-ref-object (gh-object)
|
|
||||||
((id :initarg :id)
|
|
||||||
(url :initarg :url)
|
|
||||||
(html-url :initarg :html-url)))
|
|
||||||
|
|
||||||
(defmethod gh-ref-object-base ((obj gh-ref-object))
|
|
||||||
(let ((url (oref obj :url)))
|
|
||||||
(--> (s-split "/" url t)
|
|
||||||
(-slice it 2)
|
|
||||||
(s-join "/" it)
|
|
||||||
(concat "/" it))))
|
|
||||||
|
|
||||||
(defmethod gh-ref-object-base (obj)
|
|
||||||
(if (stringp obj) obj
|
|
||||||
(error "illegal input for `gh-ref-object-base'")))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-user (gh-ref-object)
|
|
||||||
((login :initarg :login)
|
|
||||||
(gravatar-url :initarg :gravatar-url))
|
|
||||||
"Github user object")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-comment (gh-ref-object)
|
|
||||||
((body :initarg :body)
|
|
||||||
(user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(created-at :initarg :created_at)
|
|
||||||
(updated-at :initarg :updated_at))
|
|
||||||
"Github comment object")
|
|
||||||
|
|
||||||
(defmethod gh-comment-req-to-update ((req gh-comment))
|
|
||||||
`(("body" . ,(oref req :body))))
|
|
||||||
|
|
||||||
(provide 'gh-common)
|
|
||||||
;;; gh-common.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,176 +0,0 @@
|
|||||||
;;; gh-gist.el --- gist module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-gist-api (gh-api-v3)
|
|
||||||
((gist-cls :allocation :class :initform gh-gist-gist))
|
|
||||||
"Gist API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-gist-stub (gh-object)
|
|
||||||
((files :initarg :files :type list :initform nil :marshal-type (list gh-gist-gist-file))
|
|
||||||
(public :initarg :public :marshal-type bool)
|
|
||||||
(description :initarg :description))
|
|
||||||
"Class for user-created gist objects")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-history-change (gh-object)
|
|
||||||
((total :initarg :total)
|
|
||||||
(additions :initarg :additions)
|
|
||||||
(deletions :initarg :deletions)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-history-entry (gh-object)
|
|
||||||
((user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(version :initarg :version)
|
|
||||||
(committed :initarg :committed :marshal ((alist . committed_at)))
|
|
||||||
(change :initarg :change :marshal ((alist . change_status))
|
|
||||||
:marshal-type gh-gist-history-change)
|
|
||||||
(url :initarg :url)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-fork-entry (gh-ref-object)
|
|
||||||
((user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(created :initarg :created :marshal ((alist . created_at)))
|
|
||||||
(updated :initarg :updated :marshal ((alist . updated_at)))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-gist (gh-ref-object gh-gist-gist-stub)
|
|
||||||
((date :initarg :date :marshal ((alist . created_at)))
|
|
||||||
(update :initarg :update :marshal ((alist . updated_at)))
|
|
||||||
(push-url :initarg :push-url :marshal ((alist . git_push_url)))
|
|
||||||
(pull-url :initarg :pull-url :marshal ((alist . git_pull_url)))
|
|
||||||
(comments :initarg :comments)
|
|
||||||
(user :initarg :user :initform nil :marshal-type gh-user :marshal ((alist . owner)))
|
|
||||||
(history :initarg :history :initform nil :type list :marshal-type (list gh-gist-history-entry))
|
|
||||||
(forks :initarg :forks :initform nil :type list :marshal-type (list gh-gist-fork-entry)))
|
|
||||||
"Gist object")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-gist-gist-file (gh-object)
|
|
||||||
((filename :initarg :filename)
|
|
||||||
(size :initarg :size)
|
|
||||||
(url :initarg :url :marshal ((alist . raw_url)))
|
|
||||||
(content :initarg :content)))
|
|
||||||
|
|
||||||
(defmethod gh-gist-gist-to-obj ((gist gh-gist-gist-stub))
|
|
||||||
(let ((files (mapcar #'gh-gist-gist-file-to-obj (oref gist :files))))
|
|
||||||
`(("description" . ,(oref gist :description))
|
|
||||||
("public" . ,(oref gist :public))
|
|
||||||
,@(and files (list (cons "files" files))))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-gist-has-files ((gist gh-gist-gist-stub))
|
|
||||||
(not (memq nil (mapcar (lambda (f)
|
|
||||||
(oref f :content)) (oref gist :files)))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-gist-file-to-obj ((file gh-gist-gist-file))
|
|
||||||
(let* ((filename (oref file :filename))
|
|
||||||
(content (oref file :content))
|
|
||||||
(file (if content
|
|
||||||
`(("filename" . ,filename)
|
|
||||||
("content" . ,content))
|
|
||||||
nil)))
|
|
||||||
(cons filename file)))
|
|
||||||
|
|
||||||
(defmethod gh-gist-list ((api gh-gist-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api gist-cls)) "GET"
|
|
||||||
(format "/users/%s/gists" (or username (gh-api-get-username api)))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-list-public ((api gh-gist-api))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api gist-cls)) "GET" "/gists/public"))
|
|
||||||
|
|
||||||
(defmethod gh-gist-list-starred ((api gh-gist-api))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api gist-cls)) "GET" "/gists/starred"))
|
|
||||||
|
|
||||||
(defmethod gh-gist-get ((api gh-gist-api) gist-or-id)
|
|
||||||
(let (id transformer)
|
|
||||||
(if (stringp gist-or-id)
|
|
||||||
(setq id gist-or-id
|
|
||||||
transformer (gh-object-reader (oref api gist-cls)))
|
|
||||||
(setq id (oref gist-or-id :id)
|
|
||||||
transformer (gh-object-reader gist-or-id)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api transformer "GET" (format "/gists/%s" id))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-new ((api gh-gist-api) gist-stub)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api gist-cls)) "POST" "/gists"
|
|
||||||
(gh-gist-gist-to-obj gist-stub)))
|
|
||||||
|
|
||||||
(defmethod gh-gist-edit ((api gh-gist-api) gist)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api gist-cls)) "PATCH"
|
|
||||||
(format "/gists/%s"
|
|
||||||
(oref gist :id))
|
|
||||||
(gh-gist-gist-to-obj gist)))
|
|
||||||
|
|
||||||
(defmethod gh-gist-set-star ((api gh-gist-api) gist-or-id star)
|
|
||||||
(let ((id (if (stringp gist-or-id) gist-or-id
|
|
||||||
(oref gist-or-id :id))))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api 'ignore (if star "PUT" "DELETE")
|
|
||||||
(format "/gists/%s/star" id))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-get-star ((api gh-gist-api) gist-or-id)
|
|
||||||
(let ((id (if (stringp gist-or-id) gist-or-id
|
|
||||||
(oref gist-or-id :id))))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api 'ignore "GET" (format "/gists/%s/star" id))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-fork ((api gh-gist-api) gist-or-id)
|
|
||||||
(let ((id (if (stringp gist-or-id) gist-or-id
|
|
||||||
(oref gist-or-id :id))))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api gist-cls)) "POST"
|
|
||||||
(format "/gists/%s/forks" id))))
|
|
||||||
|
|
||||||
(defmethod gh-gist-delete ((api gh-gist-api) gist-or-id)
|
|
||||||
(let ((id (if (stringp gist-or-id) gist-or-id
|
|
||||||
(oref gist-or-id :id))))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api 'ignore "DELETE" (format "/gists/%s" id))))
|
|
||||||
|
|
||||||
(provide 'gh-gist)
|
|
||||||
;;; gh-gist.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,72 +0,0 @@
|
|||||||
;;; gh-issue-comments.el --- issue comments api for github
|
|
||||||
|
|
||||||
;; Copyright (C) 2014 Travis Thieman
|
|
||||||
|
|
||||||
;; Author: Travis Thieman <travis.thieman@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; 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:
|
|
||||||
|
|
||||||
;; TODOS:
|
|
||||||
;; * Support listing all comments in a repository
|
|
||||||
|
|
||||||
;; Basic usage:
|
|
||||||
|
|
||||||
;; (setf api (gh-issue-comments-api "api" :sync nil :cache nil :num-retries 1))
|
|
||||||
;; (setf comments (gh-issue-comments-list api "user" "repo" "issue id"))
|
|
||||||
;; (setq my-comment (make-instance 'gh-issue-comments-comment :body "This is great!"))
|
|
||||||
;; (gh-issue-comments-new api "user" "repo" "issue id" my-comment)
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
(require 'gh-issues)
|
|
||||||
|
|
||||||
(let ((ver "1.0.0"))
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-api 'gh-issues-api ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-comment 'gh-issues-comment ver)
|
|
||||||
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-req-to-update 'gh-comment-req-to-update ver)
|
|
||||||
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-list 'gh-issues-comments-list ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-get 'gh-issues-comments-get ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-update 'gh-issues-comments-update ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-new 'gh-issues-comments-new ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-issue-comments-delete 'gh-issues-comments-delete ver))
|
|
||||||
|
|
||||||
(provide 'gh-issue-comments)
|
|
||||||
;;; gh-issue-comments.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,281 +0,0 @@
|
|||||||
;;; gh-issues.el --- issues api for github
|
|
||||||
|
|
||||||
;; Copyright (C) 2014-2015 Yann Hodique
|
|
||||||
;; Copyright (C) 2014 Travis Thieman
|
|
||||||
;; Copyright (C) 2012 Raimon Grau
|
|
||||||
|
|
||||||
;; Author: Raimon Grau <raimonster@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; 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:
|
|
||||||
|
|
||||||
;; Basic usage:
|
|
||||||
|
|
||||||
;; (setf api (gh-issues-api "api" :sync nil :cache nil :num-retries 1))
|
|
||||||
;; (setf issues (gh-issues-list api "user" "repo"))
|
|
||||||
;; (last (oref issues data)) ; get one issue
|
|
||||||
;; (setq mi (make-instance 'gh-issues-issue :body "issue body" :title "issue title"))
|
|
||||||
;; (gh-issues-issue-new api "user" "repo" mi)
|
|
||||||
;; (setf comments (gh-issues-comments-list api "user" "repo" "issue id"))
|
|
||||||
;; (setq my-comment (make-instance 'gh-issues-comment :body "This is great!"))
|
|
||||||
;; (gh-issues-comments-new api "user" "repo" "issue id" my-comment)
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-comments)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
(require 'gh-repos)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-issues-api (gh-api-v3 gh-comments-api-mixin)
|
|
||||||
((issue-cls :allocation :class :initform gh-issues-issue)
|
|
||||||
(milestone-cls :allocation :class :initform gh-issues-milestone)
|
|
||||||
(label-cls :allocation :class :initform gh-issues-label)
|
|
||||||
(comment-cls :allocation :class :initform gh-issues-comment))
|
|
||||||
"Github Issues api")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-issues-issue (gh-ref-object)
|
|
||||||
((number :initarg :number)
|
|
||||||
(state :initarg :state)
|
|
||||||
(title :initarg :title)
|
|
||||||
(body :initarg :body)
|
|
||||||
(user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(labels :initarg :labels :initform nil :marshal-type (list gh-issues-label))
|
|
||||||
(assignee :initarg :assignee :initform nil :marshal-type gh-user)
|
|
||||||
(milestone :initarg :milestone :initform nil :marshal-type gh-issues-milestone)
|
|
||||||
(comments :initarg :comments :initform 0)
|
|
||||||
(pull-request :initarg :pull-request :marshal-type gh-issues-pull-request)
|
|
||||||
(closed-at :initarg :created-at)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(updated-at :initarg :updated-at))
|
|
||||||
"issues request")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-issues-pull-request (gh-object)
|
|
||||||
((html-url :initarg :html-url)
|
|
||||||
(diff-url :initarg :diff-url)
|
|
||||||
(patch-url :initarg :patch-url)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-issues-label (gh-ref-object)
|
|
||||||
((name :initarg :name)
|
|
||||||
(color :initarg :color)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-req-to-update ((label gh-issues-label))
|
|
||||||
`(("name" . ,(oref label :name))
|
|
||||||
("color" . ,(oref label :color))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-issues-milestone (gh-ref-object)
|
|
||||||
((number :initarg :number)
|
|
||||||
(state :initarg :state)
|
|
||||||
(title :initarg :title)
|
|
||||||
(description :initarg :description)
|
|
||||||
(creator :initarg :creator :initform nil :marshal-type gh-user)
|
|
||||||
(open-issues :initarg :open-issues )
|
|
||||||
(closed-issues :initarg :closed-issues)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(due-on :initarg :due-on))
|
|
||||||
"github milestone")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-issues-comment (gh-comment)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod gh-issues-issue-list ((api gh-issues-api) user repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api issue-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/issues" user repo)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-milestone-list ((api gh-issues-api) user repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api milestone-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/milestones" user repo)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-milestone-get ((api gh-issues-api) user repo id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api milestone-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/milestones/%s" user repo id)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-milestone-new ((api gh-issues-api) user repo milestone)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api milestone-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/milestones" user repo)
|
|
||||||
(gh-issues-milestone-req-to-update milestone)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-milestone-update ((api gh-issues-api) user repo
|
|
||||||
id milestone)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api milestone-cls)) "PATCH"
|
|
||||||
(format "/repos/%s/%s/milestones/%s" user repo id)
|
|
||||||
(gh-issues-milestone-req-to-update milestone)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-milestone-req-to-update ((milestone gh-issues-milestone))
|
|
||||||
(let ((state (oref milestone :state))
|
|
||||||
(description (oref milestone :description))
|
|
||||||
(due-on (oref milestone :due-on))
|
|
||||||
(to-update `(("title" . ,(oref milestone :title)))))
|
|
||||||
(when state (nconc to-update `(("state" . ,state))))
|
|
||||||
(when description (nconc to-update `(("description" . ,description))))
|
|
||||||
(when due-on (nconc to-update `(("due_on" . ,due-on))))
|
|
||||||
to-update))
|
|
||||||
|
|
||||||
(defmethod gh-issues-issue-get ((api gh-issues-api) user repo id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api issue-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/issues/%s" user repo id)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-issue-req-to-update ((req gh-issues-issue))
|
|
||||||
(let ((assignee (oref req :assignee))
|
|
||||||
;; (labels (oref req labels))
|
|
||||||
(milestone (oref req :milestone))
|
|
||||||
(to-update `(("title" . ,(oref req :title))
|
|
||||||
("state" . ,(oref req :state))
|
|
||||||
("body" . ,(oref req :body)))))
|
|
||||||
|
|
||||||
;; (when labels (nconc to-update `(("labels" . ,(oref req labels) ))))
|
|
||||||
(when milestone
|
|
||||||
(nconc to-update `(("milestone" . ,(oref milestone :number)))))
|
|
||||||
(when assignee
|
|
||||||
(nconc to-update `(("assignee" . ,(oref assignee :login)))))
|
|
||||||
to-update))
|
|
||||||
|
|
||||||
(defmethod gh-issues-issue-update ((api gh-issues-api) user repo id req)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api issue-cls)) "PATCH"
|
|
||||||
(format "/repos/%s/%s/issues/%s" user repo id)
|
|
||||||
(gh-issues-issue-req-to-update req)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-issue-new ((api gh-issues-api) user repo issue)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api issue-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/issues" user repo)
|
|
||||||
(gh-issues-issue-req-to-update issue)))
|
|
||||||
|
|
||||||
;;; Labels
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-get ((api gh-issues-api) user repo name)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api label-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/labels/%s" user repo name)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-list ((api gh-issues-api) user repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api label-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/labels" user repo )))
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-new ((api gh-issues-api) user repo req)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api label-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/labels" user repo)
|
|
||||||
(gh-issues-label-req-to-update req)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-update ((api gh-issues-api) user repo req)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api label-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/labels/%s" user repo (oref req :name))
|
|
||||||
(gh-issues-label-req-to-update req)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-label-delete ((api gh-issues-api) user repo name)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api label-cls)) "DELETE"
|
|
||||||
(format "/repos/%s/%s/labels/%s" user repo name)))
|
|
||||||
|
|
||||||
|
|
||||||
(defmethod gh-issues-labels-in-issue ((api gh-issues-api) user repo
|
|
||||||
issue-or-issue-id)
|
|
||||||
(let ((issue-id (gh-issues--issue-id issue-or-issue-id)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api label-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/issues/%s/labels" user repo issue-id))))
|
|
||||||
|
|
||||||
(defmethod gh-issues-labels-add-to-issue ((api gh-issues-api) user repo
|
|
||||||
issue-or-issue-id labels)
|
|
||||||
(let ((issue-id (gh-issues--issue-id issue-or-issue-id)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api label-cls)) "PUT"
|
|
||||||
(format "/repos/%s/%s/issues/%s/labels" user repo issue-id)
|
|
||||||
(mapcar #'gh-issues--label-name labels))))
|
|
||||||
|
|
||||||
(defmethod gh-issues-labels-remove-all-from-issue ((api gh-issues-api) user repo
|
|
||||||
issue-or-issue-id )
|
|
||||||
(let ((issue-id (gh-issues--issue-id issue-or-issue-id)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (lambda (x) x) "DELETE"
|
|
||||||
(format "/repos/%s/%s/issues/%s/labels" user repo issue-id))))
|
|
||||||
|
|
||||||
(defmethod gh-issues-labels-in-milestone ((api gh-issues-api) user repo
|
|
||||||
milestone-or-milestone-id)
|
|
||||||
(let ((milestone-id (gh-issues--milestone-id milestone-or-milestone-id)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api label-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/milestones/%s/labels" user repo milestone-id))))
|
|
||||||
|
|
||||||
;;; Comments
|
|
||||||
|
|
||||||
(defmethod gh-issues-comments-list ((api gh-issues-api) user repo issue-id)
|
|
||||||
(gh-comments-list api (format "/repos/%s/%s/issues/%s" user repo issue-id)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-comments-get ((api gh-issues-api) user repo comment-id)
|
|
||||||
(gh-comments-get api (format "/repos/%s/%s/issues" user repo) comment-id))
|
|
||||||
|
|
||||||
(defmethod gh-issues-comments-update ((api gh-issues-api)
|
|
||||||
user repo comment-id comment)
|
|
||||||
(gh-comments-update api (format "/repos/%s/%s/issues" user repo)
|
|
||||||
comment-id (gh-comment-req-to-update comment)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-comments-new ((api gh-issues-api)
|
|
||||||
user repo issue-id comment)
|
|
||||||
(gh-comments-new api (format "/repos/%s/%s/issues/%s" user repo issue-id)
|
|
||||||
(gh-comment-req-to-update comment)))
|
|
||||||
|
|
||||||
(defmethod gh-issues-comments-delete ((api gh-issues-api) user repo comment-id)
|
|
||||||
(gh-comments-delete api (format "/repos/%s/%s/issues" user repo) comment-id))
|
|
||||||
|
|
||||||
;;; helpers
|
|
||||||
|
|
||||||
(defun gh-issues--issue-id (issue-or-issue-id)
|
|
||||||
(if (eieio-object-p issue-or-issue-id)
|
|
||||||
(oref issue-or-issue-id :id)
|
|
||||||
issue-or-issue-id))
|
|
||||||
|
|
||||||
(defun gh-issues--milestone-id (milestone-or-milestone-id)
|
|
||||||
(if (eieio-object-p milestone-or-milestone-id)
|
|
||||||
(oref milestone-or-milestone-id :id)
|
|
||||||
milestone-or-milestone-id))
|
|
||||||
|
|
||||||
(defun gh-issues--label-name (label-or-label-name)
|
|
||||||
(if (eieio-object-p label-or-label-name)
|
|
||||||
(oref label-or-label-name :name)
|
|
||||||
label-or-label-name))
|
|
||||||
|
|
||||||
|
|
||||||
(provide 'gh-issues)
|
|
||||||
;;; gh-issues.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,97 +0,0 @@
|
|||||||
;;; gh-oauth.el --- oauth module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2012 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-oauth-api (gh-api-v3)
|
|
||||||
((auth-cls :allocation :class :initform gh-oauth-authorization))
|
|
||||||
"OAuth API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-oauth-password-authenticator (gh-password-authenticator)
|
|
||||||
((remember :allocation :class :initform nil)))
|
|
||||||
|
|
||||||
(defmethod initialize-instance ((api gh-oauth-api) &rest args)
|
|
||||||
;; force password authentication for this API
|
|
||||||
(let ((gh-api-v3-authenticator 'gh-oauth-password-authenticator))
|
|
||||||
(call-next-method)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-oauth-authorization (gh-ref-object)
|
|
||||||
((scopes :initarg :scopes)
|
|
||||||
(token :initarg :token)
|
|
||||||
(app :initarg :app :initform nil :marshal-type gh-oauth-app)
|
|
||||||
(updated-at :initarg :updated-at)
|
|
||||||
(created-at :initarg :created-at)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-oauth-app (gh-object)
|
|
||||||
((url :initarg :url)
|
|
||||||
(name :initarg :name)))
|
|
||||||
|
|
||||||
(defmethod gh-oauth-auth-list ((api gh-oauth-api))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api auth-cls)) "GET"
|
|
||||||
(format "/authorizations")))
|
|
||||||
|
|
||||||
(defmethod gh-oauth-auth-get ((api gh-oauth-api) id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api auth-cls)) "GET"
|
|
||||||
(format "/authorizations/%s" id)))
|
|
||||||
|
|
||||||
(defmethod gh-oauth-auth-new ((api gh-oauth-api) &optional scopes)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api auth-cls)) "POST"
|
|
||||||
(format "/authorizations") (list (cons 'scopes scopes)
|
|
||||||
(cons 'note (format "gh.el - %s"
|
|
||||||
(system-name))))))
|
|
||||||
|
|
||||||
(defmethod gh-oauth-auth-update ((api gh-oauth-api) id &optional scopes)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api auth-cls)) "PATCH"
|
|
||||||
(format "/authorizations/%s" id) (list (cons 'scopes scopes))))
|
|
||||||
|
|
||||||
(defmethod gh-oauth-auth-delete ((api gh-oauth-api) id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "DELETE" (format "/authorizations/%s" id)))
|
|
||||||
|
|
||||||
(provide 'gh-oauth)
|
|
||||||
;;; gh-oauth.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,113 +0,0 @@
|
|||||||
;;; gh-org.el --- orgs module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2012 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-orgs-api (gh-api-v3)
|
|
||||||
((org-cls :allocation :class :initform gh-orgs-org))
|
|
||||||
"Orgs API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-orgs-org-stub (gh-ref-object)
|
|
||||||
((login :initarg :login)
|
|
||||||
(avatar-url :initarg :avatar-url)
|
|
||||||
(description :initarg :description)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-orgs-plan (gh-object)
|
|
||||||
((name :initarg :name)
|
|
||||||
(space :initarg :space)
|
|
||||||
(private-repos :initarg :private-repos)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-orgs-org (gh-orgs-org-stub)
|
|
||||||
((name :initarg :name)
|
|
||||||
(company :initarg :company)
|
|
||||||
(blog :initarg :blog)
|
|
||||||
(location :initarg :location)
|
|
||||||
(email :initarg :email)
|
|
||||||
(public-repos :initarg :public-repos)
|
|
||||||
(public-gists :initarg :public-gists)
|
|
||||||
(followers :initarg :followers)
|
|
||||||
(following :initarg :following)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(type :initarg :type)
|
|
||||||
(total-private-repos :initarg :total-private-repos)
|
|
||||||
(owned-private-repos :initarg :owned-private-repos)
|
|
||||||
(private-gists :initarg :private-gists)
|
|
||||||
(disk-usage :initarg :disk-usage)
|
|
||||||
(collaborators :initarg :collaborators)
|
|
||||||
(billing-email :initarg :billing-email)
|
|
||||||
(plan :initarg :plan :initform nil :marshal-type gh-orgs-plan))
|
|
||||||
"Class for GitHub organizations")
|
|
||||||
|
|
||||||
(defmethod gh-orgs-org-to-obj ((org gh-orgs-org))
|
|
||||||
`(,@(when (slot-boundp org :billing-email)
|
|
||||||
(list (cons "billing_email" (oref org :billing-email))))
|
|
||||||
,@(when (slot-boundp org :blog)
|
|
||||||
(list (cons "blog" (oref org :blog))))
|
|
||||||
,@(when (slot-boundp org :company)
|
|
||||||
(list (cons "company" (oref org :company))))
|
|
||||||
,@(when (slot-boundp org :email)
|
|
||||||
(list (cons "email" (oref org :email))))
|
|
||||||
,@(when (slot-boundp org :location)
|
|
||||||
(list (cons "location" (oref org :location))))
|
|
||||||
,@(when (slot-boundp org :name)
|
|
||||||
(list (cons "name" (oref org :name))))))
|
|
||||||
|
|
||||||
(defmethod gh-orgs-list ((api gh-orgs-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api org-cls)) "GET"
|
|
||||||
(format "/users/%s/orgs" (or username (gh-api-get-username api)))))
|
|
||||||
|
|
||||||
(defmethod gh-orgs-get ((api gh-orgs-api) org)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api org-cls)) "GET"
|
|
||||||
(format "/orgs/%s" org)))
|
|
||||||
|
|
||||||
(defmethod gh-orgs-update ((api gh-orgs-api) org-obj)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api org-cls)) "PATCH"
|
|
||||||
(format "/orgs/%s" (oref org-obj :login))
|
|
||||||
(apply 'gh-orgs-org-to-obj org-obj nil)))
|
|
||||||
|
|
||||||
(provide 'gh-orgs)
|
|
||||||
;;; gh-org.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,10 +0,0 @@
|
|||||||
(define-package "gh" "20160728.1525" "A GitHub library for Emacs"
|
|
||||||
'((emacs "24.3")
|
|
||||||
(s "1.9.0")
|
|
||||||
(dash "2.9.0")
|
|
||||||
(pcache "0.4.1")
|
|
||||||
(logito "0.1")
|
|
||||||
(marshal "0.6.3")))
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
@ -1,103 +0,0 @@
|
|||||||
;;; gh-profile.el --- profile support for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2013 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
(require 'rx)
|
|
||||||
(require 'url-parse)
|
|
||||||
|
|
||||||
(defgroup gh-profile nil
|
|
||||||
"Github profile."
|
|
||||||
:group 'gh)
|
|
||||||
|
|
||||||
(defun gh-profile-remote-regexp (domain)
|
|
||||||
(eval
|
|
||||||
`(rx bol (or ,(concat "git@" domain ":")
|
|
||||||
(and (or "git" "ssh" "http" "https") "://"
|
|
||||||
(* nonl) (? "@") ,domain "/"))
|
|
||||||
(and (group (* nonl)) "/" (group (* nonl))) (? ".git"))))
|
|
||||||
|
|
||||||
(defcustom gh-profile-alist `(("github"
|
|
||||||
:url "https://api.github.com"
|
|
||||||
:remote-regexp
|
|
||||||
,(gh-profile-remote-regexp "github.com")))
|
|
||||||
"List of profiles for Github access. List every Github
|
|
||||||
Enterprise server and/or Github accounts you have access
|
|
||||||
to here."
|
|
||||||
:type '(alist :key-type string
|
|
||||||
:value-type (plist :key-type (choice (const :url)
|
|
||||||
(const :username)
|
|
||||||
(const :password)
|
|
||||||
(const :token)
|
|
||||||
(const :remote-regexp))
|
|
||||||
:value-type string))
|
|
||||||
:group 'gh-profile)
|
|
||||||
|
|
||||||
(defun gh-profile-get-remote-regexp (profile)
|
|
||||||
(let* ((profile-plist (cdr (assoc profile gh-profile-alist)))
|
|
||||||
(regexp (plist-get profile-plist :remote-regexp)))
|
|
||||||
(if regexp
|
|
||||||
regexp
|
|
||||||
;; try to guess remote format (just use the hostname)
|
|
||||||
(let* ((url (url-generic-parse-url (plist-get profile-plist :url)))
|
|
||||||
(host (url-host url)))
|
|
||||||
(gh-profile-remote-regexp host)))))
|
|
||||||
|
|
||||||
(defcustom gh-profile-default-profile "github"
|
|
||||||
"Default profile. This needs to be a key present in
|
|
||||||
`gh-profile-alist'"
|
|
||||||
:type 'string
|
|
||||||
:group 'gh-profile)
|
|
||||||
|
|
||||||
(defvar gh-profile-current-profile nil)
|
|
||||||
(make-variable-buffer-local 'gh-profile-current-profile)
|
|
||||||
|
|
||||||
(defun gh-profile-current-profile ()
|
|
||||||
(or gh-profile-current-profile
|
|
||||||
gh-profile-default-profile))
|
|
||||||
|
|
||||||
(defun gh-profile-url ()
|
|
||||||
(plist-get (cdr (assoc (or gh-profile-current-profile
|
|
||||||
gh-profile-default-profile)
|
|
||||||
gh-profile-alist)) :url))
|
|
||||||
|
|
||||||
(defun gh-profile-completing-read ()
|
|
||||||
(let ((profiles (mapcar #'car gh-profile-alist)))
|
|
||||||
(if (> (length profiles) 1)
|
|
||||||
(completing-read "Github profile: " profiles nil t nil nil (first profiles))
|
|
||||||
(car profiles))))
|
|
||||||
|
|
||||||
(defun gh-profile-get-remote-profile (remote-url)
|
|
||||||
(loop for (id . props) in gh-profile-alist
|
|
||||||
if (string-match (gh-profile-get-remote-regexp id)
|
|
||||||
remote-url)
|
|
||||||
return id))
|
|
||||||
|
|
||||||
(provide 'gh-profile)
|
|
||||||
;;; gh-profile.el ends here
|
|
||||||
@ -1,78 +0,0 @@
|
|||||||
;;; gh-pull-comments.el --- pull request comments api for github
|
|
||||||
|
|
||||||
;; Copyright (C) 2014 Toni Reina
|
|
||||||
|
|
||||||
;; Author: Toni Reina <areina0@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; 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:
|
|
||||||
|
|
||||||
;; TODOS:
|
|
||||||
;; * Support listing all comments in a repository
|
|
||||||
|
|
||||||
;; Basic usage:
|
|
||||||
|
|
||||||
;; (setf api (gh-pull-comments-api "api" :sync nil :cache nil :num-retries 1))
|
|
||||||
;; (setf comments (gh-pull-comments-list api "user" "repo" "pull request id"))
|
|
||||||
;; (setq my-comment (make-instance 'gh-pull-comments-comment
|
|
||||||
;; :body "This is great!"
|
|
||||||
;; :path "README.md"
|
|
||||||
;; :position 2
|
|
||||||
;; :commit-id "commit sha"))
|
|
||||||
;; (gh-pull-comments-new api "user" "repo" "pull request id" my-comment)
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
(require 'gh-pulls)
|
|
||||||
|
|
||||||
(let ((ver "1.0.0"))
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-api 'gh-pulls-api ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-comment 'gh-pulls-comment ver)
|
|
||||||
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-req-to-update 'gh-comment-req-to-update ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-req-to-create 'gh-pulls-comment-req-to-create)
|
|
||||||
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-list 'gh-pulls-comments-list ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-get 'gh-pulls-comments-get ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-update 'gh-pulls-comments-update ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-new 'gh-pulls-comments-new ver)
|
|
||||||
(define-obsolete-function-alias
|
|
||||||
'gh-pull-comments-delete 'gh-pulls-comments-delete ver))
|
|
||||||
|
|
||||||
(provide 'gh-pull-comments)
|
|
||||||
;;; gh-pull-comments.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,166 +0,0 @@
|
|||||||
;;; gh-pulls.el --- pull requests module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-comments)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
(require 'gh-repos)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-pulls-cache (gh-cache)
|
|
||||||
((invalidation-chain :allocation :class
|
|
||||||
:initform '(("^/repos/.*/.*/pulls$" . "\0")
|
|
||||||
("^/repos/.*/.*/pulls/.*$" . "\0")))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-pulls-api (gh-api-v3 gh-comments-api-mixin)
|
|
||||||
((cache-cls :allocation :class :initform gh-pulls-cache)
|
|
||||||
|
|
||||||
(req-cls :allocation :class :initform gh-pulls-request)
|
|
||||||
(comment-cls :allocation :class :initform gh-pulls-comment))
|
|
||||||
"Git pull requests API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-pulls-comment (gh-comment)
|
|
||||||
((path :initarg :path)
|
|
||||||
(diff-hunk :initarg :diff-hunk)
|
|
||||||
(position :initarg :position)
|
|
||||||
(original-position :initarg :original-position)
|
|
||||||
(commit-id :initarg :commit-id)
|
|
||||||
(original-commit-id :initarg :original-commit-id)
|
|
||||||
(in-reply-to :initarg :in-reply-to :initform nil)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comment-req-to-create ((req gh-pulls-comment))
|
|
||||||
(let ((in-reply-to (oref req in-reply-to))
|
|
||||||
(to-update `(("body" . ,(oref req body)))))
|
|
||||||
(if in-reply-to
|
|
||||||
(nconc to-update `(("in_reply_to" . ,in-reply-to)))
|
|
||||||
(nconc to-update `(("commit_id" . ,(oref req commit-id))
|
|
||||||
("path" . ,(oref req path))
|
|
||||||
("position" . ,(oref req position)))))
|
|
||||||
to-update))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-pulls-request-stub (gh-ref-object)
|
|
||||||
((diff-url :initarg :diff-url)
|
|
||||||
(patch-url :initarg :patch-url)
|
|
||||||
(issue-url :initarg :issue-url)
|
|
||||||
(number :initarg :number)
|
|
||||||
(state :initarg :state)
|
|
||||||
(title :initarg :title)
|
|
||||||
(body :initarg :body)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(updated-at :initarg :updated-at)
|
|
||||||
(closed-at :initarg :closed-at)
|
|
||||||
(merged-at :initarg :merged-at)
|
|
||||||
(head :initarg :head :initform nil :marshal-type gh-repos-ref)
|
|
||||||
(base :initarg :base :initform nil :marshal-type gh-repos-ref)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-pulls-request (gh-pulls-request-stub)
|
|
||||||
((merged :initarg :merged)
|
|
||||||
(mergeable :initarg :mergeable)
|
|
||||||
(merged-by :initarg :merged-by)
|
|
||||||
(comments :initarg :comments)
|
|
||||||
(user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(commits :initarg :commits)
|
|
||||||
(additions :initarg :additions)
|
|
||||||
(deletions :initarg :deletions)
|
|
||||||
(changed-files :initarg :changed-files))
|
|
||||||
"Git pull requests API")
|
|
||||||
|
|
||||||
(defmethod gh-pulls-req-to-new ((req gh-pulls-request))
|
|
||||||
(let ((head (oref req :head))
|
|
||||||
(base (oref req :base)))
|
|
||||||
`(("title" . ,(oref req :title))
|
|
||||||
("body" . ,(oref req :body))
|
|
||||||
("head" . ,(or (oref head :ref) (oref head :sha)))
|
|
||||||
("base" . ,(or (oref base :ref) (oref base :sha))))))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-req-to-update ((req gh-pulls-request-stub))
|
|
||||||
`(("title" . ,(oref req :title))
|
|
||||||
("body" . ,(oref req :body))
|
|
||||||
("state" . ,(oref req :state))))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-list ((api gh-pulls-api) user repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api req-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/pulls" user repo)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-get ((api gh-pulls-api) user repo id)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api req-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/pulls/%s" user repo id)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-new ((api gh-pulls-api) user repo req)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api req-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/pulls" user repo)
|
|
||||||
(gh-pulls-req-to-new req)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-update ((api gh-pulls-api) user repo id req)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api req-cls)) "PATCH"
|
|
||||||
(format "/repos/%s/%s/pulls/%s" user repo id)
|
|
||||||
(gh-pulls-req-to-update req)))
|
|
||||||
|
|
||||||
;;; Comments
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comments-list ((api gh-pulls-api) user repo pull-id)
|
|
||||||
(gh-comments-list api (format "/repos/%s/%s/pulls/%s" user repo pull-id)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comments-get ((api gh-pulls-api) user repo comment-id)
|
|
||||||
(gh-comments-get api (format "/repos/%s/%s/pulls" user repo) comment-id))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comments-update ((api gh-pulls-api)
|
|
||||||
user repo comment-id comment)
|
|
||||||
(gh-comments-update api (format "/repos/%s/%s/pulls" user repo)
|
|
||||||
comment-id (gh-comment-req-to-update comment)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comments-new ((api gh-pulls-api)
|
|
||||||
user repo pull-id comment)
|
|
||||||
(gh-comments-new api (format "/repos/%s/%s/pulls/%s" user repo pull-id)
|
|
||||||
(gh-pulls-comment-req-to-create comment)))
|
|
||||||
|
|
||||||
(defmethod gh-pulls-comments-delete ((api gh-pulls-api) user repo comment-id)
|
|
||||||
(gh-comments-delete api (format "/repos/%s/%s/pulls" user repo) comment-id))
|
|
||||||
|
|
||||||
(provide 'gh-pulls)
|
|
||||||
;;; gh-pulls.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,350 +0,0 @@
|
|||||||
;;; gh-repos.el --- repos module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-repos-api (gh-api-v3)
|
|
||||||
((repo-cls :allocation :class :initform gh-repos-repo)
|
|
||||||
(user-cls :allocation :class :initform gh-user))
|
|
||||||
"Repos API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-repos-repo-stub (gh-object)
|
|
||||||
((name :initarg :name)
|
|
||||||
(description :initarg :description)
|
|
||||||
(homepage :initarg :homepage)
|
|
||||||
(private :initarg :private))
|
|
||||||
"Class for user-created repository objects")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-repos-repo (gh-ref-object gh-repos-repo-stub)
|
|
||||||
((clone-url :initarg :clone-url)
|
|
||||||
(git-url :initarg :git-url)
|
|
||||||
(ssh-url :initarg :ssh-url)
|
|
||||||
(svn-url :initarg :svn-url)
|
|
||||||
(mirror-url :initarg :mirror-url)
|
|
||||||
(owner :initarg :owner :initform nil :marshal-type gh-user)
|
|
||||||
(full-name :initarg :full-name)
|
|
||||||
(language :initarg :language)
|
|
||||||
(fork :initarg :fork)
|
|
||||||
(forks :initarg :forks)
|
|
||||||
(forks-count :initarg :forks-count)
|
|
||||||
(watchers :initarg :watchers)
|
|
||||||
(watchers-count :initarg :watchers-count)
|
|
||||||
(stargazers-count :initarg :stargazers-count)
|
|
||||||
(size :initarg :size)
|
|
||||||
(master-branch :initarg :master-branch)
|
|
||||||
(open-issues :initarg :open-issues)
|
|
||||||
(pushed-at :initarg :pushed-at)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(updated-at :initarg :updated-at)
|
|
||||||
(organisation :initarg :organisation :initform nil :marshal-type gh-user)
|
|
||||||
(parent :initarg :parent :marshal-type gh-repos-repo)
|
|
||||||
(source :initarg :source :marshal-type gh-repos-repo)
|
|
||||||
(has-issues :initarg :has-issues)
|
|
||||||
(has-wiki :initarg :has-wiki)
|
|
||||||
(has-downloads :initarg :has-downloads))
|
|
||||||
"Class for GitHub repositories")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-repos-ref (gh-object)
|
|
||||||
((label :initarg :label)
|
|
||||||
(ref :initarg :ref :initform nil)
|
|
||||||
(sha :initarg :sha :initform nil)
|
|
||||||
(user :initarg :user :initform nil :marshal-type gh-user)
|
|
||||||
(repo :initarg :repo :initform nil :marshal-type gh-repos-repo)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-user-list ((api gh-repos-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/users/%s/repos" (or username (gh-api-get-username api)))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-org-list ((api gh-repos-api) org)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/orgs/%s/repos" org)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-to-obj ((repo gh-repos-repo-stub)
|
|
||||||
&rest caps)
|
|
||||||
(let ((has_issues (plist-member caps :issues))
|
|
||||||
(has_wiki (plist-member caps :wiki))
|
|
||||||
(has_downloads (plist-member caps :downloads)))
|
|
||||||
`(("name" . ,(oref repo :name))
|
|
||||||
,@(when (slot-boundp repo :homepage)
|
|
||||||
(list (cons "homepage" (oref repo :homepage))))
|
|
||||||
,@(when (slot-boundp repo :description)
|
|
||||||
(list (cons "description" (oref repo :description))))
|
|
||||||
,@(when (slot-boundp repo :private)
|
|
||||||
(list (cons "public" (not (oref repo :private)))))
|
|
||||||
,@(when has_issues
|
|
||||||
(list (cons "has_issues" (plist-get caps :issues))))
|
|
||||||
,@(when has_wiki
|
|
||||||
(list (cons "has_wiki" (plist-get caps :wiki))))
|
|
||||||
,@(when has_downloads
|
|
||||||
(list (cons "has_downloads" (plist-get caps :downloads)))))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-new ((api gh-repos-api) repo-stub
|
|
||||||
&optional org &rest caps)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "POST"
|
|
||||||
(if org (format "/orgs/%s/repos" org)
|
|
||||||
"/user/repos")
|
|
||||||
(apply 'gh-repos-repo-to-obj repo-stub caps)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-get ((api gh-repos-api) repo-id &optional user)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s"
|
|
||||||
(or user (gh-api-get-username api))
|
|
||||||
repo-id)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-update ((api gh-repos-api) repo-stub
|
|
||||||
&optional user &rest caps)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "PATCH"
|
|
||||||
(format "/repos/%s/%s"
|
|
||||||
(or user (gh-api-get-username api))
|
|
||||||
(oref repo-stub :name))
|
|
||||||
(apply 'gh-repos-repo-to-obj repo-stub caps)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-rename ((api gh-repos-api) repo-stub new-name
|
|
||||||
&optional user)
|
|
||||||
(let ((new-stub (make-instance 'gh-repos-repo-stub :name new-name)))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "PATCH"
|
|
||||||
(format "/repos/%s/%s"
|
|
||||||
(or user (gh-api-get-username api))
|
|
||||||
(oref repo-stub :name))
|
|
||||||
(gh-repos-repo-to-obj new-stub))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-delete ((api gh-repos-api) repo-id
|
|
||||||
&optional user)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "DELETE"
|
|
||||||
(format "/repos/%s/%s"
|
|
||||||
(or user (gh-api-get-username api))
|
|
||||||
repo-id)))
|
|
||||||
|
|
||||||
;; TODO gh-repos-repo-move
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-contributors ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/contributors"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
;;; TODO: generate some useful objects with the return values
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-languages ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "GET" (format "/repos/%s/%s/languages"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-teams ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "GET" (format "/repos/%s/%s/teams"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-tags ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "GET" (format "/repos/%s/%s/tags"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-repo-branches ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "GET" (format "/repos/%s/%s/branches"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
;;; TODO gh-repos-repo-branch-commits
|
|
||||||
|
|
||||||
;;; Collaborators sub-API
|
|
||||||
|
|
||||||
(defmethod gh-repos-collaborators-list ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api user-cls)) "GET" (format "/repos/%s/%s/collaborators"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-collaborators-p ((api gh-repos-api) repo user)
|
|
||||||
(eq (oref (gh-api-authenticated-request
|
|
||||||
api nil "GET"
|
|
||||||
(format "/repos/%s/%s/collaborators/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)
|
|
||||||
user))
|
|
||||||
:http-status)
|
|
||||||
204))
|
|
||||||
|
|
||||||
(defmethod gh-repos-collaborators-add ((api gh-repos-api) repo user)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "PUT"
|
|
||||||
(format "/repos/%s/%s/collaborators/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)
|
|
||||||
user)))
|
|
||||||
|
|
||||||
(defmethod gh-repos-collaborators-delete ((api gh-repos-api) repo user)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "DELETE"
|
|
||||||
(format "/repos/%s/%s/collaborators/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)
|
|
||||||
user)))
|
|
||||||
|
|
||||||
;;; TODO Comments sub-API
|
|
||||||
;;; TODO Commits sub-API
|
|
||||||
;;; TODO Contents sub-API
|
|
||||||
;;; TODO Downloads sub-API
|
|
||||||
|
|
||||||
;;; Forks sub-API
|
|
||||||
|
|
||||||
(defmethod gh-repos-forks-list ((api gh-repos-api) repo &optional recursive)
|
|
||||||
(let ((resp (gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/forks"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)))))
|
|
||||||
(when recursive
|
|
||||||
(let ((forks (oref resp :data)))
|
|
||||||
(oset resp :data
|
|
||||||
(apply 'nconc forks
|
|
||||||
(mapcar
|
|
||||||
(lambda (f)
|
|
||||||
(oref (gh-repos-forks-list api f t) data))
|
|
||||||
forks)))))
|
|
||||||
resp))
|
|
||||||
|
|
||||||
(defmethod gh-repos-fork ((api gh-repos-api) repo &optional org)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api repo-cls)) "POST"
|
|
||||||
(format "/repos/%s/%s/forks"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))
|
|
||||||
nil (when org `(("org" . ,org)))))
|
|
||||||
|
|
||||||
;;; TODO Keys sub-API
|
|
||||||
;;; TODO Hooks sub-API
|
|
||||||
;;; TODO Merging sub-API
|
|
||||||
|
|
||||||
;;; Starring sub-API
|
|
||||||
|
|
||||||
(defmethod gh-repos-stargazers ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api user-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/stargazers"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-starred-list ((api gh-repos-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/users/%s/starred" (or username (gh-api-get-username api)))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-starred-p ((api gh-repos-api) repo)
|
|
||||||
(eq (oref (gh-api-authenticated-request
|
|
||||||
api nil "GET"
|
|
||||||
(format "/user/starred/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)))
|
|
||||||
:http-status)
|
|
||||||
204))
|
|
||||||
|
|
||||||
(defmethod gh-repos-star ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "PUT"
|
|
||||||
(format "/user/starred/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-unstar ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "DELETE"
|
|
||||||
(format "/user/starred/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
;;; TODO Statuses sub-API
|
|
||||||
|
|
||||||
;;; Watching sub-API
|
|
||||||
|
|
||||||
(defmethod gh-repos-watchers ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api user-cls)) "GET"
|
|
||||||
(format "/repos/%s/%s/subscribers"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-watched-list ((api gh-repos-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api repo-cls)) "GET"
|
|
||||||
(format "/users/%s/subscriptions"
|
|
||||||
(or username (gh-api-get-username api)))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-watched-p ((api gh-repos-api) repo)
|
|
||||||
(eq (oref (gh-api-authenticated-request
|
|
||||||
api nil "GET"
|
|
||||||
(format "/user/subscriptions/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name)))
|
|
||||||
:http-status)
|
|
||||||
204))
|
|
||||||
|
|
||||||
(defmethod gh-repos-watch ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "PUT"
|
|
||||||
(format "/user/subscriptions/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(defmethod gh-repos-unwatch ((api gh-repos-api) repo)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api nil "DELETE"
|
|
||||||
(format "/user/subscriptions/%s/%s"
|
|
||||||
(oref (oref repo :owner) :login)
|
|
||||||
(oref repo :name))))
|
|
||||||
|
|
||||||
(provide 'gh-repos)
|
|
||||||
;;; gh-repos.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,62 +0,0 @@
|
|||||||
;;; gh-search.el --- repository search for gh.el
|
|
||||||
;; Copyright (C) 2016 Ivan Malison
|
|
||||||
|
|
||||||
;; Author: Ivan Malison <IvanMalison@gmail.com>
|
|
||||||
|
|
||||||
;; 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:
|
|
||||||
|
|
||||||
(require 'gh-users)
|
|
||||||
(require 'gh-repos)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-search-api (gh-api-v3)
|
|
||||||
((repo-cls :allocation :class :initform gh-repos-repo)
|
|
||||||
(user-cls :allocation :class :initform gh-users-user)))
|
|
||||||
|
|
||||||
(defmacro gh-search-method-builder (method-name uri process-result-function)
|
|
||||||
`(defmethod ,method-name ((search-api gh-search-api)
|
|
||||||
query-string &optional page-limit
|
|
||||||
&rest additional-arguments)
|
|
||||||
(unless (and (stringp query-string) (> (length query-string) 1))
|
|
||||||
(error "a non-empty query string must be provided to github search"))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
search-api
|
|
||||||
(apply-partially (quote ,process-result-function) search-api)
|
|
||||||
"GET" ,uri nil
|
|
||||||
`((q . ,query-string) ,@additional-arguments) page-limit)))
|
|
||||||
|
|
||||||
(defmacro gh-search-process-method-builder (method-name class-symbol)
|
|
||||||
`(defmethod ,method-name ((search-api gh-search-api) data)
|
|
||||||
(unless (listp data)
|
|
||||||
(error "Did not recieve a list from the search query"))
|
|
||||||
(let ((items (assoc 'items data)))
|
|
||||||
(unless items
|
|
||||||
(error "Search query did not return items"))
|
|
||||||
(gh-object-list-read (oref search-api ,class-symbol) (cdr items)))))
|
|
||||||
|
|
||||||
(gh-search-process-method-builder gh-process-repo-search-result repo-cls)
|
|
||||||
(gh-search-process-method-builder gh-process-user-search-result user-cls)
|
|
||||||
(gh-search-method-builder gh-search-repos "/search/repositories"
|
|
||||||
gh-process-repo-search-result)
|
|
||||||
(gh-search-method-builder gh-search-users "/search/users"
|
|
||||||
gh-process-user-search-result)
|
|
||||||
|
|
||||||
(provide 'gh-search)
|
|
||||||
;;; gh-search.el ends here
|
|
||||||
@ -1,193 +0,0 @@
|
|||||||
;;; gh-url.el --- url wrapper for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2012 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'url-http)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-url-request ()
|
|
||||||
((method :initarg :method :type string)
|
|
||||||
(url :initarg :url :type string)
|
|
||||||
(query :initarg :query :initform nil)
|
|
||||||
(headers :initarg :headers :initform nil)
|
|
||||||
(data :initarg :data :initform "" :type string)
|
|
||||||
(async :initarg :async :initform nil)
|
|
||||||
(num-retries :initarg :num-retries :initform 0)
|
|
||||||
(install-callbacks :initarg :install-callbacks :initform nil)
|
|
||||||
|
|
||||||
(default-response-cls :allocation :class :initform gh-url-response)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-url-response ()
|
|
||||||
((data-received :initarg :data-received :initform nil)
|
|
||||||
(data :initarg :data :initform nil)
|
|
||||||
(headers :initarg :headers :initform nil)
|
|
||||||
(http-status :initarg :http-status :initform nil)
|
|
||||||
(callbacks :initarg :callbacks :initform nil)
|
|
||||||
(transform :initarg :transform :initform nil)
|
|
||||||
(-req :initarg :-req :initform nil)))
|
|
||||||
|
|
||||||
(defmethod gh-url-response-set-data ((resp gh-url-response) data)
|
|
||||||
(let ((transform (oref resp :transform)))
|
|
||||||
(oset resp :data
|
|
||||||
(if transform
|
|
||||||
(funcall transform data)
|
|
||||||
data))
|
|
||||||
(oset resp :data-received t)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-url-callback ()
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod gh-url-callback-run ((cb gh-url-callback) resp)
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod gh-url-response-run-callbacks ((resp gh-url-response))
|
|
||||||
(let ((copy-list (lambda (list)
|
|
||||||
(if (consp list)
|
|
||||||
(let ((res nil))
|
|
||||||
(while (consp list) (push (pop list) res))
|
|
||||||
(prog1 (nreverse res) (setcdr res list)))
|
|
||||||
(car list)))))
|
|
||||||
(let ((data (oref resp :data)))
|
|
||||||
(dolist (cb (funcall copy-list (oref resp :callbacks)))
|
|
||||||
(cond ((and (object-p cb)
|
|
||||||
(object-of-class-p cb 'gh-url-callback))
|
|
||||||
(gh-url-callback-run cb resp))
|
|
||||||
((or (functionp cb) (symbolp cb))
|
|
||||||
(funcall cb data))
|
|
||||||
(t (apply (car cb) data (cdr cb))))
|
|
||||||
(object-remove-from-list resp :callbacks cb))))
|
|
||||||
resp)
|
|
||||||
|
|
||||||
(defmethod gh-url-add-response-callback ((resp gh-url-response) callback)
|
|
||||||
(object-add-to-list resp :callbacks callback t)
|
|
||||||
(if (oref resp :data-received)
|
|
||||||
(gh-url-response-run-callbacks resp)
|
|
||||||
resp))
|
|
||||||
|
|
||||||
;;; code borrowed from nicferrier's web.el
|
|
||||||
(defun gh-url-parse-headers (data)
|
|
||||||
(let* ((headers nil)
|
|
||||||
(header-lines (split-string data "\n"))
|
|
||||||
(status-line (car header-lines)))
|
|
||||||
(when (string-match
|
|
||||||
"HTTP/\\([0-9.]+\\) \\([0-9]\\{3\\}\\)\\( \\(.*\\)\\)*"
|
|
||||||
status-line)
|
|
||||||
(push (cons 'status-version (match-string 1 status-line)) headers)
|
|
||||||
(push (cons 'status-code (match-string 2 status-line)) headers)
|
|
||||||
(push (cons 'status-string
|
|
||||||
(or (match-string 4 status-line) ""))
|
|
||||||
headers))
|
|
||||||
(loop for line in (cdr header-lines)
|
|
||||||
if (string-match
|
|
||||||
"^\\([A-Za-z0-9.-]+\\):[ ]*\\(.*\\)"
|
|
||||||
line)
|
|
||||||
do
|
|
||||||
(let ((name (match-string 1 line))
|
|
||||||
(value (match-string 2 line)))
|
|
||||||
(push (cons name value) headers)))
|
|
||||||
headers))
|
|
||||||
|
|
||||||
(defmethod gh-url-response-finalize ((resp gh-url-response))
|
|
||||||
(when (oref resp :data-received)
|
|
||||||
(gh-url-response-run-callbacks resp)))
|
|
||||||
|
|
||||||
(defmethod gh-url-response-init ((resp gh-url-response)
|
|
||||||
buffer)
|
|
||||||
(declare (special url-http-end-of-headers))
|
|
||||||
(unwind-protect
|
|
||||||
(with-current-buffer buffer
|
|
||||||
(let ((headers (gh-url-parse-headers
|
|
||||||
(buffer-substring
|
|
||||||
(point-min) (1+ url-http-end-of-headers)))))
|
|
||||||
(oset resp :headers headers)
|
|
||||||
(oset resp :http-status (read (cdr (assoc 'status-code headers)))))
|
|
||||||
(goto-char (1+ url-http-end-of-headers))
|
|
||||||
(let ((raw (buffer-substring (point) (point-max))))
|
|
||||||
(gh-url-response-set-data resp raw)))
|
|
||||||
(kill-buffer buffer))
|
|
||||||
(gh-url-response-finalize resp)
|
|
||||||
resp)
|
|
||||||
|
|
||||||
(defun gh-url-set-response (status req-resp)
|
|
||||||
(set-buffer-multibyte t)
|
|
||||||
(destructuring-bind (req resp) req-resp
|
|
||||||
(let ((responses-req (clone req))
|
|
||||||
(num (oref req :num-retries)))
|
|
||||||
(oset resp :-req responses-req)
|
|
||||||
(if (or (null num) (zerop num))
|
|
||||||
(gh-url-response-init resp (current-buffer))
|
|
||||||
(condition-case err
|
|
||||||
(gh-url-response-init resp (current-buffer))
|
|
||||||
(error
|
|
||||||
(oset req :num-retries (1- num))
|
|
||||||
(gh-url-run-request req resp)))))))
|
|
||||||
|
|
||||||
(defun gh-url-form-encode (form)
|
|
||||||
(mapconcat (lambda (x) (format "%s=%s" (car x) (cdr x)))
|
|
||||||
form "&"))
|
|
||||||
|
|
||||||
(defun gh-url-params-encode (form)
|
|
||||||
(concat "?" (gh-url-form-encode form)))
|
|
||||||
|
|
||||||
(defmethod gh-url-run-request ((req gh-url-request) &optional resp)
|
|
||||||
(let ((url-registered-auth-schemes
|
|
||||||
'(("basic" ignore . 4))) ;; don't let default handlers kick in
|
|
||||||
(url-privacy-level 'high)
|
|
||||||
(url-request-method (oref req :method))
|
|
||||||
(url-request-data (oref req :data))
|
|
||||||
(url-request-extra-headers (oref req :headers))
|
|
||||||
(url (concat (oref req :url)
|
|
||||||
(let ((params (oref req :query)))
|
|
||||||
(if params
|
|
||||||
(gh-url-params-encode params)
|
|
||||||
"")))))
|
|
||||||
(if (oref req :async)
|
|
||||||
(let* ((resp (or resp (make-instance (oref req default-response-cls))))
|
|
||||||
(req-resp (list req resp)))
|
|
||||||
(with-current-buffer
|
|
||||||
(url-retrieve url 'gh-url-set-response (list req-resp))
|
|
||||||
(set (make-local-variable 'url-registered-auth-schemes)
|
|
||||||
url-registered-auth-schemes)))
|
|
||||||
(let* ((resp (or resp (make-instance (oref req default-response-cls))))
|
|
||||||
(req-resp (list req resp)))
|
|
||||||
(with-current-buffer (url-retrieve-synchronously url)
|
|
||||||
(gh-url-set-response nil req-resp)))))
|
|
||||||
(mapc (lambda (cb)
|
|
||||||
(gh-url-add-response-callback resp cb))
|
|
||||||
(oref req :install-callbacks))
|
|
||||||
resp)
|
|
||||||
|
|
||||||
(provide 'gh-url)
|
|
||||||
;;; gh-url.el ends here
|
|
||||||
@ -1,86 +0,0 @@
|
|||||||
;;; gh-users.el --- users module for gh.el
|
|
||||||
|
|
||||||
;; Copyright (C) 2013 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(require 'gh-api)
|
|
||||||
(require 'gh-auth)
|
|
||||||
(require 'gh-common)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defclass gh-users-api (gh-api-v3)
|
|
||||||
((users-cls :allocation :class :initform gh-users-user))
|
|
||||||
"Users API")
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(gh-defclass gh-users-user (gh-user)
|
|
||||||
((gravatar-id :initarg :gravatar-id)
|
|
||||||
(html-url :initarg :html-url)
|
|
||||||
(followers-url :initarg :followers-url)
|
|
||||||
(following-url :initarg :following-url)
|
|
||||||
(gists-url :initarg :gists-url)
|
|
||||||
(starred-url :initarg :starred-url)
|
|
||||||
(subscriptions-url :initarg :subscriptions-url)
|
|
||||||
(organizations-url :initarg :organizations-url)
|
|
||||||
(repos-url :initarg :repos-url)
|
|
||||||
(events-url :initarg :events-url)
|
|
||||||
(received-events-url :initarg :received-events-url)
|
|
||||||
(type :initarg :type)
|
|
||||||
(site-admin :initarg :site-admin)
|
|
||||||
(name :initarg :name)
|
|
||||||
(company :initarg :company)
|
|
||||||
(blog :initarg :blog)
|
|
||||||
(location :initarg :location)
|
|
||||||
(email :initarg :email)
|
|
||||||
(hireable :initarg :hireable)
|
|
||||||
(bio :initarg :bio)
|
|
||||||
(public-repos :initarg :public-repos)
|
|
||||||
(public-gists :initarg :public-gists)
|
|
||||||
(followers :initarg :followers)
|
|
||||||
(following :initarg :following)
|
|
||||||
(created-at :initarg :created-at)
|
|
||||||
(update-at :initarg :update-at)))
|
|
||||||
|
|
||||||
(defmethod gh-users-get ((api gh-users-api) &optional username)
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-reader (oref api users-cls)) "GET"
|
|
||||||
(if username
|
|
||||||
(format "/users/%s" username)
|
|
||||||
"/user")))
|
|
||||||
|
|
||||||
(defmethod gh-users-list ((api gh-users-api))
|
|
||||||
(gh-api-authenticated-request
|
|
||||||
api (gh-object-list-reader (oref api users-cls)) "GET"
|
|
||||||
"/users"))
|
|
||||||
|
|
||||||
(provide 'gh-users)
|
|
||||||
;;; gh-users.el ends here
|
|
||||||
@ -1,39 +0,0 @@
|
|||||||
;;; gh.el --- Github API client libraries
|
|
||||||
|
|
||||||
;; Copyright (C) 2011 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yhodique@gmail.com>
|
|
||||||
;; Keywords:
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'gh-gist)
|
|
||||||
(require 'gh-pulls)
|
|
||||||
(require 'gh-issues)
|
|
||||||
(require 'gh-users)
|
|
||||||
|
|
||||||
(provide 'gh)
|
|
||||||
;;; gh.el ends here
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; indent-tabs-mode: nil
|
|
||||||
;; End:
|
|
||||||
@ -1,36 +0,0 @@
|
|||||||
;;; github-notifier-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "github-notifier" "github-notifier.el" (22500
|
|
||||||
;;;;;; 1786 648025 550000))
|
|
||||||
;;; Generated autoloads from github-notifier.el
|
|
||||||
|
|
||||||
(defalias 'github-notifier 'github-notifier-mode)
|
|
||||||
|
|
||||||
(defvar github-notifier-mode nil "\
|
|
||||||
Non-nil if Github-Notifier mode is enabled.
|
|
||||||
See the command `github-notifier-mode' for a description of this minor mode.
|
|
||||||
Setting this variable directly does not take effect;
|
|
||||||
either customize it (see the info node `Easy Customization')
|
|
||||||
or call the function `github-notifier-mode'.")
|
|
||||||
|
|
||||||
(custom-autoload 'github-notifier-mode "github-notifier" nil)
|
|
||||||
|
|
||||||
(autoload 'github-notifier-mode "github-notifier" "\
|
|
||||||
Toggle github notifications count display in mode line (Github Notifier mode).
|
|
||||||
With a prefix argument ARG, enable Github Notifier mode if ARG is
|
|
||||||
positive, and disable it otherwise. If called from Lisp, enable
|
|
||||||
the mode if ARG is omitted or nil.
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; github-notifier-autoloads.el ends here
|
|
||||||
@ -1 +0,0 @@
|
|||||||
(define-package "github-notifier" "20160702.2112" "Displays your GitHub notifications unread count in mode-line" '((emacs "24")) :url "https://github.com/xuchunyang/github-notifier.el" :keywords '("github" "mode-line"))
|
|
||||||
@ -1,243 +0,0 @@
|
|||||||
;;; github-notifier.el --- Displays your GitHub notifications unread count in mode-line -*- lexical-binding: t; -*-
|
|
||||||
|
|
||||||
;; Copyright (C) 2015, 2016 Chunyang Xu
|
|
||||||
|
|
||||||
;; Author: Chunyang Xu <xuchunyang56@gmail.com>
|
|
||||||
;; URL: https://github.com/xuchunyang/github-notifier.el
|
|
||||||
;; Package-Version: 20160702.2112
|
|
||||||
;; Package-Requires: ((emacs "24"))
|
|
||||||
;; Keywords: github, mode-line
|
|
||||||
;; Version: 0.1
|
|
||||||
|
|
||||||
;; 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 is a global minor-mode. Turn it on everywhere with:
|
|
||||||
;;
|
|
||||||
;; M-x github-notifier-mode
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'url)
|
|
||||||
(require 'json)
|
|
||||||
|
|
||||||
(defgroup github-notifier nil
|
|
||||||
"Github Notifier"
|
|
||||||
:group 'emacs)
|
|
||||||
|
|
||||||
;;; Custom
|
|
||||||
(defcustom github-notifier-token nil
|
|
||||||
"Access token to get Github Notifications.
|
|
||||||
|
|
||||||
To generate an access token, visit
|
|
||||||
URL `https://github.com/settings/tokens/new?scopes=notifications&description=github-notifier.el'
|
|
||||||
|
|
||||||
This is similar to how erc or jabber handle authentication in
|
|
||||||
emacs, but the following disclaimer always worth reminding.
|
|
||||||
|
|
||||||
DISCLAIMER
|
|
||||||
When you save this variable, DON'T WRITE IT ANYWHERE PUBLIC. This
|
|
||||||
token grants (very) limited access to your account.
|
|
||||||
END DISCLAIMER
|
|
||||||
|
|
||||||
If nil, Github-Notifier will ask you and remember your token via
|
|
||||||
`customize-save-variable'."
|
|
||||||
:type '(choice (string :tag "Token")
|
|
||||||
(const :tag "Ask me" nil))
|
|
||||||
:group 'github-notifier)
|
|
||||||
|
|
||||||
(defcustom github-notifier-mode-line
|
|
||||||
'(:eval
|
|
||||||
(let (unread-text help-text)
|
|
||||||
(cond ((null github-notifier-unread-count)
|
|
||||||
(setq unread-text "-?"
|
|
||||||
help-text "The Github notifications number is unknown."))
|
|
||||||
((zerop github-notifier-unread-count)
|
|
||||||
(setq unread-text ""
|
|
||||||
help-text "Good job, you don't have unread notification."))
|
|
||||||
(t
|
|
||||||
(setq unread-text (format "-%d%s" github-notifier-unread-count
|
|
||||||
(if (github-notifier-notifications-checked) "*" ""))
|
|
||||||
help-text (if (= github-notifier-unread-count 1)
|
|
||||||
"You have 1 unread notification.\nmouse-1 Read it on Github."
|
|
||||||
(format "You have %d unread notifications.\nmouse-1 Read them on Github."
|
|
||||||
github-notifier-unread-count)))))
|
|
||||||
(propertize (concat " GH" unread-text)
|
|
||||||
'help-echo help-text
|
|
||||||
'local-map github-notifier-mode-line-map
|
|
||||||
'mouse-face 'mode-line-highlight)))
|
|
||||||
"Mode line lighter for Github Notifier."
|
|
||||||
:type 'sexp
|
|
||||||
:risky t
|
|
||||||
:group 'github-notifier)
|
|
||||||
|
|
||||||
(defcustom github-notifier-update-interval 60
|
|
||||||
"Seconds after which the github notifications count will be updated."
|
|
||||||
:type 'integer
|
|
||||||
:group 'github-notifier)
|
|
||||||
|
|
||||||
(defcustom github-notifier-only-participating nil
|
|
||||||
"If non-nil, only counts notifications in which the user is directly participating or mentioned."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'github-notifier)
|
|
||||||
|
|
||||||
(defcustom github-notifier-enterprise-domain nil
|
|
||||||
"Domain to Github installation.
|
|
||||||
Can be overriden to support Enterprise installations"
|
|
||||||
:type 'string
|
|
||||||
:group 'github-notifier)
|
|
||||||
|
|
||||||
;;; Variables
|
|
||||||
(defvar github-notifier-unread-count nil
|
|
||||||
"Github notifications unread count.
|
|
||||||
Normally, this is a number, however, nil means unknown by Emacs.")
|
|
||||||
|
|
||||||
(defvar github-notifier-unread-json nil
|
|
||||||
"JSON object contains latest (to github-notifier) unread notifications.")
|
|
||||||
|
|
||||||
(defvar github-notifier-update-hook nil
|
|
||||||
"Run by `github-notifier-update-cb'.
|
|
||||||
Functions added to this hook takes one argument, the unread
|
|
||||||
notification json object BEFORE updating. Accordingly,
|
|
||||||
`github-notifier-unread-json' stores the unread notification json
|
|
||||||
AFTER updating.")
|
|
||||||
|
|
||||||
(defvar github-notifier-mode-line-map
|
|
||||||
(let ((map (make-sparse-keymap)))
|
|
||||||
(define-key map [mode-line mouse-1] 'github-notifier-visit-github)
|
|
||||||
map))
|
|
||||||
|
|
||||||
(defvar github-notifier-last-notification nil)
|
|
||||||
(defvar github-notifier-last-notification-checked nil)
|
|
||||||
(defvar github-notifier-update-timer nil)
|
|
||||||
|
|
||||||
;;; Function
|
|
||||||
(defun github-notifier-get-url (path &optional api-request)
|
|
||||||
"Get URL to Github endpoint.
|
|
||||||
Get a url to PATH on Github or Github enterprise if
|
|
||||||
`github-enterprise-domain' is set. If API-REQUEST is true it
|
|
||||||
will return an API."
|
|
||||||
(let ((url
|
|
||||||
(if github-notifier-enterprise-domain
|
|
||||||
(concat github-notifier-enterprise-domain (when api-request "/api/v3"))
|
|
||||||
(concat (when api-request "api.") "github.com"))))
|
|
||||||
(concat "https://" url path)))
|
|
||||||
|
|
||||||
;; FIXME: Even we use `url-retrieve' to retrieve network asynchronously, Emacs
|
|
||||||
;; still gets blocked frequently (?), especially when the network situation is
|
|
||||||
;; bad, once it blocks Emacs, you have to wait to it gets finised or interrupt
|
|
||||||
;; it by hitting C-g many times. This is very annoying.
|
|
||||||
;;
|
|
||||||
;; Maybe we can try to invoke curl(1) as asynchronous process.
|
|
||||||
(defun github-notifier-update-cb (_status)
|
|
||||||
(set-buffer-multibyte t)
|
|
||||||
(goto-char (point-min))
|
|
||||||
(if (not (string-match "200 OK" (buffer-string)))
|
|
||||||
(progn (message "[github-notifier] Problem connecting to the server")
|
|
||||||
(setq github-notifier-unread-count nil))
|
|
||||||
(re-search-forward "^$" nil 'move)
|
|
||||||
(let (json-str
|
|
||||||
(old-count github-notifier-unread-count)
|
|
||||||
(old-json github-notifier-unread-json))
|
|
||||||
(setq json-str (buffer-substring-no-properties (point) (point-max))
|
|
||||||
github-notifier-unread-json (json-read-from-string json-str))
|
|
||||||
(setq github-notifier-unread-count (length github-notifier-unread-json))
|
|
||||||
(when (> github-notifier-unread-count 0)
|
|
||||||
(setq github-notifier-last-notification (cdr (assoc 'updated_at (elt github-notifier-unread-json 0)))))
|
|
||||||
(unless (and (equal old-count github-notifier-unread-count)
|
|
||||||
(github-notifier-notifications-checked))
|
|
||||||
(force-mode-line-update t))
|
|
||||||
(run-hook-with-args 'github-notifier-update-hook old-json)
|
|
||||||
;; Debug
|
|
||||||
;; (setq a-json-string json-str)
|
|
||||||
;; (message "Github notification %d unread, updated at %s"
|
|
||||||
;; github-notifier-unread-count (current-time-string))
|
|
||||||
))
|
|
||||||
;; Debug
|
|
||||||
;; (display-buffer (current-buffer))
|
|
||||||
(kill-buffer)
|
|
||||||
(when github-notifier-mode
|
|
||||||
(setq github-notifier-update-timer
|
|
||||||
(run-at-time github-notifier-update-interval nil #'github-notifier-update))))
|
|
||||||
|
|
||||||
(defun github-notifier-update (&optional force)
|
|
||||||
"Update `github-notifier-unread-count'."
|
|
||||||
(when (or force github-notifier-mode)
|
|
||||||
(let ((url-request-extra-headers `(("Authorization" .
|
|
||||||
,(format "token %s" github-notifier-token))))
|
|
||||||
(url (github-notifier-get-url (concat "/notifications"
|
|
||||||
(when github-notifier-only-participating
|
|
||||||
"?participating=true")) t)))
|
|
||||||
(condition-case error-data
|
|
||||||
(url-retrieve url #'github-notifier-update-cb nil t t)
|
|
||||||
(error
|
|
||||||
(message "Error retrieving github notification from %s: %s" url error-data)
|
|
||||||
(when github-notifier-mode
|
|
||||||
(setq github-notifier-update-timer
|
|
||||||
(run-at-time github-notifier-update-interval nil #'github-notifier-update))))))))
|
|
||||||
|
|
||||||
(defun github-notifier-visit-github ()
|
|
||||||
(interactive)
|
|
||||||
(browse-url (github-notifier-get-url "/notifications"))
|
|
||||||
(setq github-notifier-last-notification-checked (format-time-string "%FT%TZ" (current-time) t))
|
|
||||||
(force-mode-line-update t))
|
|
||||||
|
|
||||||
(defun github-notifier-notifications-checked ()
|
|
||||||
(and github-notifier-unread-count (> github-notifier-unread-count 0)
|
|
||||||
github-notifier-last-notification github-notifier-last-notification-checked
|
|
||||||
(string< github-notifier-last-notification github-notifier-last-notification-checked)))
|
|
||||||
|
|
||||||
;;; Glboal Minor-mode
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defalias 'github-notifier 'github-notifier-mode)
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(define-minor-mode github-notifier-mode
|
|
||||||
"Toggle github notifications count display in mode line (Github Notifier mode).
|
|
||||||
With a prefix argument ARG, enable Github Notifier mode if ARG is
|
|
||||||
positive, and disable it otherwise. If called from Lisp, enable
|
|
||||||
the mode if ARG is omitted or nil."
|
|
||||||
:global t :group 'github-notifier
|
|
||||||
(unless github-notifier-token
|
|
||||||
(setq github-notifier-token
|
|
||||||
(with-temp-buffer
|
|
||||||
(when (or
|
|
||||||
(= 0 (call-process "git" nil t nil "config" "github-notifier.oauth-token"))
|
|
||||||
(= 0 (call-process "git" nil t nil "config" "github.oauth-token")))
|
|
||||||
(buffer-substring 1 (progn (goto-char 1) (line-end-position)))))))
|
|
||||||
(unless (stringp github-notifier-token)
|
|
||||||
(browse-url (github-notifier-get-url "/settings/tokens/new?scopes=notifications&description=github-notifier.el"))
|
|
||||||
(let (token)
|
|
||||||
(unwind-protect
|
|
||||||
(setq token (read-string "Paste Your Access Token: "))
|
|
||||||
(if (stringp token)
|
|
||||||
(customize-save-variable 'github-notifier-token token)
|
|
||||||
(message "No Access Token")
|
|
||||||
(setq github-notifier-mode nil)))))
|
|
||||||
(unless global-mode-string
|
|
||||||
(setq global-mode-string '("")))
|
|
||||||
(if (not github-notifier-mode)
|
|
||||||
(progn
|
|
||||||
(setq global-mode-string
|
|
||||||
(delq 'github-notifier-mode-line global-mode-string))
|
|
||||||
(when github-notifier-update-timer
|
|
||||||
(cancel-timer github-notifier-update-timer)
|
|
||||||
(setq github-notifier-update-timer nil)))
|
|
||||||
(add-to-list 'global-mode-string 'github-notifier-mode-line t)
|
|
||||||
(github-notifier-update)))
|
|
||||||
|
|
||||||
(provide 'github-notifier)
|
|
||||||
;;; github-notifier.el ends here
|
|
||||||
@ -1,551 +0,0 @@
|
|||||||
;;; go-guru.el --- Integration of the Go 'guru' analysis tool into Emacs.
|
|
||||||
|
|
||||||
;; Copyright 2016 The Go Authors. All rights reserved.
|
|
||||||
;; Use of this source code is governed by a BSD-style
|
|
||||||
;; license that can be found in the LICENSE file.
|
|
||||||
|
|
||||||
;; Version: 0.1
|
|
||||||
;; Package-Requires: ((go-mode "1.3.1") (cl-lib "0.5"))
|
|
||||||
;; Keywords: tools
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; To enable the Go guru in Emacs, use this command to download,
|
|
||||||
;; build, and install the tool in $GOROOT/bin:
|
|
||||||
;;
|
|
||||||
;; $ go get golang.org/x/tools/cmd/guru
|
|
||||||
;;
|
|
||||||
;; Verify that the tool is on your $PATH:
|
|
||||||
;;
|
|
||||||
;; $ guru -help
|
|
||||||
;; Go source code guru.
|
|
||||||
;; Usage: guru [flags] <mode> <position>
|
|
||||||
;; ...
|
|
||||||
;;
|
|
||||||
;; Then copy this file to a directory on your `load-path',
|
|
||||||
;; and add this to your ~/.emacs:
|
|
||||||
;;
|
|
||||||
;; (require 'go-guru)
|
|
||||||
;;
|
|
||||||
;; Inside a buffer of Go source code, select an expression of
|
|
||||||
;; interest, and type `C-c C-o d' (for "describe") or run one of the
|
|
||||||
;; other go-guru-xxx commands. If you use `menu-bar-mode', these
|
|
||||||
;; commands are available from the Guru menu.
|
|
||||||
;;
|
|
||||||
;; To enable identifier highlighting mode in a Go source buffer, use:
|
|
||||||
;;
|
|
||||||
;; (go-guru-hl-identifier-mode)
|
|
||||||
;;
|
|
||||||
;; To enable it automatically in all Go source buffers,
|
|
||||||
;; add this to your ~/.emacs:
|
|
||||||
;;
|
|
||||||
;; (add-hook 'go-mode-hook #'go-guru-hl-identifier-mode)
|
|
||||||
;;
|
|
||||||
;; See http://golang.org/s/using-guru for more information about guru.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'compile)
|
|
||||||
(require 'easymenu)
|
|
||||||
(require 'go-mode)
|
|
||||||
(require 'json)
|
|
||||||
(require 'simple)
|
|
||||||
(require 'cl-lib)
|
|
||||||
|
|
||||||
(defgroup go-guru nil
|
|
||||||
"Options specific to the Go guru."
|
|
||||||
:group 'go)
|
|
||||||
|
|
||||||
(defcustom go-guru-command "guru"
|
|
||||||
"The Go guru command."
|
|
||||||
:type 'string
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defcustom go-guru-scope ""
|
|
||||||
"The scope of the analysis. See `go-guru-set-scope'."
|
|
||||||
:type 'string
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defvar go-guru--scope-history
|
|
||||||
nil
|
|
||||||
"History of values supplied to `go-guru-set-scope'.")
|
|
||||||
|
|
||||||
(defcustom go-guru-build-tags ""
|
|
||||||
"Build tags passed to guru."
|
|
||||||
:type 'string
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defface go-guru-hl-identifier-face
|
|
||||||
'((t (:inherit highlight)))
|
|
||||||
"Face used for highlighting identifiers in `go-guru-hl-identifier'."
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defcustom go-guru-debug nil
|
|
||||||
"Print debug messages when running guru."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defcustom go-guru-hl-identifier-idle-time 0.5
|
|
||||||
"How long to wait after user input before highlighting the current identifier."
|
|
||||||
:type 'float
|
|
||||||
:group 'go-guru)
|
|
||||||
|
|
||||||
(defvar go-guru--current-hl-identifier-idle-time
|
|
||||||
0
|
|
||||||
"The current delay for hl-identifier-mode.")
|
|
||||||
|
|
||||||
(defvar go-guru--hl-identifier-timer
|
|
||||||
nil
|
|
||||||
"The global timer used for highlighting identifiers.")
|
|
||||||
|
|
||||||
(defvar go-guru--last-enclosing
|
|
||||||
nil
|
|
||||||
"The remaining enclosing regions of the previous go-expand-region invocation.")
|
|
||||||
|
|
||||||
;; Extend go-mode-map.
|
|
||||||
(let ((m (define-prefix-command 'go-guru-map)))
|
|
||||||
(define-key m "d" #'go-guru-describe)
|
|
||||||
(define-key m "f" #'go-guru-freevars)
|
|
||||||
(define-key m "i" #'go-guru-implements)
|
|
||||||
(define-key m "c" #'go-guru-peers) ; c for channel
|
|
||||||
(define-key m "r" #'go-guru-referrers)
|
|
||||||
(define-key m "j" #'go-guru-definition) ; j for jump
|
|
||||||
(define-key m "p" #'go-guru-pointsto)
|
|
||||||
(define-key m "s" #'go-guru-callstack) ; s for stack
|
|
||||||
(define-key m "e" #'go-guru-whicherrs) ; e for error
|
|
||||||
(define-key m "<" #'go-guru-callers)
|
|
||||||
(define-key m ">" #'go-guru-callees)
|
|
||||||
(define-key m "x" #'go-guru-expand-region)) ;; x for expand
|
|
||||||
|
|
||||||
(define-key go-mode-map (kbd "C-c C-o") #'go-guru-map)
|
|
||||||
|
|
||||||
(easy-menu-define go-guru-mode-menu go-mode-map
|
|
||||||
"Menu for Go Guru."
|
|
||||||
'("Guru"
|
|
||||||
["Jump to Definition" go-guru-definition t]
|
|
||||||
["Show Referrers" go-guru-referrers t]
|
|
||||||
["Show Free Names" go-guru-freevars t]
|
|
||||||
["Describe Expression" go-guru-describe t]
|
|
||||||
["Show Implements" go-guru-implements t]
|
|
||||||
"---"
|
|
||||||
["Show Callers" go-guru-callers t]
|
|
||||||
["Show Callees" go-guru-callees t]
|
|
||||||
["Show Callstack" go-guru-callstack t]
|
|
||||||
"---"
|
|
||||||
["Show Points-To" go-guru-pointsto t]
|
|
||||||
["Show Which Errors" go-guru-whicherrs t]
|
|
||||||
["Show Channel Peers" go-guru-peers t]
|
|
||||||
"---"
|
|
||||||
["Set pointer analysis scope..." go-guru-set-scope t]))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-set-scope ()
|
|
||||||
"Set the scope for the Go guru, prompting the user to edit the previous scope.
|
|
||||||
|
|
||||||
The scope restricts analysis to the specified packages.
|
|
||||||
Its value is a comma-separated list of patterns of these forms:
|
|
||||||
golang.org/x/tools/cmd/guru # a single package
|
|
||||||
golang.org/x/tools/... # all packages beneath dir
|
|
||||||
... # the entire workspace.
|
|
||||||
|
|
||||||
A pattern preceded by '-' is negative, so the scope
|
|
||||||
encoding/...,-encoding/xml
|
|
||||||
matches all encoding packages except encoding/xml."
|
|
||||||
(interactive)
|
|
||||||
(let ((scope (read-from-minibuffer "Go guru scope: "
|
|
||||||
go-guru-scope
|
|
||||||
nil
|
|
||||||
nil
|
|
||||||
'go-guru--scope-history)))
|
|
||||||
(if (string-equal "" scope)
|
|
||||||
(error "You must specify a non-empty scope for the Go guru"))
|
|
||||||
(setq go-guru-scope scope)))
|
|
||||||
|
|
||||||
(defun go-guru--set-scope-if-empty ()
|
|
||||||
(if (string-equal "" go-guru-scope)
|
|
||||||
(go-guru-set-scope)))
|
|
||||||
|
|
||||||
(defun go-guru--json (mode)
|
|
||||||
"Execute the Go guru in the specified MODE, passing it the
|
|
||||||
selected region of the current buffer, requesting JSON output.
|
|
||||||
Parse and return the resulting JSON object."
|
|
||||||
;; A "what" query works even in a buffer without a file name.
|
|
||||||
(let* ((filename (file-truename (or buffer-file-name "synthetic.go")))
|
|
||||||
(cmd (go-guru--command mode filename '("-json")))
|
|
||||||
(buf (current-buffer))
|
|
||||||
;; Use temporary buffers to avoid conflict with go-guru--start.
|
|
||||||
(json-buffer (generate-new-buffer "*go-guru-json-output*"))
|
|
||||||
(input-buffer (generate-new-buffer "*go-guru-json-input*")))
|
|
||||||
(unwind-protect
|
|
||||||
;; Run guru, feeding it the input buffer (modified files).
|
|
||||||
(with-current-buffer input-buffer
|
|
||||||
(go-guru--insert-modified-files)
|
|
||||||
(unless (buffer-file-name buf)
|
|
||||||
(go-guru--insert-modified-file filename buf))
|
|
||||||
(let ((exitcode (apply #'call-process-region
|
|
||||||
(append (list (point-min)
|
|
||||||
(point-max)
|
|
||||||
(car cmd) ; guru
|
|
||||||
nil ; delete
|
|
||||||
json-buffer ; output
|
|
||||||
nil) ; display
|
|
||||||
(cdr cmd))))) ; args
|
|
||||||
(with-current-buffer json-buffer
|
|
||||||
(unless (zerop exitcode)
|
|
||||||
;; Failed: use buffer contents (sans final \n) as an error.
|
|
||||||
(error "%s" (buffer-substring (point-min) (1- (point-max)))))
|
|
||||||
;; Success: parse JSON.
|
|
||||||
(goto-char (point-min))
|
|
||||||
(json-read))))
|
|
||||||
;; Clean up temporary buffers.
|
|
||||||
(kill-buffer json-buffer)
|
|
||||||
(kill-buffer input-buffer))))
|
|
||||||
|
|
||||||
(define-compilation-mode go-guru-output-mode "Go guru"
|
|
||||||
"Go guru output mode is a variant of `compilation-mode' for the
|
|
||||||
output of the Go guru tool."
|
|
||||||
(set (make-local-variable 'compilation-error-screen-columns) nil)
|
|
||||||
(set (make-local-variable 'compilation-filter-hook) #'go-guru--compilation-filter-hook)
|
|
||||||
(set (make-local-variable 'compilation-start-hook) #'go-guru--compilation-start-hook))
|
|
||||||
|
|
||||||
(defun go-guru--compilation-filter-hook ()
|
|
||||||
"Post-process a blob of input to the go-guru-output buffer."
|
|
||||||
;; For readability, truncate each "file:line:col:" prefix to a fixed width.
|
|
||||||
;; If the prefix is longer than 20, show "…/last/19chars.go".
|
|
||||||
;; This usually includes the last segment of the package name.
|
|
||||||
;; Hide the line and column numbers.
|
|
||||||
(let ((start compilation-filter-start)
|
|
||||||
(end (point)))
|
|
||||||
(goto-char start)
|
|
||||||
(unless (bolp)
|
|
||||||
;; TODO(adonovan): not quite right: the filter may be called
|
|
||||||
;; with chunks of output containing incomplete lines. Moving to
|
|
||||||
;; beginning-of-line may cause duplicate post-processing.
|
|
||||||
(beginning-of-line))
|
|
||||||
(setq start (point))
|
|
||||||
(while (< start end)
|
|
||||||
(let ((p (search-forward ": " end t)))
|
|
||||||
(if (null p)
|
|
||||||
(setq start end) ; break out of loop
|
|
||||||
(setq p (1- p)) ; exclude final space
|
|
||||||
(let* ((posn (buffer-substring-no-properties start p))
|
|
||||||
(flen (cl-search ":" posn)) ; length of filename
|
|
||||||
(filename (if (< flen 19)
|
|
||||||
(substring posn 0 flen)
|
|
||||||
(concat "…" (substring posn (- flen 19) flen)))))
|
|
||||||
(put-text-property start p 'display filename)
|
|
||||||
(forward-line 1)
|
|
||||||
(setq start (point))))))))
|
|
||||||
|
|
||||||
(defun go-guru--compilation-start-hook (proc)
|
|
||||||
"Erase default output header inserted by `compilation-mode'."
|
|
||||||
(with-current-buffer (process-buffer proc)
|
|
||||||
(let ((inhibit-read-only t))
|
|
||||||
(beginning-of-buffer)
|
|
||||||
(delete-region (point) (point-max)))))
|
|
||||||
|
|
||||||
(defun go-guru--start (mode)
|
|
||||||
"Start an asynchronous Go guru process for the specified query
|
|
||||||
MODE, passing it the selected region of the current buffer, and
|
|
||||||
feeding its standard input with the contents of all modified Go
|
|
||||||
buffers. Its output is handled by `go-guru-output-mode', a
|
|
||||||
variant of `compilation-mode'."
|
|
||||||
(or buffer-file-name
|
|
||||||
(error "Cannot use guru on a buffer without a file name"))
|
|
||||||
(let* ((filename (file-truename buffer-file-name))
|
|
||||||
(cmd (mapconcat #'shell-quote-argument (go-guru--command mode filename) " "))
|
|
||||||
(process-connection-type nil) ; use pipe (not pty) so EOF closes stdin
|
|
||||||
(procbuf (compilation-start cmd 'go-guru-output-mode)))
|
|
||||||
(with-current-buffer procbuf
|
|
||||||
(setq truncate-lines t)) ; the output is neater without line wrapping
|
|
||||||
(with-current-buffer (get-buffer-create "*go-guru-input*")
|
|
||||||
(erase-buffer)
|
|
||||||
(go-guru--insert-modified-files)
|
|
||||||
(process-send-region procbuf (point-min) (point-max))
|
|
||||||
(process-send-eof procbuf))
|
|
||||||
procbuf))
|
|
||||||
|
|
||||||
(defun go-guru--command (mode filename &optional flags)
|
|
||||||
"Return a command and argument list for a Go guru query of MODE, passing it
|
|
||||||
the selected region of the current buffer. FILENAME is the
|
|
||||||
effective name of the current buffer."
|
|
||||||
(let* ((posn (if (use-region-p)
|
|
||||||
(format "%s:#%d,#%d"
|
|
||||||
filename
|
|
||||||
(1- (go--position-bytes (region-beginning)))
|
|
||||||
(1- (go--position-bytes (region-end))))
|
|
||||||
(format "%s:#%d"
|
|
||||||
filename
|
|
||||||
(1- (go--position-bytes (point))))))
|
|
||||||
(cmd (append (list go-guru-command
|
|
||||||
"-modified"
|
|
||||||
"-scope" go-guru-scope
|
|
||||||
(format "-tags=%s" (mapconcat 'identity go-guru-build-tags ",")))
|
|
||||||
flags
|
|
||||||
(list mode
|
|
||||||
posn))))
|
|
||||||
;; Log the command to *Messages*, for debugging.
|
|
||||||
(when go-guru-debug
|
|
||||||
(message "go-guru--command: %s" cmd)
|
|
||||||
(message nil)) ; clear/shrink minibuffer
|
|
||||||
cmd))
|
|
||||||
|
|
||||||
(defun go-guru--insert-modified-files ()
|
|
||||||
"Insert the contents of each modified Go buffer into the
|
|
||||||
current buffer in the format specified by guru's -modified flag."
|
|
||||||
(mapc #'(lambda (b)
|
|
||||||
(and (buffer-modified-p b)
|
|
||||||
(buffer-file-name b)
|
|
||||||
(string= (file-name-extension (buffer-file-name b)) "go")
|
|
||||||
(go-guru--insert-modified-file (buffer-file-name b) b)))
|
|
||||||
(buffer-list)))
|
|
||||||
|
|
||||||
(defun go-guru--insert-modified-file (name buffer)
|
|
||||||
(insert (format "%s\n%d\n" name (go-guru--buffer-size-bytes buffer)))
|
|
||||||
(insert-buffer-substring buffer))
|
|
||||||
|
|
||||||
(defun go-guru--buffer-size-bytes (&optional buffer)
|
|
||||||
"Return the number of bytes in the current buffer.
|
|
||||||
If BUFFER, return the number of characters in that buffer instead."
|
|
||||||
(with-current-buffer (or buffer (current-buffer))
|
|
||||||
(string-bytes (buffer-substring (point-min)
|
|
||||||
(point-max)))))
|
|
||||||
|
|
||||||
(defun go-guru--goto-byte (offset)
|
|
||||||
"Go to the OFFSETth byte in the buffer."
|
|
||||||
(goto-char (byte-to-position offset)))
|
|
||||||
|
|
||||||
(defun go-guru--goto-byte-column (offset)
|
|
||||||
"Go to the OFFSETth byte in the current line."
|
|
||||||
(goto-char (byte-to-position (+ (position-bytes (point-at-bol)) (1- offset)))))
|
|
||||||
|
|
||||||
(defun go-guru--goto-pos (posn)
|
|
||||||
"Find the file containing the position POSN (of the form `file:line:col')
|
|
||||||
set the point to it, switching the current buffer."
|
|
||||||
(let ((file-line-pos (split-string posn ":")))
|
|
||||||
(find-file (car file-line-pos))
|
|
||||||
(goto-char (point-min))
|
|
||||||
(forward-line (1- (string-to-number (cadr file-line-pos))))
|
|
||||||
(go-guru--goto-byte-column (string-to-number (cl-caddr file-line-pos)))))
|
|
||||||
|
|
||||||
(defun go-guru--goto-pos-no-file (posn)
|
|
||||||
"Given `file:line:col', go to the line and column. The file
|
|
||||||
component will be ignored."
|
|
||||||
(let ((file-line-pos (split-string posn ":")))
|
|
||||||
(goto-char (point-min))
|
|
||||||
(forward-line (1- (string-to-number (cadr file-line-pos))))
|
|
||||||
(go-guru--goto-byte-column (string-to-number (cl-caddr file-line-pos)))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-callees ()
|
|
||||||
"Show possible callees of the function call at the current point."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "callees"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-callers ()
|
|
||||||
"Show the set of callers of the function containing the current point."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "callers"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-callstack ()
|
|
||||||
"Show an arbitrary path from a root of the call graph to the
|
|
||||||
function containing the current point."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "callstack"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-definition ()
|
|
||||||
"Jump to the definition of the selected identifier."
|
|
||||||
(interactive)
|
|
||||||
(or buffer-file-name
|
|
||||||
(error "Cannot use guru on a buffer without a file name"))
|
|
||||||
(let* ((res (go-guru--json "definition"))
|
|
||||||
(desc (cdr (assoc 'desc res))))
|
|
||||||
(push-mark)
|
|
||||||
(ring-insert find-tag-marker-ring (point-marker))
|
|
||||||
(go-guru--goto-pos (cdr (assoc 'objpos res)))
|
|
||||||
(message "%s" desc)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-describe ()
|
|
||||||
"Describe the selected syntax, its kind, type and methods."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--start "describe"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-pointsto ()
|
|
||||||
"Show what the selected expression points to."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "pointsto"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-implements ()
|
|
||||||
"Describe the 'implements' relation for types in the package
|
|
||||||
containing the current point."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--start "implements"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-freevars ()
|
|
||||||
"Enumerate the free variables of the current selection."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--start "freevars"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-peers ()
|
|
||||||
"Enumerate the set of possible corresponding sends/receives for
|
|
||||||
this channel receive/send operation."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "peers"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-referrers ()
|
|
||||||
"Enumerate all references to the object denoted by the selected
|
|
||||||
identifier."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--start "referrers"))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-whicherrs ()
|
|
||||||
"Show globals, constants and types to which the selected
|
|
||||||
expression (of type 'error') may refer."
|
|
||||||
(interactive)
|
|
||||||
(go-guru--set-scope-if-empty)
|
|
||||||
(go-guru--start "whicherrs"))
|
|
||||||
|
|
||||||
(defun go-guru-what ()
|
|
||||||
"Run a 'what' query and return the parsed JSON response as an
|
|
||||||
association list."
|
|
||||||
(go-guru--json "what"))
|
|
||||||
|
|
||||||
(defun go-guru--hl-symbols (posn face id)
|
|
||||||
"Highlight the symbols at the positions POSN by creating
|
|
||||||
overlays with face FACE. The attribute 'go-guru-overlay on the
|
|
||||||
overlays will be set to ID."
|
|
||||||
(save-excursion
|
|
||||||
(mapc (lambda (pos)
|
|
||||||
(go-guru--goto-pos-no-file pos)
|
|
||||||
(let ((x (make-overlay (point) (+ (point) (length (current-word))))))
|
|
||||||
(overlay-put x 'go-guru-overlay id)
|
|
||||||
(overlay-put x 'face face)))
|
|
||||||
posn)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-unhighlight-identifiers ()
|
|
||||||
"Remove highlights from previously highlighted identifier."
|
|
||||||
(remove-overlays nil nil 'go-guru-overlay 'sameid))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun go-guru-hl-identifier ()
|
|
||||||
"Highlight all instances of the identifier under point. Removes
|
|
||||||
highlights from previously highlighted identifier."
|
|
||||||
(interactive)
|
|
||||||
(go-guru-unhighlight-identifiers)
|
|
||||||
(go-guru--hl-identifier))
|
|
||||||
|
|
||||||
(defun go-guru--hl-identifier ()
|
|
||||||
"Highlight all instances of the identifier under point."
|
|
||||||
(let ((posn (cdr (assoc 'sameids (go-guru-what)))))
|
|
||||||
(go-guru--hl-symbols posn 'go-guru-hl-identifier-face 'sameid)))
|
|
||||||
|
|
||||||
(defun go-guru--hl-identifiers-function ()
|
|
||||||
"Function run after an idle timeout, highlighting the
|
|
||||||
identifier at point, if necessary."
|
|
||||||
(when go-guru-hl-identifier-mode
|
|
||||||
(unless (go-guru--on-overlay-p 'sameid)
|
|
||||||
;; Ignore guru errors. Otherwise, we might end up with an error
|
|
||||||
;; every time the timer runs, e.g. because of a malformed
|
|
||||||
;; buffer.
|
|
||||||
(condition-case nil
|
|
||||||
(go-guru-hl-identifier)
|
|
||||||
(error nil)))
|
|
||||||
(unless (eq go-guru--current-hl-identifier-idle-time go-guru-hl-identifier-idle-time)
|
|
||||||
(go-guru--hl-set-timer))))
|
|
||||||
|
|
||||||
(defun go-guru--hl-set-timer ()
|
|
||||||
(if go-guru--hl-identifier-timer
|
|
||||||
(cancel-timer go-guru--hl-identifier-timer))
|
|
||||||
(setq go-guru--current-hl-identifier-idle-time go-guru-hl-identifier-idle-time)
|
|
||||||
(setq go-guru--hl-identifier-timer (run-with-idle-timer
|
|
||||||
go-guru-hl-identifier-idle-time
|
|
||||||
t
|
|
||||||
#'go-guru--hl-identifiers-function)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(define-minor-mode go-guru-hl-identifier-mode
|
|
||||||
"Highlight instances of the identifier at point after a short
|
|
||||||
timeout."
|
|
||||||
:group 'go-guru
|
|
||||||
(if go-guru-hl-identifier-mode
|
|
||||||
(progn
|
|
||||||
(go-guru--hl-set-timer)
|
|
||||||
;; Unhighlight if point moves off identifier
|
|
||||||
(add-hook 'post-command-hook #'go-guru--hl-identifiers-post-command-hook nil t)
|
|
||||||
;; Unhighlight any time the buffer changes
|
|
||||||
(add-hook 'before-change-functions #'go-guru--hl-identifiers-before-change-function nil t))
|
|
||||||
(remove-hook 'post-command-hook #'go-guru--hl-identifiers-post-command-hook t)
|
|
||||||
(remove-hook 'before-change-functions #'go-guru--hl-identifiers-before-change-function t)
|
|
||||||
(go-guru-unhighlight-identifiers)))
|
|
||||||
|
|
||||||
(defun go-guru--on-overlay-p (id)
|
|
||||||
"Return whether point is on a guru overlay of type ID."
|
|
||||||
(cl-find-if (lambda (el) (eq (overlay-get el 'go-guru-overlay) id)) (overlays-at (point))))
|
|
||||||
|
|
||||||
(defun go-guru--hl-identifiers-post-command-hook ()
|
|
||||||
(if (and go-guru-hl-identifier-mode
|
|
||||||
(not (go-guru--on-overlay-p 'sameid)))
|
|
||||||
(go-guru-unhighlight-identifiers)))
|
|
||||||
|
|
||||||
(defun go-guru--hl-identifiers-before-change-function (_beg _end)
|
|
||||||
(go-guru-unhighlight-identifiers))
|
|
||||||
|
|
||||||
;; TODO(dominikh): a future feature may be to cycle through all uses
|
|
||||||
;; of an identifier.
|
|
||||||
|
|
||||||
(defun go-guru--enclosing ()
|
|
||||||
"Return a list of enclosing regions."
|
|
||||||
(cdr (assoc 'enclosing (go-guru-what))))
|
|
||||||
|
|
||||||
(defun go-guru--enclosing-unique ()
|
|
||||||
"Return a list of enclosing regions, with duplicates removed.
|
|
||||||
Two regions are considered equal if they have the same start and
|
|
||||||
end point."
|
|
||||||
(let ((enclosing (go-guru--enclosing)))
|
|
||||||
(cl-remove-duplicates enclosing
|
|
||||||
:from-end t
|
|
||||||
:test (lambda (a b)
|
|
||||||
(and (= (cdr (assoc 'start a))
|
|
||||||
(cdr (assoc 'start b)))
|
|
||||||
(= (cdr (assoc 'end a))
|
|
||||||
(cdr (assoc 'end b))))))))
|
|
||||||
|
|
||||||
(defun go-guru-expand-region ()
|
|
||||||
"Expand region to the next enclosing syntactic unit."
|
|
||||||
(interactive)
|
|
||||||
(let* ((enclosing (if (eq last-command #'go-guru-expand-region)
|
|
||||||
go-guru--last-enclosing
|
|
||||||
(go-guru--enclosing-unique)))
|
|
||||||
(block (if (> (length enclosing) 0) (elt enclosing 0))))
|
|
||||||
(when block
|
|
||||||
(go-guru--goto-byte (1+ (cdr (assoc 'start block))))
|
|
||||||
(set-mark (byte-to-position (1+ (cdr (assoc 'end block)))))
|
|
||||||
(setq go-guru--last-enclosing (cl-subseq enclosing 1))
|
|
||||||
(message "Region: %s" (cdr (assoc 'desc block)))
|
|
||||||
(setq deactivate-mark nil))))
|
|
||||||
|
|
||||||
|
|
||||||
(provide 'go-guru)
|
|
||||||
|
|
||||||
;; Local variables:
|
|
||||||
;; indent-tabs-mode: t
|
|
||||||
;; tab-width: 8
|
|
||||||
;; End
|
|
||||||
|
|
||||||
;;; go-guru.el ends here
|
|
||||||
@ -1,209 +0,0 @@
|
|||||||
;;; go-mode-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
|
|
||||||
;;;### (autoloads nil "go-guru" "go-guru.el" (22528 41395 701074
|
|
||||||
;;;;;; 26000))
|
|
||||||
;;; Generated autoloads from go-guru.el
|
|
||||||
|
|
||||||
(autoload 'go-guru-set-scope "go-guru" "\
|
|
||||||
Set the scope for the Go guru, prompting the user to edit the previous scope.
|
|
||||||
|
|
||||||
The scope restricts analysis to the specified packages.
|
|
||||||
Its value is a comma-separated list of patterns of these forms:
|
|
||||||
golang.org/x/tools/cmd/guru # a single package
|
|
||||||
golang.org/x/tools/... # all packages beneath dir
|
|
||||||
... # the entire workspace.
|
|
||||||
|
|
||||||
A pattern preceded by '-' is negative, so the scope
|
|
||||||
encoding/...,-encoding/xml
|
|
||||||
matches all encoding packages except encoding/xml.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-callees "go-guru" "\
|
|
||||||
Show possible callees of the function call at the current point.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-callers "go-guru" "\
|
|
||||||
Show the set of callers of the function containing the current point.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-callstack "go-guru" "\
|
|
||||||
Show an arbitrary path from a root of the call graph to the
|
|
||||||
function containing the current point.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-definition "go-guru" "\
|
|
||||||
Jump to the definition of the selected identifier.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-describe "go-guru" "\
|
|
||||||
Describe the selected syntax, its kind, type and methods.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-pointsto "go-guru" "\
|
|
||||||
Show what the selected expression points to.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-implements "go-guru" "\
|
|
||||||
Describe the 'implements' relation for types in the package
|
|
||||||
containing the current point.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-freevars "go-guru" "\
|
|
||||||
Enumerate the free variables of the current selection.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-peers "go-guru" "\
|
|
||||||
Enumerate the set of possible corresponding sends/receives for
|
|
||||||
this channel receive/send operation.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-referrers "go-guru" "\
|
|
||||||
Enumerate all references to the object denoted by the selected
|
|
||||||
identifier.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-whicherrs "go-guru" "\
|
|
||||||
Show globals, constants and types to which the selected
|
|
||||||
expression (of type 'error') may refer.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-unhighlight-identifiers "go-guru" "\
|
|
||||||
Remove highlights from previously highlighted identifier.
|
|
||||||
|
|
||||||
\(fn)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-hl-identifier "go-guru" "\
|
|
||||||
Highlight all instances of the identifier under point. Removes
|
|
||||||
highlights from previously highlighted identifier.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-guru-hl-identifier-mode "go-guru" "\
|
|
||||||
Highlight instances of the identifier at point after a short
|
|
||||||
timeout.
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "go-mode" "go-mode.el" (22528 41395 693074
|
|
||||||
;;;;;; 32000))
|
|
||||||
;;; Generated autoloads from go-mode.el
|
|
||||||
|
|
||||||
(autoload 'go-mode "go-mode" "\
|
|
||||||
Major mode for editing Go source text.
|
|
||||||
|
|
||||||
This mode provides (not just) basic editing capabilities for
|
|
||||||
working with Go code. It offers almost complete syntax
|
|
||||||
highlighting, indentation that is almost identical to gofmt and
|
|
||||||
proper parsing of the buffer content to allow features such as
|
|
||||||
navigation by function, manipulation of comments or detection of
|
|
||||||
strings.
|
|
||||||
|
|
||||||
In addition to these core features, it offers various features to
|
|
||||||
help with writing Go code. You can directly run buffer content
|
|
||||||
through gofmt, read godoc documentation from within Emacs, modify
|
|
||||||
and clean up the list of package imports or interact with the
|
|
||||||
Playground (uploading and downloading pastes).
|
|
||||||
|
|
||||||
The following extra functions are defined:
|
|
||||||
|
|
||||||
- `gofmt'
|
|
||||||
- `godoc' and `godoc-at-point'
|
|
||||||
- `go-import-add'
|
|
||||||
- `go-remove-unused-imports'
|
|
||||||
- `go-goto-arguments'
|
|
||||||
- `go-goto-docstring'
|
|
||||||
- `go-goto-function'
|
|
||||||
- `go-goto-function-name'
|
|
||||||
- `go-goto-imports'
|
|
||||||
- `go-goto-return-values'
|
|
||||||
- `go-goto-method-receiver'
|
|
||||||
- `go-play-buffer' and `go-play-region'
|
|
||||||
- `go-download-play'
|
|
||||||
- `godef-describe' and `godef-jump'
|
|
||||||
- `go-coverage'
|
|
||||||
- `go-set-project'
|
|
||||||
- `go-reset-gopath'
|
|
||||||
|
|
||||||
If you want to automatically run `gofmt' before saving a file,
|
|
||||||
add the following hook to your emacs configuration:
|
|
||||||
|
|
||||||
\(add-hook 'before-save-hook #'gofmt-before-save)
|
|
||||||
|
|
||||||
If you want to use `godef-jump' instead of etags (or similar),
|
|
||||||
consider binding godef-jump to `M-.', which is the default key
|
|
||||||
for `find-tag':
|
|
||||||
|
|
||||||
\(add-hook 'go-mode-hook (lambda ()
|
|
||||||
(local-set-key (kbd \"M-.\") #'godef-jump)))
|
|
||||||
|
|
||||||
Please note that godef is an external dependency. You can install
|
|
||||||
it with
|
|
||||||
|
|
||||||
go get github.com/rogpeppe/godef
|
|
||||||
|
|
||||||
|
|
||||||
If you're looking for even more integration with Go, namely
|
|
||||||
on-the-fly syntax checking, auto-completion and snippets, it is
|
|
||||||
recommended that you look at flycheck
|
|
||||||
\(see URL `https://github.com/flycheck/flycheck') or flymake in combination
|
|
||||||
with goflymake (see URL `https://github.com/dougm/goflymake'), gocode
|
|
||||||
\(see URL `https://github.com/nsf/gocode'), go-eldoc
|
|
||||||
\(see URL `github.com/syohex/emacs-go-eldoc') and yasnippet-go
|
|
||||||
\(see URL `https://github.com/dominikh/yasnippet-go')
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(add-to-list 'auto-mode-alist (cons "\\.go\\'" 'go-mode))
|
|
||||||
|
|
||||||
(autoload 'gofmt-before-save "go-mode" "\
|
|
||||||
Add this to .emacs to run gofmt on the current buffer when saving:
|
|
||||||
(add-hook 'before-save-hook 'gofmt-before-save).
|
|
||||||
|
|
||||||
Note that this will cause go-mode to get loaded the first time
|
|
||||||
you save any file, kind of defeating the point of autoloading.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'godoc "go-mode" "\
|
|
||||||
Show Go documentation for QUERY, much like M-x man.
|
|
||||||
|
|
||||||
\(fn QUERY)" t nil)
|
|
||||||
|
|
||||||
(autoload 'go-download-play "go-mode" "\
|
|
||||||
Download a paste from the playground and insert it in a Go buffer.
|
|
||||||
Tries to look for a URL at point.
|
|
||||||
|
|
||||||
\(fn URL)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("go-mode-pkg.el") (22528 41395 685074
|
|
||||||
;;;;;; 38000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
(provide 'go-mode-autoloads)
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; coding: utf-8
|
|
||||||
;; End:
|
|
||||||
;;; go-mode-autoloads.el ends here
|
|
||||||
@ -1,5 +0,0 @@
|
|||||||
(define-package "go-mode" "20161013.1055" "Major mode for the Go programming language" 'nil :url "https://github.com/dominikh/go-mode.el" :keywords
|
|
||||||
'("languages" "go"))
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,69 +0,0 @@
|
|||||||
;;; grizzl-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "grizzl" "grizzl.el" (22454 5325 478331 394000))
|
|
||||||
;;; Generated autoloads from grizzl.el
|
|
||||||
|
|
||||||
(autoload 'grizzl-make-index "grizzl" "\
|
|
||||||
Makes an index from the list STRINGS for use with `grizzl-search'.
|
|
||||||
|
|
||||||
If :PROGRESS-FN is given as a keyword argument, it is called repeatedly
|
|
||||||
with integers N and TOTAL.
|
|
||||||
|
|
||||||
If :CASE-SENSITIVE is specified as a non-nil keyword argument, the index
|
|
||||||
will be created case-sensitive, otherwise it will be case-insensitive.
|
|
||||||
|
|
||||||
\(fn STRINGS &rest OPTIONS)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-search "grizzl" "\
|
|
||||||
Fuzzy searches for TERM in INDEX prepared with `grizzl-make-index'.
|
|
||||||
|
|
||||||
OLD-RESULT may be specified as an existing search result to increment from.
|
|
||||||
The result can be read with `grizzl-result-strings'.
|
|
||||||
|
|
||||||
\(fn TERM INDEX &optional OLD-RESULT)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-result-count "grizzl" "\
|
|
||||||
Returns the number of matches present in RESULT.
|
|
||||||
|
|
||||||
\(fn RESULT)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-result-strings "grizzl" "\
|
|
||||||
Returns the ordered list of matched strings in RESULT, using INDEX.
|
|
||||||
|
|
||||||
If the :START option is specified, results are read from the given offset.
|
|
||||||
If the :END option is specified, up to :END results are returned.
|
|
||||||
|
|
||||||
\(fn RESULT INDEX &rest OPTIONS)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-completing-read "grizzl" "\
|
|
||||||
Performs a completing-read in the minibuffer using INDEX to fuzzy search.
|
|
||||||
Each key pressed in the minibuffer filters down the list of matches.
|
|
||||||
|
|
||||||
\(fn PROMPT INDEX)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-selected-result "grizzl" "\
|
|
||||||
Get the selected string from INDEX in a `grizzl-completing-read'.
|
|
||||||
|
|
||||||
\(fn INDEX)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-set-selection+1 "grizzl" "\
|
|
||||||
Move the selection up one row in `grizzl-completing-read'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'grizzl-set-selection-1 "grizzl" "\
|
|
||||||
Move the selection down one row in `grizzl-completing-read'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; grizzl-autoloads.el ends here
|
|
||||||
@ -1,2 +0,0 @@
|
|||||||
;;; -*- no-byte-compile: t -*-
|
|
||||||
(define-package "grizzl" "20160818.37" "Fast fuzzy search index for Emacs." '((cl-lib "0.5") (emacs "24.3")) :url "https://github.com/grizzl/grizzl" :keywords '("convenience" "usability"))
|
|
||||||
@ -1,404 +0,0 @@
|
|||||||
;;; grizzl.el --- Fast fuzzy search index for Emacs. -*- lexical-binding: t -*-
|
|
||||||
|
|
||||||
;; Copyright © 2013-2014 Chris Corbyn
|
|
||||||
;; Copyright © 2015 Bozhidar Batsov
|
|
||||||
;;
|
|
||||||
;; Author: Chris Corbyn <chris@w3style.co.uk>
|
|
||||||
;; Maintainer: Bozhidar Batsov <bozhidar@batsov.com>
|
|
||||||
;; URL: https://github.com/grizzl/grizzl
|
|
||||||
;; Package-Version: 20160818.37
|
|
||||||
;; Version: 0.1.2
|
|
||||||
;; Keywords: convenience, usability
|
|
||||||
;; Package-Requires: ((cl-lib "0.5") (emacs "24.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/>.
|
|
||||||
|
|
||||||
;; This file is not part of GNU Emacs.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; Grizzl provides a fuzzy completion framework for general purpose
|
|
||||||
;; use in Emacs Lisp projects.
|
|
||||||
;;
|
|
||||||
;; grizzl provides the underlying data structures and sesrch
|
|
||||||
;; algorithm without any UI attachment. At the core, a fuzzy search
|
|
||||||
;; index is created from a list of strings, using `grizzl-make-index'.
|
|
||||||
;; A fuzzy search term is then used to get a result from this index
|
|
||||||
;; with `grizzl-search'. Because grizzl considers the usage of a
|
|
||||||
;; fuzzy search index to operate in real-time as a user enters a
|
|
||||||
;; search term in the minibuffer, the framework optimizes for this use
|
|
||||||
;; case. Any result can be passed back into `grizzl-search' as a hint
|
|
||||||
;; to continue searching. The search algorithm is able to understand
|
|
||||||
;; insertions and deletions and therefore minimizes the work it needs
|
|
||||||
;; to do in this case. The intended use here is to collect a result
|
|
||||||
;; on each key press and feed that result into the search for the next
|
|
||||||
;; key press. Once a search is complete, the matched strings are then
|
|
||||||
;; read, using `grizzl-result-strings'. The results are ordered on the
|
|
||||||
;; a combination of the Levenshtein Distance and a character-proximity
|
|
||||||
;; scoring calculation. This means shorter strings are favoured, but
|
|
||||||
;; adjacent letters are more heavily favoured.
|
|
||||||
;;
|
|
||||||
;; It is assumed that the index will be re-used across multiple
|
|
||||||
;; searches on larger sets of data.
|
|
||||||
;;
|
|
||||||
;; Call `grizzl-completing-read' with an index returned by
|
|
||||||
;; `grizzl-make-index':
|
|
||||||
;;
|
|
||||||
;; (defvar *index* (grizzl-make-index '("one" "two" "three")))
|
|
||||||
;; (grizzl-completing-read "Number: " *index*)
|
|
||||||
;;
|
|
||||||
;; When the user hits ENTER, either one of the strings is returned on
|
|
||||||
;; success, or nil of nothing matched.
|
|
||||||
;;
|
|
||||||
;; The arrow keys can be used to navigate within the results.
|
|
||||||
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl-lib))
|
|
||||||
|
|
||||||
;;; --- Public Functions
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-make-index (strings &rest options)
|
|
||||||
"Makes an index from the list STRINGS for use with `grizzl-search'.
|
|
||||||
|
|
||||||
If :PROGRESS-FN is given as a keyword argument, it is called repeatedly
|
|
||||||
with integers N and TOTAL.
|
|
||||||
|
|
||||||
If :CASE-SENSITIVE is specified as a non-nil keyword argument, the index
|
|
||||||
will be created case-sensitive, otherwise it will be case-insensitive."
|
|
||||||
(let ((lookup-table (make-hash-table))
|
|
||||||
(total-strs (length strings))
|
|
||||||
(case-sensitive (plist-get options :case-sensitive))
|
|
||||||
(progress-fn (plist-get options :progress-fn))
|
|
||||||
(string-data (vconcat (mapcar (lambda (s)
|
|
||||||
(cons s (length s)))
|
|
||||||
strings))))
|
|
||||||
(cl-reduce (lambda (list-offset str)
|
|
||||||
(grizzl-index-insert str list-offset lookup-table
|
|
||||||
:case-sensitive case-sensitive)
|
|
||||||
(when progress-fn
|
|
||||||
(funcall progress-fn (1+ list-offset) total-strs))
|
|
||||||
(1+ list-offset))
|
|
||||||
strings
|
|
||||||
:initial-value 0)
|
|
||||||
(maphash (lambda (_char str-map)
|
|
||||||
(maphash (lambda (list-offset locations)
|
|
||||||
(puthash list-offset (reverse locations) str-map))
|
|
||||||
str-map)) lookup-table)
|
|
||||||
`((case-sensitive . ,case-sensitive)
|
|
||||||
(lookup-table . ,lookup-table)
|
|
||||||
(string-data . ,string-data))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-search (term index &optional old-result)
|
|
||||||
"Fuzzy searches for TERM in INDEX prepared with `grizzl-make-index'.
|
|
||||||
|
|
||||||
OLD-RESULT may be specified as an existing search result to increment from.
|
|
||||||
The result can be read with `grizzl-result-strings'."
|
|
||||||
(let* ((cased-term (if (grizzl-index-case-sensitive-p index)
|
|
||||||
term
|
|
||||||
(downcase term)))
|
|
||||||
(result (grizzl-rewind-result cased-term index old-result))
|
|
||||||
(matches (copy-hash-table (grizzl-result-matches result)))
|
|
||||||
(from-pos (length (grizzl-result-term result)))
|
|
||||||
(remainder (substring cased-term from-pos))
|
|
||||||
(lookup-table (grizzl-lookup-table index)))
|
|
||||||
(cl-reduce (lambda (acc-res ch)
|
|
||||||
(let ((sub-table (gethash ch lookup-table)))
|
|
||||||
(if (not sub-table)
|
|
||||||
(clrhash matches)
|
|
||||||
(grizzl-search-increment sub-table matches))
|
|
||||||
(grizzl-cons-result cased-term matches acc-res)))
|
|
||||||
remainder
|
|
||||||
:initial-value result)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-result-count (result)
|
|
||||||
"Returns the number of matches present in RESULT."
|
|
||||||
(hash-table-count (grizzl-result-matches result)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-result-strings (result index &rest options)
|
|
||||||
"Returns the ordered list of matched strings in RESULT, using INDEX.
|
|
||||||
|
|
||||||
If the :START option is specified, results are read from the given offset.
|
|
||||||
If the :END option is specified, up to :END results are returned."
|
|
||||||
(let* ((matches (grizzl-result-matches result))
|
|
||||||
(strings (grizzl-index-strings index))
|
|
||||||
(loaded '()))
|
|
||||||
(maphash (lambda (string-offset _char-offset)
|
|
||||||
(push string-offset loaded))
|
|
||||||
matches)
|
|
||||||
(let* ((ordered (sort loaded
|
|
||||||
(lambda (a b)
|
|
||||||
(< (cadr (gethash a matches))
|
|
||||||
(cadr (gethash b matches))))))
|
|
||||||
(start (or (plist-get options :start) 0))
|
|
||||||
(end (min (plist-get options :end) (length ordered)))
|
|
||||||
(best (if (or start end)
|
|
||||||
(cl-delete-if-not 'identity
|
|
||||||
(cl-subseq ordered start end))
|
|
||||||
ordered)))
|
|
||||||
(mapcar (lambda (n)
|
|
||||||
(car (elt strings n)))
|
|
||||||
best))))
|
|
||||||
|
|
||||||
;;; --- Private Functions
|
|
||||||
|
|
||||||
(defun grizzl-cons-result (term matches results)
|
|
||||||
"Build a new result for TERM and hash-table MATCHES consed with RESULTS."
|
|
||||||
(cons (cons term matches) results))
|
|
||||||
|
|
||||||
(defun grizzl-rewind-result (term index result)
|
|
||||||
"Adjusts RESULT according to TERM, ready for a new search."
|
|
||||||
(if result
|
|
||||||
(let* ((old-term (grizzl-result-term result))
|
|
||||||
(new-len (length term))
|
|
||||||
(old-len (length old-term)))
|
|
||||||
(if (and (>= new-len old-len)
|
|
||||||
(string-equal old-term (substring term 0 old-len)))
|
|
||||||
result
|
|
||||||
(grizzl-rewind-result term index (cdr result))))
|
|
||||||
(grizzl-cons-result "" (grizzl-base-matches index) nil)))
|
|
||||||
|
|
||||||
(defun grizzl-base-matches (index)
|
|
||||||
"Returns the full set of matches in INDEX, with an out-of-bound offset."
|
|
||||||
(let ((matches (make-hash-table)))
|
|
||||||
(cl-reduce (lambda (n s-len)
|
|
||||||
(puthash n (list -1 0 (cdr s-len)) matches)
|
|
||||||
(1+ n))
|
|
||||||
(grizzl-index-strings index)
|
|
||||||
:initial-value 0)
|
|
||||||
matches))
|
|
||||||
|
|
||||||
(defun grizzl-result-term (result)
|
|
||||||
"Returns the search term used to find the matches in RESULT."
|
|
||||||
(car (car result)))
|
|
||||||
|
|
||||||
(defun grizzl-result-matches (result)
|
|
||||||
"Returns the internal hash used to track the matches in RESULT."
|
|
||||||
(cdar result))
|
|
||||||
|
|
||||||
(defun grizzl-index-insert (string list-offset index &rest options)
|
|
||||||
"Inserts STRING at LIST-OFFSET into INDEX."
|
|
||||||
(let ((case-sensitive (plist-get options :case-sensitive)))
|
|
||||||
(cl-reduce (lambda (char-offset cs-char)
|
|
||||||
(let* ((char (if case-sensitive
|
|
||||||
cs-char
|
|
||||||
(downcase cs-char)))
|
|
||||||
(str-map (or (gethash char index)
|
|
||||||
(puthash char (make-hash-table) index)))
|
|
||||||
(offsets (gethash list-offset str-map)))
|
|
||||||
(puthash list-offset
|
|
||||||
(cons char-offset offsets)
|
|
||||||
str-map)
|
|
||||||
(1+ char-offset)))
|
|
||||||
string
|
|
||||||
:initial-value 0)))
|
|
||||||
|
|
||||||
(defun grizzl-lookup-table (index)
|
|
||||||
"Returns the lookup table portion of INDEX."
|
|
||||||
(cdr (assoc 'lookup-table index)))
|
|
||||||
|
|
||||||
(defun grizzl-index-strings (index)
|
|
||||||
"Returns the vector of strings stored in INDEX."
|
|
||||||
(cdr (assoc 'string-data index)))
|
|
||||||
|
|
||||||
(defun grizzl-index-case-sensitive-p (index)
|
|
||||||
"Predicate to test of INDEX is case-sensitive."
|
|
||||||
(cdr (assoc 'case-sensitive index)))
|
|
||||||
|
|
||||||
(defun grizzl-search-increment (sub-table result)
|
|
||||||
"Use the search lookup table to filter already-accumulated results."
|
|
||||||
(cl-flet ((next-offset (key current sub-table)
|
|
||||||
(cl-find-if (lambda (v)
|
|
||||||
(> v current))
|
|
||||||
(gethash key sub-table))))
|
|
||||||
(maphash (lambda (k v)
|
|
||||||
(let* ((oldpos (car v))
|
|
||||||
(oldrank (cadr v))
|
|
||||||
(len (cl-caddr v))
|
|
||||||
(newpos (next-offset k oldpos sub-table)))
|
|
||||||
(if newpos
|
|
||||||
(puthash k (list newpos
|
|
||||||
(grizzl-inc-rank oldrank oldpos newpos len)
|
|
||||||
len)
|
|
||||||
result)
|
|
||||||
(remhash k result))))
|
|
||||||
result)))
|
|
||||||
|
|
||||||
(defun grizzl-inc-rank (oldrank oldpos newpos len)
|
|
||||||
"Increment the current match distance as a new char is matched."
|
|
||||||
(let ((distance (if (< oldpos 0) 1 (- newpos oldpos))))
|
|
||||||
(+ oldrank (* len (* distance distance)))))
|
|
||||||
|
|
||||||
;;; --- Configuration Variables
|
|
||||||
|
|
||||||
(defvar *grizzl-read-max-results* 10
|
|
||||||
"The maximum number of results to show in `grizzl-completing-read'.")
|
|
||||||
|
|
||||||
;;; --- Runtime Processing Variables
|
|
||||||
|
|
||||||
(defvar *grizzl-current-result* nil
|
|
||||||
"The search result in `grizzl-completing-read'.")
|
|
||||||
|
|
||||||
(defvar *grizzl-current-selection* 0
|
|
||||||
"The selected offset in `grizzl-completing-read'.")
|
|
||||||
|
|
||||||
(defface grizzl-selection-face
|
|
||||||
`((((class color) (background light))
|
|
||||||
(:foreground "red"))
|
|
||||||
(((class color) (background dark))
|
|
||||||
(:foreground "red"))
|
|
||||||
(t (:foreground "red")))
|
|
||||||
"Face for selected result."
|
|
||||||
:group 'grizzl-mode)
|
|
||||||
|
|
||||||
(defface grizzl-prompt-face
|
|
||||||
`((t :inherit 'mode-line-inactive))
|
|
||||||
"Face used for grizzl prompt."
|
|
||||||
:group 'grizzl-mode)
|
|
||||||
|
|
||||||
;;; --- Minor Mode Definition
|
|
||||||
|
|
||||||
(defvar *grizzl-keymap* (make-sparse-keymap)
|
|
||||||
"Internal keymap used by the minor-mode in `grizzl-completing-read'.")
|
|
||||||
|
|
||||||
(define-key *grizzl-keymap* (kbd "<up>") 'grizzl-set-selection+1)
|
|
||||||
(define-key *grizzl-keymap* (kbd "C-p") 'grizzl-set-selection+1)
|
|
||||||
(define-key *grizzl-keymap* (kbd "<down>") 'grizzl-set-selection-1)
|
|
||||||
(define-key *grizzl-keymap* (kbd "C-n") 'grizzl-set-selection-1)
|
|
||||||
|
|
||||||
(define-minor-mode grizzl-mode
|
|
||||||
"Toggle the internal mode used by `grizzl-completing-read'."
|
|
||||||
nil
|
|
||||||
" Grizzl"
|
|
||||||
*grizzl-keymap*)
|
|
||||||
|
|
||||||
;;; --- Public Functions
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-completing-read (prompt index)
|
|
||||||
"Performs a completing-read in the minibuffer using INDEX to fuzzy search.
|
|
||||||
Each key pressed in the minibuffer filters down the list of matches."
|
|
||||||
(minibuffer-with-setup-hook
|
|
||||||
(lambda ()
|
|
||||||
(setq *grizzl-current-result* nil)
|
|
||||||
(setq *grizzl-current-selection* 0)
|
|
||||||
(grizzl-mode 1)
|
|
||||||
(let* ((hookfun (lambda ()
|
|
||||||
(setq *grizzl-current-result*
|
|
||||||
(grizzl-search (minibuffer-contents)
|
|
||||||
index
|
|
||||||
*grizzl-current-result*))
|
|
||||||
(grizzl-display-result index prompt)))
|
|
||||||
(exitfun (lambda ()
|
|
||||||
(grizzl-mode -1)
|
|
||||||
(remove-hook 'post-command-hook hookfun t))))
|
|
||||||
(add-hook 'minibuffer-exit-hook exitfun nil t)
|
|
||||||
(add-hook 'post-command-hook hookfun nil t)))
|
|
||||||
(let ((read-value (read-from-minibuffer ">>> ")))
|
|
||||||
(or (grizzl-selected-result index) read-value))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-selected-result (index)
|
|
||||||
"Get the selected string from INDEX in a `grizzl-completing-read'."
|
|
||||||
(elt (grizzl-result-strings *grizzl-current-result* index
|
|
||||||
:start 0
|
|
||||||
:end *grizzl-read-max-results*)
|
|
||||||
(grizzl-current-selection)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-set-selection+1 ()
|
|
||||||
"Move the selection up one row in `grizzl-completing-read'."
|
|
||||||
(interactive)
|
|
||||||
(grizzl-move-selection 1))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun grizzl-set-selection-1 ()
|
|
||||||
"Move the selection down one row in `grizzl-completing-read'."
|
|
||||||
(interactive)
|
|
||||||
(grizzl-move-selection -1))
|
|
||||||
|
|
||||||
;;; --- Private Functions
|
|
||||||
|
|
||||||
(defun grizzl-move-selection (delta)
|
|
||||||
"Move the selection by DELTA rows in `grizzl-completing-read'."
|
|
||||||
(setq *grizzl-current-selection* (+ (grizzl-current-selection) delta))
|
|
||||||
(when (not (= (grizzl-current-selection) *grizzl-current-selection*))
|
|
||||||
(beep)))
|
|
||||||
|
|
||||||
(defun grizzl-display-result (index prompt)
|
|
||||||
"Renders a series of overlays to list the matches in the result."
|
|
||||||
(let* ((matches (grizzl-result-strings *grizzl-current-result* index
|
|
||||||
:start 0
|
|
||||||
:end *grizzl-read-max-results*)))
|
|
||||||
(delete-all-overlays)
|
|
||||||
(overlay-put (make-overlay (point-min) (point-min))
|
|
||||||
'before-string
|
|
||||||
(format "%s\n%s\n"
|
|
||||||
(mapconcat 'identity
|
|
||||||
(grizzl-map-format-matches matches)
|
|
||||||
"\n")
|
|
||||||
(grizzl-format-prompt-line prompt)))
|
|
||||||
(set-window-text-height nil (max 3 (+ 2 (length matches))))))
|
|
||||||
|
|
||||||
(defun grizzl-map-format-matches (matches)
|
|
||||||
"Convert the set of string MATCHES into propertized text objects."
|
|
||||||
(if (= 0 (length matches))
|
|
||||||
(list (propertize "-- NO MATCH --" 'face 'outline-3))
|
|
||||||
(cdr (cl-reduce (lambda (acc str)
|
|
||||||
(let* ((idx (car acc))
|
|
||||||
(lst (cdr acc))
|
|
||||||
(sel (= idx (grizzl-current-selection))))
|
|
||||||
(cons (1+ idx)
|
|
||||||
(cons (grizzl-format-match str sel) lst))))
|
|
||||||
matches
|
|
||||||
:initial-value '(0)))))
|
|
||||||
|
|
||||||
(defun grizzl-format-match (match-str selected)
|
|
||||||
"Default match string formatter in `grizzl-completing-read'.
|
|
||||||
|
|
||||||
MATCH-STR is the string in the selection list and SELECTED is non-nil
|
|
||||||
if this is the current selection."
|
|
||||||
(let ((margin (if selected "> " " "))
|
|
||||||
(face (if selected 'grizzl-selection-face 'default)))
|
|
||||||
(propertize (format "%s%s" margin match-str) 'face face)))
|
|
||||||
|
|
||||||
(defun grizzl-format-prompt-line (prompt)
|
|
||||||
"Returns a string to render a full-width prompt in `grizzl-completing-read'."
|
|
||||||
(let* ((count (grizzl-result-count *grizzl-current-result*))
|
|
||||||
(match-info (format " (%d candidate%s) ---- *-"
|
|
||||||
count (if (= count 1) "" "s"))))
|
|
||||||
(concat (propertize (format "-*%s *-" prompt) 'face 'grizzl-prompt-face)
|
|
||||||
|
|
||||||
(propertize " "
|
|
||||||
'face 'grizzl-prompt-face
|
|
||||||
'display `(space :align-to (- right
|
|
||||||
,(1+ (length match-info)))))
|
|
||||||
(propertize match-info 'face 'grizzl-prompt-face))))
|
|
||||||
|
|
||||||
(defun grizzl-current-selection ()
|
|
||||||
"Get the currently selected index in `grizzl-completing-read'."
|
|
||||||
(let ((max-selection
|
|
||||||
(min (1- *grizzl-read-max-results*)
|
|
||||||
(1- (grizzl-result-count *grizzl-current-result*)))))
|
|
||||||
(max 0 (min max-selection *grizzl-current-selection*))))
|
|
||||||
|
|
||||||
(provide 'grizzl)
|
|
||||||
|
|
||||||
;;; grizzl.el ends here
|
|
||||||
@ -1,39 +0,0 @@
|
|||||||
;;; helm-make-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "helm-make" "helm-make.el" (22454 5313 194042
|
|
||||||
;;;;;; 549000))
|
|
||||||
;;; Generated autoloads from helm-make.el
|
|
||||||
|
|
||||||
(autoload 'helm-make "helm-make" "\
|
|
||||||
Call \"make -j ARG target\". Target is selected with completion.
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
(autoload 'helm-make-reset-cache "helm-make" "\
|
|
||||||
Reset cache, see `helm-make-cache-targets'.
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
(autoload 'helm-make-projectile "helm-make" "\
|
|
||||||
Call `helm-make' for `projectile-project-root'.
|
|
||||||
ARG specifies the number of cores.
|
|
||||||
|
|
||||||
By default `helm-make-projectile' will look in `projectile-project-root'
|
|
||||||
followed by `projectile-project-root'/build, for a makefile.
|
|
||||||
|
|
||||||
You can specify an additional directory to search for a makefile by
|
|
||||||
setting the buffer local variable `helm-make-build-dir'.
|
|
||||||
|
|
||||||
\(fn &optional ARG)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; helm-make-autoloads.el ends here
|
|
||||||
@ -1,2 +0,0 @@
|
|||||||
;;; -*- no-byte-compile: t -*-
|
|
||||||
(define-package "helm-make" "20160807.1756" "Select a Makefile target with helm" '((helm "1.5.3") (projectile "0.11.0")) :url "https://github.com/abo-abo/helm-make" :keywords '("makefile"))
|
|
||||||
@ -1,315 +0,0 @@
|
|||||||
;;; helm-make.el --- Select a Makefile target with helm
|
|
||||||
|
|
||||||
;; Copyright (C) 2014 Oleh Krehel
|
|
||||||
|
|
||||||
;; Author: Oleh Krehel <ohwoeowho@gmail.com>
|
|
||||||
;; URL: https://github.com/abo-abo/helm-make
|
|
||||||
;; Package-Version: 20160807.1756
|
|
||||||
;; Version: 0.2.0
|
|
||||||
;; Package-Requires: ((helm "1.5.3") (projectile "0.11.0"))
|
|
||||||
;; Keywords: makefile
|
|
||||||
|
|
||||||
;; This file is not part of GNU Emacs
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 3, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This 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.
|
|
||||||
|
|
||||||
;; For a full copy of the GNU General Public License
|
|
||||||
;; see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; A call to `helm-make' will give you a `helm' selection of this directory
|
|
||||||
;; Makefile's targets. Selecting a target will call `compile' on it.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'helm)
|
|
||||||
(require 'helm-multi-match)
|
|
||||||
|
|
||||||
(declare-function ivy-read "ext:ivy")
|
|
||||||
|
|
||||||
(defgroup helm-make nil
|
|
||||||
"Select a Makefile target with helm."
|
|
||||||
:group 'convenience)
|
|
||||||
|
|
||||||
(defcustom helm-make-do-save nil
|
|
||||||
"If t, save all open buffers visiting files from Makefile's directory."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'helm-make)
|
|
||||||
|
|
||||||
(defcustom helm-make-build-dir ""
|
|
||||||
"Specify a build directory for an out of source build.
|
|
||||||
The path should be relative to the project root.
|
|
||||||
|
|
||||||
When non-nil `helm-make-projectile' will first look in that directory for a
|
|
||||||
makefile."
|
|
||||||
:type '(string)
|
|
||||||
:group 'helm-make)
|
|
||||||
(make-variable-buffer-local 'helm-make-build-dir)
|
|
||||||
|
|
||||||
(defcustom helm-make-sort-targets nil
|
|
||||||
"Whether targets shall be sorted.
|
|
||||||
If t, targets will be sorted as a final step before calling the
|
|
||||||
completion method.
|
|
||||||
|
|
||||||
HINT: If you are facing performance problems set this to nil.
|
|
||||||
This might be the case, if there are thousand of targets."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'helm-make)
|
|
||||||
|
|
||||||
(defcustom helm-make-cache-targets nil
|
|
||||||
"Whether to cache the targets or not.
|
|
||||||
|
|
||||||
If t, cache targets of Makefile. If `helm-make' or `helm-make-projectile'
|
|
||||||
gets called for the same Makefile again, and the Makefile hasn't changed
|
|
||||||
meanwhile, i.e. the modification time is `equal' to the cached one, reuse
|
|
||||||
the cached targets, instead of recomputing them. If nil do nothing.
|
|
||||||
|
|
||||||
You can reset the cache by calling `helm-make-reset-db'."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'helm-make)
|
|
||||||
|
|
||||||
(defcustom helm-make-executable "make"
|
|
||||||
"Store the name of make executable."
|
|
||||||
:type 'string
|
|
||||||
:group 'helm-make)
|
|
||||||
|
|
||||||
(defcustom helm-make-require-match t
|
|
||||||
"When non-nil, don't allow selecting a target that's not on the list."
|
|
||||||
:type 'boolean)
|
|
||||||
|
|
||||||
(defcustom helm-make-named-buffer nil
|
|
||||||
"When non-nil, name compilation buffer based on make target."
|
|
||||||
:type 'boolean)
|
|
||||||
|
|
||||||
(defcustom helm-make-comint nil
|
|
||||||
"When non-nil, run helm-make in Comint mode instead of Compilation mode."
|
|
||||||
:type 'boolean)
|
|
||||||
|
|
||||||
(defvar helm-make-command nil
|
|
||||||
"Store the make command.")
|
|
||||||
|
|
||||||
(defvar helm-make-target-history nil
|
|
||||||
"Holds the recently used targets.")
|
|
||||||
|
|
||||||
(defvar helm-make-makefile-names '("Makefile" "makefile" "GNUmakefile")
|
|
||||||
"List of Makefile names which make recognizes.
|
|
||||||
An exception is \"GNUmakefile\", only GNU make unterstand it.")
|
|
||||||
|
|
||||||
(defun helm--make-action (target)
|
|
||||||
"Make TARGET."
|
|
||||||
(let* ((make-command (format helm-make-command target))
|
|
||||||
(compile-buffer (compile make-command helm-make-comint)))
|
|
||||||
(when helm-make-named-buffer
|
|
||||||
(helm--make-rename-buffer compile-buffer target))))
|
|
||||||
|
|
||||||
(defun helm--make-rename-buffer (buffer target)
|
|
||||||
"Rename the compilation BUFFER based on the make TARGET."
|
|
||||||
(let ((buffer-name (format "*compilation (%s)*" target)))
|
|
||||||
(when (get-buffer-window buffer-name)
|
|
||||||
(delete-window (get-buffer-window buffer-name)))
|
|
||||||
(when (get-buffer buffer-name)
|
|
||||||
(kill-buffer buffer-name))
|
|
||||||
(with-current-buffer buffer
|
|
||||||
(rename-buffer buffer-name))))
|
|
||||||
|
|
||||||
(defcustom helm-make-completion-method 'helm
|
|
||||||
"Method to select a candidate from a list of strings."
|
|
||||||
:type '(choice
|
|
||||||
(const :tag "Helm" helm)
|
|
||||||
(const :tag "Ido" ido)
|
|
||||||
(const :tag "Ivy" ivy)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun helm-make (&optional arg)
|
|
||||||
"Call \"make -j ARG target\". Target is selected with completion."
|
|
||||||
(interactive "p")
|
|
||||||
(setq helm-make-command (format "%s -j%d %%s" helm-make-executable arg))
|
|
||||||
(let ((makefile (helm--make-makefile-exists default-directory)))
|
|
||||||
(if makefile
|
|
||||||
(helm--make makefile)
|
|
||||||
(error "No Makefile in %s" default-directory))))
|
|
||||||
|
|
||||||
(defun helm--make-target-list-qp (makefile)
|
|
||||||
"Return the target list for MAKEFILE by parsing the output of \"make -nqp\"."
|
|
||||||
(let ((default-directory (file-name-directory
|
|
||||||
(expand-file-name makefile)))
|
|
||||||
targets target)
|
|
||||||
(with-temp-buffer
|
|
||||||
(insert
|
|
||||||
(shell-command-to-string
|
|
||||||
"make -nqp __BASH_MAKE_COMPLETION__=1 .DEFAULT 2>/dev/null"))
|
|
||||||
(goto-char (point-min))
|
|
||||||
(unless (re-search-forward "^# Files" nil t)
|
|
||||||
(error "Unexpected \"make -nqp\" output"))
|
|
||||||
(while (re-search-forward "^\\([^%$:#\n\t ]+\\):\\([^=]\\|$\\)" nil t)
|
|
||||||
(setq target (match-string 1))
|
|
||||||
(unless (or (save-excursion
|
|
||||||
(goto-char (match-beginning 0))
|
|
||||||
(forward-line -1)
|
|
||||||
(looking-at "^# Not a target:"))
|
|
||||||
(string-match "^\\([/a-zA-Z0-9_. -]+/\\)?\\." target))
|
|
||||||
(push target targets))))
|
|
||||||
targets))
|
|
||||||
|
|
||||||
(defun helm--make-target-list-default (makefile)
|
|
||||||
"Return the target list for MAKEFILE by parsing it."
|
|
||||||
(let (targets)
|
|
||||||
(with-temp-buffer
|
|
||||||
(insert-file-contents makefile)
|
|
||||||
(goto-char (point-min))
|
|
||||||
(while (re-search-forward "^\\([^: \n]+\\):" nil t)
|
|
||||||
(let ((str (match-string 1)))
|
|
||||||
(unless (string-match "^\\." str)
|
|
||||||
(push str targets)))))
|
|
||||||
targets))
|
|
||||||
|
|
||||||
(defcustom helm-make-list-target-method 'default
|
|
||||||
"Method of obtaining the list of Makefile targets."
|
|
||||||
:type '(choice
|
|
||||||
(const :tag "Default" default)
|
|
||||||
(const :tag "make -qp" qp)))
|
|
||||||
|
|
||||||
(defun helm--make-makefile-exists (base-dir &optional dir-list)
|
|
||||||
"Check if one of `helm-make-makefile-names' exist in BASE-DIR.
|
|
||||||
|
|
||||||
Returns the absolute filename to the Makefile, if one exists,
|
|
||||||
otherwise nil.
|
|
||||||
|
|
||||||
If DIR-LIST is non-nil, also search for `helm-make-makefile-names'."
|
|
||||||
(let* ((default-directory (file-truename base-dir))
|
|
||||||
(makefiles
|
|
||||||
(progn
|
|
||||||
(unless (and dir-list (listp dir-list))
|
|
||||||
(setq dir-list (list "")))
|
|
||||||
(let (result)
|
|
||||||
(dolist (dir dir-list)
|
|
||||||
(dolist (makefile helm-make-makefile-names)
|
|
||||||
(push (expand-file-name makefile dir) result)))
|
|
||||||
(reverse result)))))
|
|
||||||
(cl-find-if 'file-exists-p makefiles)))
|
|
||||||
|
|
||||||
(defvar helm-make-db (make-hash-table :test 'equal)
|
|
||||||
"An alist of Makefile and corresponding targets.")
|
|
||||||
|
|
||||||
(cl-defstruct helm-make-dbfile
|
|
||||||
targets
|
|
||||||
modtime
|
|
||||||
sorted)
|
|
||||||
|
|
||||||
(defun helm--make-cached-targets (makefile)
|
|
||||||
"Return cached targets of MAKEFILE.
|
|
||||||
|
|
||||||
If there are no cached targets for MAKEFILE, the MAKEFILE modification
|
|
||||||
time has changed, or `helm-make-cache-targets' is nil, parse the MAKEFILE,
|
|
||||||
and cache targets of MAKEFILE, if `helm-make-cache-targets' is t."
|
|
||||||
(let* ((att (file-attributes makefile 'integer))
|
|
||||||
(modtime (if att (nth 5 att) nil))
|
|
||||||
(entry (gethash makefile helm-make-db nil))
|
|
||||||
(new-entry (make-helm-make-dbfile))
|
|
||||||
(targets (cond
|
|
||||||
((and helm-make-cache-targets
|
|
||||||
entry
|
|
||||||
(equal modtime (helm-make-dbfile-modtime entry))
|
|
||||||
(helm-make-dbfile-targets entry))
|
|
||||||
(helm-make-dbfile-targets entry))
|
|
||||||
(t
|
|
||||||
(delete-dups (if (eq helm-make-list-target-method 'default)
|
|
||||||
(helm--make-target-list-default makefile)
|
|
||||||
(helm--make-target-list-qp makefile)))))))
|
|
||||||
(when helm-make-sort-targets
|
|
||||||
(unless (and helm-make-cache-targets
|
|
||||||
entry
|
|
||||||
(helm-make-dbfile-sorted entry))
|
|
||||||
(setq targets (sort targets 'string<)))
|
|
||||||
(setf (helm-make-dbfile-sorted new-entry) t))
|
|
||||||
|
|
||||||
(when helm-make-cache-targets
|
|
||||||
(setf (helm-make-dbfile-targets new-entry) targets
|
|
||||||
(helm-make-dbfile-modtime new-entry) modtime)
|
|
||||||
(puthash makefile new-entry helm-make-db))
|
|
||||||
targets))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun helm-make-reset-cache ()
|
|
||||||
"Reset cache, see `helm-make-cache-targets'."
|
|
||||||
(interactive)
|
|
||||||
(clrhash helm-make-db))
|
|
||||||
|
|
||||||
(defun helm--make (makefile)
|
|
||||||
"Call make for MAKEFILE."
|
|
||||||
(when helm-make-do-save
|
|
||||||
(let* ((regex (format "^%s" default-directory))
|
|
||||||
(buffers
|
|
||||||
(cl-remove-if-not
|
|
||||||
(lambda (b)
|
|
||||||
(let ((name (buffer-file-name b)))
|
|
||||||
(and name
|
|
||||||
(string-match regex (expand-file-name name)))))
|
|
||||||
(buffer-list))))
|
|
||||||
(mapc
|
|
||||||
(lambda (b)
|
|
||||||
(with-current-buffer b
|
|
||||||
(save-buffer)))
|
|
||||||
buffers)))
|
|
||||||
(let ((targets (helm--make-cached-targets makefile))
|
|
||||||
(default-directory (file-name-directory makefile)))
|
|
||||||
(delete-dups helm-make-target-history)
|
|
||||||
(cl-case helm-make-completion-method
|
|
||||||
(helm
|
|
||||||
(helm :sources
|
|
||||||
`((name . "Targets")
|
|
||||||
(candidates . ,targets)
|
|
||||||
(action . helm--make-action))
|
|
||||||
:history 'helm-make-target-history
|
|
||||||
:preselect (when helm-make-target-history
|
|
||||||
(format "^%s$" (car helm-make-target-history)))))
|
|
||||||
(ivy
|
|
||||||
(ivy-read "Target: "
|
|
||||||
targets
|
|
||||||
:history 'helm-make-target-history
|
|
||||||
:preselect (car helm-make-target-history)
|
|
||||||
:action 'helm--make-action
|
|
||||||
:require-match helm-make-require-match))
|
|
||||||
(ido
|
|
||||||
(let ((target (ido-completing-read
|
|
||||||
"Target: " targets
|
|
||||||
nil nil nil
|
|
||||||
'helm-make-target-history)))
|
|
||||||
(when target
|
|
||||||
(helm--make-action target)))))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun helm-make-projectile (&optional arg)
|
|
||||||
"Call `helm-make' for `projectile-project-root'.
|
|
||||||
ARG specifies the number of cores.
|
|
||||||
|
|
||||||
By default `helm-make-projectile' will look in `projectile-project-root'
|
|
||||||
followed by `projectile-project-root'/build, for a makefile.
|
|
||||||
|
|
||||||
You can specify an additional directory to search for a makefile by
|
|
||||||
setting the buffer local variable `helm-make-build-dir'."
|
|
||||||
(interactive "p")
|
|
||||||
(require 'projectile)
|
|
||||||
(setq helm-make-command (format "%s -j%d %%s" helm-make-executable arg))
|
|
||||||
(let ((makefile (helm--make-makefile-exists
|
|
||||||
(projectile-project-root)
|
|
||||||
(if (and (stringp helm-make-build-dir)
|
|
||||||
(not (string-match-p "\\`[ \t\n\r]*\\'" helm-make-build-dir)))
|
|
||||||
`(,helm-make-build-dir "" "build")
|
|
||||||
`(,@helm-make-build-dir "" "build")))))
|
|
||||||
(if makefile
|
|
||||||
(helm--make makefile)
|
|
||||||
(error "No Makefile found for project %s" (projectile-project-root)))))
|
|
||||||
|
|
||||||
(provide 'helm-make)
|
|
||||||
|
|
||||||
;;; helm-make.el ends here
|
|
||||||
@ -1,15 +0,0 @@
|
|||||||
;;; ht-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("ht.el") (22490 24933 409230 911000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; ht-autoloads.el ends here
|
|
||||||
@ -1 +0,0 @@
|
|||||||
(define-package "ht" "20160911.1900" "The missing hash table library for Emacs" '((dash "2.12.0")) :keywords '("hash table" "hash map" "hash"))
|
|
||||||
@ -1,280 +0,0 @@
|
|||||||
;;; ht.el --- The missing hash table library for Emacs
|
|
||||||
|
|
||||||
;; Copyright (C) 2013 Wilfred Hughes
|
|
||||||
|
|
||||||
;; Author: Wilfred Hughes <me@wilfred.me.uk>
|
|
||||||
;; Version: 2.2
|
|
||||||
;; Package-Version: 20160911.1900
|
|
||||||
;; Keywords: hash table, hash map, hash
|
|
||||||
;; Package-Requires: ((dash "2.12.0"))
|
|
||||||
|
|
||||||
;; 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:
|
|
||||||
|
|
||||||
;; The missing hash table library for Emacs.
|
|
||||||
;;
|
|
||||||
;; See documentation at https://github.com/Wilfred/ht.el
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'dash)
|
|
||||||
|
|
||||||
(defmacro ht (&rest pairs)
|
|
||||||
"Create a hash table with the key-value pairs given.
|
|
||||||
Keys are compared with `equal'.
|
|
||||||
|
|
||||||
\(fn (KEY-1 VALUE-1) (KEY-2 VALUE-2) ...)"
|
|
||||||
(let* ((table-symbol (make-symbol "ht-temp"))
|
|
||||||
(assignments
|
|
||||||
(mapcar
|
|
||||||
(lambda (pair) `(ht-set! ,table-symbol ,@pair))
|
|
||||||
pairs)))
|
|
||||||
`(let ((,table-symbol (ht-create)))
|
|
||||||
,@assignments
|
|
||||||
,table-symbol)))
|
|
||||||
|
|
||||||
(defun ht-create (&optional test)
|
|
||||||
"Create an empty hash table.
|
|
||||||
|
|
||||||
TEST indicates the function used to compare the hash
|
|
||||||
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
|
|
||||||
user-supplied test created via `define-hash-table-test'."
|
|
||||||
(make-hash-table :test (or test 'equal)))
|
|
||||||
|
|
||||||
(defun ht<-alist (alist &optional test)
|
|
||||||
"Create a hash table with initial values according to ALIST.
|
|
||||||
|
|
||||||
TEST indicates the function used to compare the hash
|
|
||||||
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
|
|
||||||
user-supplied test created via `define-hash-table-test'."
|
|
||||||
(let ((h (ht-create test)))
|
|
||||||
;; the first key-value pair in an alist gets precedence, so we
|
|
||||||
;; start from the end of the list:
|
|
||||||
(dolist (pair (reverse alist) h)
|
|
||||||
(let ((key (car pair))
|
|
||||||
(value (cdr pair)))
|
|
||||||
(ht-set! h key value)))))
|
|
||||||
|
|
||||||
(defalias 'ht-from-alist 'ht<-alist)
|
|
||||||
|
|
||||||
(defun ht<-plist (plist &optional test)
|
|
||||||
"Create a hash table with initial values according to PLIST.
|
|
||||||
|
|
||||||
TEST indicates the function used to compare the hash
|
|
||||||
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
|
|
||||||
user-supplied test created via `define-hash-table-test'."
|
|
||||||
(let ((h (ht-create test)))
|
|
||||||
(dolist (pair (-partition 2 plist) h)
|
|
||||||
(let ((key (car pair))
|
|
||||||
(value (cadr pair)))
|
|
||||||
(ht-set! h key value)))))
|
|
||||||
|
|
||||||
(defalias 'ht-from-plist 'ht<-plist)
|
|
||||||
|
|
||||||
(defun ht-get (table key &optional default)
|
|
||||||
"Look up KEY in TABLE, and return the matching value.
|
|
||||||
If KEY isn't present, return DEFAULT (nil if not specified)."
|
|
||||||
(gethash key table default))
|
|
||||||
|
|
||||||
(defun ht-set! (table key value)
|
|
||||||
"Associate KEY in TABLE with VALUE."
|
|
||||||
(puthash key value table)
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defalias 'ht-set 'ht-set!)
|
|
||||||
|
|
||||||
(defun ht-update! (table from-table)
|
|
||||||
"Update TABLE according to every key-value pair in FROM-TABLE."
|
|
||||||
(maphash
|
|
||||||
(lambda (key value) (puthash key value table))
|
|
||||||
from-table)
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defalias 'ht-update 'ht-update!)
|
|
||||||
|
|
||||||
(defun ht-merge (&rest tables)
|
|
||||||
"Crete a new tables that includes all the key-value pairs from TABLES.
|
|
||||||
If multiple have tables have the same key, the value in the last
|
|
||||||
table is used."
|
|
||||||
(let ((merged (ht-create)))
|
|
||||||
(mapc (lambda (table) (ht-update! merged table)) tables)
|
|
||||||
merged))
|
|
||||||
|
|
||||||
(defun ht-remove! (table key)
|
|
||||||
"Remove KEY from TABLE."
|
|
||||||
(remhash key table))
|
|
||||||
|
|
||||||
(defalias 'ht-remove 'ht-remove!)
|
|
||||||
|
|
||||||
(defun ht-clear! (table)
|
|
||||||
"Remove all keys from TABLE."
|
|
||||||
(clrhash table)
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defalias 'ht-clear 'ht-clear!)
|
|
||||||
|
|
||||||
(defun ht-map (function table)
|
|
||||||
"Apply FUNCTION to each key-value pair of TABLE, and make a list of the results.
|
|
||||||
FUNCTION is called with two arguments, KEY and VALUE."
|
|
||||||
(let (results)
|
|
||||||
(maphash
|
|
||||||
(lambda (key value)
|
|
||||||
(push (funcall function key value) results))
|
|
||||||
table)
|
|
||||||
results))
|
|
||||||
|
|
||||||
(defmacro ht-amap (form table)
|
|
||||||
"Anaphoric version of `ht-map'.
|
|
||||||
For every key-value pair in TABLE, evaluate FORM with the
|
|
||||||
variables KEY and VALUE bound."
|
|
||||||
`(ht-map (lambda (key value) ,form) ,table))
|
|
||||||
|
|
||||||
(defun ht-keys (table)
|
|
||||||
"Return a list of all the keys in TABLE."
|
|
||||||
(ht-amap key table))
|
|
||||||
|
|
||||||
(defun ht-values (table)
|
|
||||||
"Return a list of all the values in TABLE."
|
|
||||||
(ht-amap value table))
|
|
||||||
|
|
||||||
(defun ht-items (table)
|
|
||||||
"Return a list of two-element lists '(key value) from TABLE."
|
|
||||||
(ht-amap (list key value) table))
|
|
||||||
|
|
||||||
(defalias 'ht-each 'maphash
|
|
||||||
"Apply FUNCTION to each key-value pair of TABLE.
|
|
||||||
Returns nil, used for side-effects only.")
|
|
||||||
|
|
||||||
(defmacro ht-aeach (form table)
|
|
||||||
"Anaphoric version of `ht-each'.
|
|
||||||
For every key-value pair in TABLE, evaluate FORM with the
|
|
||||||
variables key and value bound."
|
|
||||||
`(ht-each (lambda (key value) ,form) ,table))
|
|
||||||
|
|
||||||
(defun ht->plist (table)
|
|
||||||
"Return a flat list '(key1 value1 key2 value2...) from TABLE.
|
|
||||||
|
|
||||||
Note that hash tables are unordered, so this cannot be an exact
|
|
||||||
inverse of `ht<-plist'. The following is not guaranteed:
|
|
||||||
|
|
||||||
\(let ((data '(a b c d)))
|
|
||||||
(equalp data
|
|
||||||
(ht->plist (ht<-plist data))))"
|
|
||||||
(apply 'append (ht-items table)))
|
|
||||||
|
|
||||||
(defalias 'ht-to-plist 'ht->plist)
|
|
||||||
|
|
||||||
(defun ht-copy (table)
|
|
||||||
"Return a shallow copy of TABLE (keys and values are shared)."
|
|
||||||
(copy-hash-table table))
|
|
||||||
|
|
||||||
(defun ht->alist (table)
|
|
||||||
"Return a list of two-element lists '(key . value) from TABLE.
|
|
||||||
|
|
||||||
Note that hash tables are unordered, so this cannot be an exact
|
|
||||||
inverse of `ht<-alist'. The following is not guaranteed:
|
|
||||||
|
|
||||||
\(let ((data '((a . b) (c . d))))
|
|
||||||
(equalp data
|
|
||||||
(ht->alist (ht<-alist data))))"
|
|
||||||
(ht-amap (cons key value) table))
|
|
||||||
|
|
||||||
(defalias 'ht-to-alist 'ht->alist)
|
|
||||||
|
|
||||||
(defalias 'ht? 'hash-table-p)
|
|
||||||
|
|
||||||
(defalias 'ht-p 'hash-table-p)
|
|
||||||
|
|
||||||
(defun ht-contains? (table key)
|
|
||||||
"Return 't if TABLE contains KEY."
|
|
||||||
(not (eq (ht-get table key 'ht--not-found) 'ht--not-found)))
|
|
||||||
|
|
||||||
(defalias 'ht-contains-p 'ht-contains?)
|
|
||||||
|
|
||||||
(defun ht-size (table)
|
|
||||||
"Return the actual number of entries in TABLE."
|
|
||||||
(hash-table-count table))
|
|
||||||
|
|
||||||
(defun ht-empty? (table)
|
|
||||||
"Return true if the actual number of entries in TABLE is zero."
|
|
||||||
(zerop (ht-size table)))
|
|
||||||
|
|
||||||
(defun ht-select (function table)
|
|
||||||
"Return a hash table containing all entries in TABLE for which
|
|
||||||
FUNCTION returns a truthy value.
|
|
||||||
|
|
||||||
FUNCTION is called with two arguments, KEY and VALUE."
|
|
||||||
(let ((results (ht-create)))
|
|
||||||
(ht-each
|
|
||||||
(lambda (key value)
|
|
||||||
(when (funcall function key value)
|
|
||||||
(ht-set! results key value)))
|
|
||||||
table)
|
|
||||||
results))
|
|
||||||
|
|
||||||
(defun ht-reject (function table)
|
|
||||||
"Return a hash table containing all entries in TABLE for which
|
|
||||||
FUNCTION returns a falsy value.
|
|
||||||
|
|
||||||
FUNCTION is called with two arguments, KEY and VALUE."
|
|
||||||
(let ((results (ht-create)))
|
|
||||||
(ht-each
|
|
||||||
(lambda (key value)
|
|
||||||
(unless (funcall function key value)
|
|
||||||
(ht-set! results key value)))
|
|
||||||
table)
|
|
||||||
results))
|
|
||||||
|
|
||||||
(defun ht-reject! (function table)
|
|
||||||
"Delete entries from TABLE for which FUNCTION returns a falsy value.
|
|
||||||
|
|
||||||
FUNCTION is called with two arguments, KEY and VALUE."
|
|
||||||
(ht-each
|
|
||||||
(lambda (key value)
|
|
||||||
(when (funcall function key value)
|
|
||||||
(remhash key table)))
|
|
||||||
table)
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defalias 'ht-delete-if 'ht-reject!)
|
|
||||||
|
|
||||||
(defun ht-find (function table)
|
|
||||||
"Return (key, value) from TABLE for which FUNCTION returns a truthy value.
|
|
||||||
Return nil otherwise.
|
|
||||||
|
|
||||||
FUNCTION is called with two arguments, KEY and VALUE."
|
|
||||||
(catch 'break
|
|
||||||
(ht-each
|
|
||||||
(lambda (key value)
|
|
||||||
(when (funcall function key value)
|
|
||||||
(throw 'break (list key value))))
|
|
||||||
table)))
|
|
||||||
|
|
||||||
(defun ht-equal? (table1 table2)
|
|
||||||
"Return t if TABLE1 and TABLE2 have the same keys and values.
|
|
||||||
Does not compare equality predicates."
|
|
||||||
(let ((keys1 (ht-keys table1))
|
|
||||||
(keys2 (ht-keys table2))
|
|
||||||
(sentinel (make-symbol "ht-sentinel")))
|
|
||||||
(and (equal (length keys1) (length keys2))
|
|
||||||
(--all?
|
|
||||||
(equal (ht-get table1 it)
|
|
||||||
(ht-get table2 it sentinel))
|
|
||||||
keys1))))
|
|
||||||
|
|
||||||
(defalias 'ht-equal-p 'ht-equal?)
|
|
||||||
|
|
||||||
(provide 'ht)
|
|
||||||
;;; ht.el ends here
|
|
||||||
@ -1,75 +0,0 @@
|
|||||||
;;; hydra-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "hydra" "hydra.el" (22501 5659 447421 78000))
|
|
||||||
;;; Generated autoloads from hydra.el
|
|
||||||
|
|
||||||
(autoload 'defhydra "hydra" "\
|
|
||||||
Create a Hydra - a family of functions with prefix NAME.
|
|
||||||
|
|
||||||
NAME should be a symbol, it will be the prefix of all functions
|
|
||||||
defined here.
|
|
||||||
|
|
||||||
BODY has the format:
|
|
||||||
|
|
||||||
(BODY-MAP BODY-KEY &rest BODY-PLIST)
|
|
||||||
|
|
||||||
DOCSTRING will be displayed in the echo area to identify the
|
|
||||||
Hydra. When DOCSTRING starts with a newline, special Ruby-style
|
|
||||||
substitution will be performed by `hydra--format'.
|
|
||||||
|
|
||||||
Functions are created on basis of HEADS, each of which has the
|
|
||||||
format:
|
|
||||||
|
|
||||||
(KEY CMD &optional HINT &rest PLIST)
|
|
||||||
|
|
||||||
BODY-MAP is a keymap; `global-map' is used quite often. Each
|
|
||||||
function generated from HEADS will be bound in BODY-MAP to
|
|
||||||
BODY-KEY + KEY (both are strings passed to `kbd'), and will set
|
|
||||||
the transient map so that all following heads can be called
|
|
||||||
though KEY only. BODY-KEY can be an empty string.
|
|
||||||
|
|
||||||
CMD is a callable expression: either an interactive function
|
|
||||||
name, or an interactive lambda, or a single sexp (it will be
|
|
||||||
wrapped in an interactive lambda).
|
|
||||||
|
|
||||||
HINT is a short string that identifies its head. It will be
|
|
||||||
printed beside KEY in the echo erea if `hydra-is-helpful' is not
|
|
||||||
nil. If you don't even want the KEY to be printed, set HINT
|
|
||||||
explicitly to nil.
|
|
||||||
|
|
||||||
The heads inherit their PLIST from BODY-PLIST and are allowed to
|
|
||||||
override some keys. The keys recognized are :exit and :bind.
|
|
||||||
:exit can be:
|
|
||||||
|
|
||||||
- nil (default): this head will continue the Hydra state.
|
|
||||||
- t: this head will stop the Hydra state.
|
|
||||||
|
|
||||||
:bind can be:
|
|
||||||
- nil: this head will not be bound in BODY-MAP.
|
|
||||||
- a lambda taking KEY and CMD used to bind a head.
|
|
||||||
|
|
||||||
It is possible to omit both BODY-MAP and BODY-KEY if you don't
|
|
||||||
want to bind anything. In that case, typically you will bind the
|
|
||||||
generated NAME/body command. This command is also the return
|
|
||||||
result of `defhydra'.
|
|
||||||
|
|
||||||
\(fn NAME BODY &optional DOCSTRING &rest HEADS)" nil t)
|
|
||||||
|
|
||||||
(put 'defhydra 'lisp-indent-function 'defun)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("hydra-examples.el" "hydra-ox.el" "hydra-pkg.el"
|
|
||||||
;;;;;; "lv.el") (22501 5659 473131 612000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; hydra-autoloads.el ends here
|
|
||||||
@ -1,386 +0,0 @@
|
|||||||
;;; hydra-examples.el --- Some applications for Hydra
|
|
||||||
|
|
||||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: Oleh Krehel
|
|
||||||
|
|
||||||
;; This file is part of GNU Emacs.
|
|
||||||
|
|
||||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation, either version 3 of the License, or
|
|
||||||
;; (at your option) any later version.
|
|
||||||
|
|
||||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; 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, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; These are the sample Hydras.
|
|
||||||
;;
|
|
||||||
;; If you want to use them plainly, set `hydra-examples-verbatim' to t
|
|
||||||
;; before requiring this file. But it's probably better to only look
|
|
||||||
;; at them and use them as templates for building your own.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'hydra)
|
|
||||||
|
|
||||||
;;* Examples
|
|
||||||
;;** Example 1: text scale
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(defhydra hydra-zoom (global-map "<f2>")
|
|
||||||
"zoom"
|
|
||||||
("g" text-scale-increase "in")
|
|
||||||
("l" text-scale-decrease "out")))
|
|
||||||
|
|
||||||
;; This example generates three commands:
|
|
||||||
;;
|
|
||||||
;; `hydra-zoom/text-scale-increase'
|
|
||||||
;; `hydra-zoom/text-scale-decrease'
|
|
||||||
;; `hydra-zoom/body'
|
|
||||||
;;
|
|
||||||
;; In addition, two of them are bound like this:
|
|
||||||
;;
|
|
||||||
;; (global-set-key (kbd "<f2> g") 'hydra-zoom/text-scale-increase)
|
|
||||||
;; (global-set-key (kbd "<f2> l") 'hydra-zoom/text-scale-decrease)
|
|
||||||
;;
|
|
||||||
;; Note that you can substitute `global-map' with e.g. `emacs-lisp-mode-map' if you need.
|
|
||||||
;; The functions generated will be the same, except the binding code will change to:
|
|
||||||
;;
|
|
||||||
;; (define-key emacs-lisp-mode-map [f2 103]
|
|
||||||
;; (function hydra-zoom/text-scale-increase))
|
|
||||||
;; (define-key emacs-lisp-mode-map [f2 108]
|
|
||||||
;; (function hydra-zoom/text-scale-decrease))
|
|
||||||
|
|
||||||
;;** Example 2: move window splitter
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(defhydra hydra-splitter (global-map "C-M-s")
|
|
||||||
"splitter"
|
|
||||||
("h" hydra-move-splitter-left)
|
|
||||||
("j" hydra-move-splitter-down)
|
|
||||||
("k" hydra-move-splitter-up)
|
|
||||||
("l" hydra-move-splitter-right)))
|
|
||||||
|
|
||||||
;;** Example 3: jump to error
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(defhydra hydra-error (global-map "M-g")
|
|
||||||
"goto-error"
|
|
||||||
("h" first-error "first")
|
|
||||||
("j" next-error "next")
|
|
||||||
("k" previous-error "prev")
|
|
||||||
("v" recenter-top-bottom "recenter")
|
|
||||||
("q" nil "quit")))
|
|
||||||
|
|
||||||
;; This example introduces only one new thing: since the command
|
|
||||||
;; passed to the "q" head is nil, it will quit the Hydra without doing
|
|
||||||
;; anything. Heads that quit the Hydra instead of continuing are
|
|
||||||
;; referred to as having blue :color. All the other heads have red
|
|
||||||
;; :color, unless other is specified.
|
|
||||||
|
|
||||||
;;** Example 4: toggle rarely used modes
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(defvar whitespace-mode nil)
|
|
||||||
(global-set-key
|
|
||||||
(kbd "C-c C-v")
|
|
||||||
(defhydra hydra-toggle-simple (:color blue)
|
|
||||||
"toggle"
|
|
||||||
("a" abbrev-mode "abbrev")
|
|
||||||
("d" toggle-debug-on-error "debug")
|
|
||||||
("f" auto-fill-mode "fill")
|
|
||||||
("t" toggle-truncate-lines "truncate")
|
|
||||||
("w" whitespace-mode "whitespace")
|
|
||||||
("q" nil "cancel"))))
|
|
||||||
|
|
||||||
;; Note that in this case, `defhydra' returns the `hydra-toggle-simple/body'
|
|
||||||
;; symbol, which is then passed to `global-set-key'.
|
|
||||||
;;
|
|
||||||
;; Another new thing is that both the keymap and the body prefix are
|
|
||||||
;; skipped. This means that `defhydra' will bind nothing - that's why
|
|
||||||
;; `global-set-key' is necessary.
|
|
||||||
;;
|
|
||||||
;; One more new thing is that you can assign a :color to the body. All
|
|
||||||
;; heads will inherit this color. The code above is very much equivalent to:
|
|
||||||
;;
|
|
||||||
;; (global-set-key (kbd "C-c C-v a") 'abbrev-mode)
|
|
||||||
;; (global-set-key (kbd "C-c C-v d") 'toggle-debug-on-error)
|
|
||||||
;;
|
|
||||||
;; The differences are:
|
|
||||||
;;
|
|
||||||
;; * You get a hint immediately after "C-c C-v"
|
|
||||||
;; * You can cancel and call a command immediately, e.g. "C-c C-v C-n"
|
|
||||||
;; is equivalent to "C-n" with Hydra approach, while it will error
|
|
||||||
;; that "C-c C-v C-n" isn't bound with the usual approach.
|
|
||||||
|
|
||||||
;;** Example 5: mini-vi
|
|
||||||
(defun hydra-vi/pre ()
|
|
||||||
(set-cursor-color "#e52b50"))
|
|
||||||
|
|
||||||
(defun hydra-vi/post ()
|
|
||||||
(set-cursor-color "#ffffff"))
|
|
||||||
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(global-set-key
|
|
||||||
(kbd "C-z")
|
|
||||||
(defhydra hydra-vi (:pre hydra-vi/pre :post hydra-vi/post :color amaranth)
|
|
||||||
"vi"
|
|
||||||
("l" forward-char)
|
|
||||||
("h" backward-char)
|
|
||||||
("j" next-line)
|
|
||||||
("k" previous-line)
|
|
||||||
("m" set-mark-command "mark")
|
|
||||||
("a" move-beginning-of-line "beg")
|
|
||||||
("e" move-end-of-line "end")
|
|
||||||
("d" delete-region "del" :color blue)
|
|
||||||
("y" kill-ring-save "yank" :color blue)
|
|
||||||
("q" nil "quit")))
|
|
||||||
(hydra-set-property 'hydra-vi :verbosity 1))
|
|
||||||
|
|
||||||
;; This example introduces :color amaranth. It's similar to red,
|
|
||||||
;; except while you can quit red with any binding which isn't a Hydra
|
|
||||||
;; head, you can quit amaranth only with a blue head. So you can quit
|
|
||||||
;; this mode only with "d", "y", "q" or "C-g".
|
|
||||||
;;
|
|
||||||
;; Another novelty are the :pre and :post handlers. :pre will be
|
|
||||||
;; called before each command, while :post will be called when the
|
|
||||||
;; Hydra quits. In this case, they're used to override the cursor
|
|
||||||
;; color while Hydra is active.
|
|
||||||
|
|
||||||
;;** Example 6: selective global bind
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(defhydra hydra-next-error (global-map "C-x")
|
|
||||||
"next-error"
|
|
||||||
("`" next-error "next")
|
|
||||||
("j" next-error "next" :bind nil)
|
|
||||||
("k" previous-error "previous" :bind nil)))
|
|
||||||
|
|
||||||
;; This example will bind "C-x `" in `global-map', but it will not
|
|
||||||
;; bind "C-x j" and "C-x k".
|
|
||||||
;; You can still "C-x `jjk" though.
|
|
||||||
|
|
||||||
;;** Example 7: toggle with Ruby-style docstring
|
|
||||||
(defvar whitespace-mode nil)
|
|
||||||
(defhydra hydra-toggle (:color pink)
|
|
||||||
"
|
|
||||||
_a_ abbrev-mode: %`abbrev-mode
|
|
||||||
_d_ debug-on-error: %`debug-on-error
|
|
||||||
_f_ auto-fill-mode: %`auto-fill-function
|
|
||||||
_t_ truncate-lines: %`truncate-lines
|
|
||||||
_w_ whitespace-mode: %`whitespace-mode
|
|
||||||
|
|
||||||
"
|
|
||||||
("a" abbrev-mode nil)
|
|
||||||
("d" toggle-debug-on-error nil)
|
|
||||||
("f" auto-fill-mode nil)
|
|
||||||
("t" toggle-truncate-lines nil)
|
|
||||||
("w" whitespace-mode nil)
|
|
||||||
("q" nil "quit"))
|
|
||||||
;; Recommended binding:
|
|
||||||
;; (global-set-key (kbd "C-c C-v") 'hydra-toggle/body)
|
|
||||||
|
|
||||||
;; Here, using e.g. "_a_" translates to "a" with proper face.
|
|
||||||
;; More interestingly:
|
|
||||||
;;
|
|
||||||
;; "foobar %`abbrev-mode" means roughly (format "foobar %S" abbrev-mode)
|
|
||||||
;;
|
|
||||||
;; This means that you actually see the state of the mode that you're changing.
|
|
||||||
|
|
||||||
;;** Example 8: the whole menu for `Buffer-menu-mode'
|
|
||||||
(defhydra hydra-buffer-menu (:color pink
|
|
||||||
:hint nil)
|
|
||||||
"
|
|
||||||
^Mark^ ^Unmark^ ^Actions^ ^Search
|
|
||||||
^^^^^^^^----------------------------------------------------------------- (__)
|
|
||||||
_m_: mark _u_: unmark _x_: execute _R_: re-isearch (oo)
|
|
||||||
_s_: save _U_: unmark up _b_: bury _I_: isearch /------\\/
|
|
||||||
_d_: delete ^ ^ _g_: refresh _O_: multi-occur / | ||
|
|
||||||
_D_: delete up ^ ^ _T_: files only: % -28`Buffer-menu-files-only^^ * /\\---/\\
|
|
||||||
_~_: modified ^ ^ ^ ^ ^^ ~~ ~~
|
|
||||||
"
|
|
||||||
("m" Buffer-menu-mark)
|
|
||||||
("u" Buffer-menu-unmark)
|
|
||||||
("U" Buffer-menu-backup-unmark)
|
|
||||||
("d" Buffer-menu-delete)
|
|
||||||
("D" Buffer-menu-delete-backwards)
|
|
||||||
("s" Buffer-menu-save)
|
|
||||||
("~" Buffer-menu-not-modified)
|
|
||||||
("x" Buffer-menu-execute)
|
|
||||||
("b" Buffer-menu-bury)
|
|
||||||
("g" revert-buffer)
|
|
||||||
("T" Buffer-menu-toggle-files-only)
|
|
||||||
("O" Buffer-menu-multi-occur :color blue)
|
|
||||||
("I" Buffer-menu-isearch-buffers :color blue)
|
|
||||||
("R" Buffer-menu-isearch-buffers-regexp :color blue)
|
|
||||||
("c" nil "cancel")
|
|
||||||
("v" Buffer-menu-select "select" :color blue)
|
|
||||||
("o" Buffer-menu-other-window "other-window" :color blue)
|
|
||||||
("q" quit-window "quit" :color blue))
|
|
||||||
;; Recommended binding:
|
|
||||||
;; (define-key Buffer-menu-mode-map "." 'hydra-buffer-menu/body)
|
|
||||||
|
|
||||||
;;** Example 9: s-expressions in the docstring
|
|
||||||
;; You can inline s-expresssions into the docstring like this:
|
|
||||||
(defvar dired-mode-map)
|
|
||||||
(declare-function dired-mark "dired")
|
|
||||||
(when (bound-and-true-p hydra-examples-verbatim)
|
|
||||||
(require 'dired)
|
|
||||||
(defhydra hydra-marked-items (dired-mode-map "")
|
|
||||||
"
|
|
||||||
Number of marked items: %(length (dired-get-marked-files))
|
|
||||||
"
|
|
||||||
("m" dired-mark "mark")))
|
|
||||||
|
|
||||||
;; This results in the following dynamic docstring:
|
|
||||||
;;
|
|
||||||
;; (format "Number of marked items: %S\n"
|
|
||||||
;; (length (dired-get-marked-files)))
|
|
||||||
;;
|
|
||||||
;; You can use `format'-style width specs, e.g. % 10(length nil).
|
|
||||||
|
|
||||||
;;** Example 10: apropos family
|
|
||||||
(defhydra hydra-apropos (:color blue
|
|
||||||
:hint nil)
|
|
||||||
"
|
|
||||||
_a_propos _c_ommand
|
|
||||||
_d_ocumentation _l_ibrary
|
|
||||||
_v_ariable _u_ser-option
|
|
||||||
^ ^ valu_e_"
|
|
||||||
("a" apropos)
|
|
||||||
("d" apropos-documentation)
|
|
||||||
("v" apropos-variable)
|
|
||||||
("c" apropos-command)
|
|
||||||
("l" apropos-library)
|
|
||||||
("u" apropos-user-option)
|
|
||||||
("e" apropos-value))
|
|
||||||
;; Recommended binding:
|
|
||||||
;; (global-set-key (kbd "C-c h") 'hydra-apropos/body)
|
|
||||||
|
|
||||||
;;** Example 11: rectangle-mark-mode
|
|
||||||
(require 'rect)
|
|
||||||
(defhydra hydra-rectangle (:body-pre (rectangle-mark-mode 1)
|
|
||||||
:color pink
|
|
||||||
:post (deactivate-mark))
|
|
||||||
"
|
|
||||||
^_k_^ _d_elete _s_tring
|
|
||||||
_h_ _l_ _o_k _y_ank
|
|
||||||
^_j_^ _n_ew-copy _r_eset
|
|
||||||
^^^^ _e_xchange _u_ndo
|
|
||||||
^^^^ ^ ^ _p_aste
|
|
||||||
"
|
|
||||||
("h" rectangle-backward-char nil)
|
|
||||||
("l" rectangle-forward-char nil)
|
|
||||||
("k" rectangle-previous-line nil)
|
|
||||||
("j" rectangle-next-line nil)
|
|
||||||
("e" hydra-ex-point-mark nil)
|
|
||||||
("n" copy-rectangle-as-kill nil)
|
|
||||||
("d" delete-rectangle nil)
|
|
||||||
("r" (if (region-active-p)
|
|
||||||
(deactivate-mark)
|
|
||||||
(rectangle-mark-mode 1)) nil)
|
|
||||||
("y" yank-rectangle nil)
|
|
||||||
("u" undo nil)
|
|
||||||
("s" string-rectangle nil)
|
|
||||||
("p" kill-rectangle nil)
|
|
||||||
("o" nil nil))
|
|
||||||
|
|
||||||
;; Recommended binding:
|
|
||||||
;; (global-set-key (kbd "C-x SPC") 'hydra-rectangle/body)
|
|
||||||
|
|
||||||
;;** Example 12: org-agenda-view
|
|
||||||
(defun org-agenda-cts ()
|
|
||||||
(and (eq major-mode 'org-agenda-mode)
|
|
||||||
(let ((args (get-text-property
|
|
||||||
(min (1- (point-max)) (point))
|
|
||||||
'org-last-args)))
|
|
||||||
(nth 2 args))))
|
|
||||||
|
|
||||||
(defhydra hydra-org-agenda-view (:hint none)
|
|
||||||
"
|
|
||||||
_d_: ?d? day _g_: time grid=?g? _a_: arch-trees
|
|
||||||
_w_: ?w? week _[_: inactive _A_: arch-files
|
|
||||||
_t_: ?t? fortnight _f_: follow=?f? _r_: clock report=?r?
|
|
||||||
_m_: ?m? month _e_: entry text=?e? _D_: include diary=?D?
|
|
||||||
_y_: ?y? year _q_: quit _L__l__c_: log = ?l?"
|
|
||||||
("SPC" org-agenda-reset-view)
|
|
||||||
("d" org-agenda-day-view (if (eq 'day (org-agenda-cts)) "[x]" "[ ]"))
|
|
||||||
("w" org-agenda-week-view (if (eq 'week (org-agenda-cts)) "[x]" "[ ]"))
|
|
||||||
("t" org-agenda-fortnight-view (if (eq 'fortnight (org-agenda-cts)) "[x]" "[ ]"))
|
|
||||||
("m" org-agenda-month-view (if (eq 'month (org-agenda-cts)) "[x]" "[ ]"))
|
|
||||||
("y" org-agenda-year-view (if (eq 'year (org-agenda-cts)) "[x]" "[ ]"))
|
|
||||||
("l" org-agenda-log-mode (format "% -3S" org-agenda-show-log))
|
|
||||||
("L" (org-agenda-log-mode '(4)))
|
|
||||||
("c" (org-agenda-log-mode 'clockcheck))
|
|
||||||
("f" org-agenda-follow-mode (format "% -3S" org-agenda-follow-mode))
|
|
||||||
("a" org-agenda-archives-mode)
|
|
||||||
("A" (org-agenda-archives-mode 'files))
|
|
||||||
("r" org-agenda-clockreport-mode (format "% -3S" org-agenda-clockreport-mode))
|
|
||||||
("e" org-agenda-entry-text-mode (format "% -3S" org-agenda-entry-text-mode))
|
|
||||||
("g" org-agenda-toggle-time-grid (format "% -3S" org-agenda-use-time-grid))
|
|
||||||
("D" org-agenda-toggle-diary (format "% -3S" org-agenda-include-diary))
|
|
||||||
("!" org-agenda-toggle-deadlines)
|
|
||||||
("[" (let ((org-agenda-include-inactive-timestamps t))
|
|
||||||
(org-agenda-check-type t 'timeline 'agenda)
|
|
||||||
(org-agenda-redo)
|
|
||||||
(message "Display now includes inactive timestamps as well")))
|
|
||||||
("q" (message "Abort") :exit t)
|
|
||||||
("v" nil))
|
|
||||||
|
|
||||||
;; Recommended binding:
|
|
||||||
;; (define-key org-agenda-mode-map "v" 'hydra-org-agenda-view/body)
|
|
||||||
|
|
||||||
;;* Helpers
|
|
||||||
(require 'windmove)
|
|
||||||
|
|
||||||
(defun hydra-move-splitter-left (arg)
|
|
||||||
"Move window splitter left."
|
|
||||||
(interactive "p")
|
|
||||||
(if (let ((windmove-wrap-around))
|
|
||||||
(windmove-find-other-window 'right))
|
|
||||||
(shrink-window-horizontally arg)
|
|
||||||
(enlarge-window-horizontally arg)))
|
|
||||||
|
|
||||||
(defun hydra-move-splitter-right (arg)
|
|
||||||
"Move window splitter right."
|
|
||||||
(interactive "p")
|
|
||||||
(if (let ((windmove-wrap-around))
|
|
||||||
(windmove-find-other-window 'right))
|
|
||||||
(enlarge-window-horizontally arg)
|
|
||||||
(shrink-window-horizontally arg)))
|
|
||||||
|
|
||||||
(defun hydra-move-splitter-up (arg)
|
|
||||||
"Move window splitter up."
|
|
||||||
(interactive "p")
|
|
||||||
(if (let ((windmove-wrap-around))
|
|
||||||
(windmove-find-other-window 'up))
|
|
||||||
(enlarge-window arg)
|
|
||||||
(shrink-window arg)))
|
|
||||||
|
|
||||||
(defun hydra-move-splitter-down (arg)
|
|
||||||
"Move window splitter down."
|
|
||||||
(interactive "p")
|
|
||||||
(if (let ((windmove-wrap-around))
|
|
||||||
(windmove-find-other-window 'up))
|
|
||||||
(shrink-window arg)
|
|
||||||
(enlarge-window arg)))
|
|
||||||
|
|
||||||
(defvar rectangle-mark-mode)
|
|
||||||
(defun hydra-ex-point-mark ()
|
|
||||||
"Exchange point and mark."
|
|
||||||
(interactive)
|
|
||||||
(if rectangle-mark-mode
|
|
||||||
(rectangle-exchange-point-and-mark)
|
|
||||||
(let ((mk (mark)))
|
|
||||||
(rectangle-mark-mode 1)
|
|
||||||
(goto-char mk))))
|
|
||||||
|
|
||||||
(provide 'hydra-examples)
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
;;; hydra-examples.el ends here
|
|
||||||
@ -1,127 +0,0 @@
|
|||||||
;;; hydra-ox.el --- Org mode export widget implemented in Hydra
|
|
||||||
|
|
||||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: Oleh Krehel
|
|
||||||
|
|
||||||
;; This file is part of GNU Emacs.
|
|
||||||
|
|
||||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation, either version 3 of the License, or
|
|
||||||
;; (at your option) any later version.
|
|
||||||
|
|
||||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; 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, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; This shows how a complex dispatch menu can be built with Hydra.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'hydra)
|
|
||||||
(require 'org)
|
|
||||||
(declare-function org-html-export-as-html 'ox-html)
|
|
||||||
(declare-function org-html-export-to-html 'ox-html)
|
|
||||||
(declare-function org-latex-export-as-latex 'ox-latex)
|
|
||||||
(declare-function org-latex-export-to-latex 'ox-latex)
|
|
||||||
(declare-function org-latex-export-to-pdf 'ox-latex)
|
|
||||||
(declare-function org-ascii-export-as-ascii 'ox-ascii)
|
|
||||||
(declare-function org-ascii-export-to-ascii 'ox-ascii)
|
|
||||||
|
|
||||||
(defhydradio hydra-ox ()
|
|
||||||
(body-only "Export only the body.")
|
|
||||||
(export-scope "Export scope." [buffer subtree])
|
|
||||||
(async-export "When non-nil, export async.")
|
|
||||||
(visible-only "When non-nil, export visible only")
|
|
||||||
(force-publishing "Toggle force publishing"))
|
|
||||||
|
|
||||||
(defhydra hydra-ox-html (:color blue)
|
|
||||||
"ox-html"
|
|
||||||
("H" (org-html-export-as-html
|
|
||||||
hydra-ox/async-export
|
|
||||||
(eq hydra-ox/export-scope 'subtree)
|
|
||||||
hydra-ox/visible-only
|
|
||||||
hydra-ox/body-only)
|
|
||||||
"As HTML buffer")
|
|
||||||
("h" (org-html-export-to-html
|
|
||||||
hydra-ox/async-export
|
|
||||||
(eq hydra-ox/export-scope 'subtree)
|
|
||||||
hydra-ox/visible-only
|
|
||||||
hydra-ox/body-only) "As HTML file")
|
|
||||||
("o" (org-open-file
|
|
||||||
(org-html-export-to-html
|
|
||||||
hydra-ox/async-export
|
|
||||||
(eq hydra-ox/export-scope 'subtree)
|
|
||||||
hydra-ox/visible-only
|
|
||||||
hydra-ox/body-only)) "As HTML file and open")
|
|
||||||
("b" hydra-ox/body "back")
|
|
||||||
("q" nil "quit"))
|
|
||||||
|
|
||||||
(defhydra hydra-ox-latex (:color blue)
|
|
||||||
"ox-latex"
|
|
||||||
("L" org-latex-export-as-latex "As LaTeX buffer")
|
|
||||||
("l" org-latex-export-to-latex "As LaTeX file")
|
|
||||||
("p" org-latex-export-to-pdf "As PDF file")
|
|
||||||
("o" (org-open-file (org-latex-export-to-pdf)) "As PDF file and open")
|
|
||||||
("b" hydra-ox/body "back")
|
|
||||||
("q" nil "quit"))
|
|
||||||
|
|
||||||
(defhydra hydra-ox-text (:color blue)
|
|
||||||
"ox-text"
|
|
||||||
("A" (org-ascii-export-as-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset ascii))
|
|
||||||
"As ASCII buffer")
|
|
||||||
|
|
||||||
("a" (org-ascii-export-to-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset ascii))
|
|
||||||
"As ASCII file")
|
|
||||||
("L" (org-ascii-export-as-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset latin1))
|
|
||||||
"As Latin1 buffer")
|
|
||||||
("l" (org-ascii-export-to-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset latin1))
|
|
||||||
"As Latin1 file")
|
|
||||||
("U" (org-ascii-export-as-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset utf-8))
|
|
||||||
"As UTF-8 buffer")
|
|
||||||
("u" (org-ascii-export-to-ascii
|
|
||||||
nil nil nil nil
|
|
||||||
'(:ascii-charset utf-8))
|
|
||||||
"As UTF-8 file")
|
|
||||||
("b" hydra-ox/body "back")
|
|
||||||
("q" nil "quit"))
|
|
||||||
|
|
||||||
(defhydra hydra-ox ()
|
|
||||||
"
|
|
||||||
_C-b_ Body only: % -15`hydra-ox/body-only^^^ _C-v_ Visible only: %`hydra-ox/visible-only
|
|
||||||
_C-s_ Export scope: % -15`hydra-ox/export-scope _C-f_ Force publishing: %`hydra-ox/force-publishing
|
|
||||||
_C-a_ Async export: %`hydra-ox/async-export
|
|
||||||
|
|
||||||
"
|
|
||||||
("C-b" (hydra-ox/body-only) nil)
|
|
||||||
("C-v" (hydra-ox/visible-only) nil)
|
|
||||||
("C-s" (hydra-ox/export-scope) nil)
|
|
||||||
("C-f" (hydra-ox/force-publishing) nil)
|
|
||||||
("C-a" (hydra-ox/async-export) nil)
|
|
||||||
("h" hydra-ox-html/body "Export to HTML" :exit t)
|
|
||||||
("l" hydra-ox-latex/body "Export to LaTeX" :exit t)
|
|
||||||
("t" hydra-ox-text/body "Export to Plain Text" :exit t)
|
|
||||||
("q" nil "quit"))
|
|
||||||
|
|
||||||
(define-key org-mode-map (kbd "C-c C-,") 'hydra-ox/body)
|
|
||||||
|
|
||||||
(provide 'hydra-ox)
|
|
||||||
|
|
||||||
;;; hydra-ox.el ends here
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
(define-package "hydra" "20160913.216" "Make bindings that stick around."
|
|
||||||
'((cl-lib "0.5"))
|
|
||||||
:url "https://github.com/abo-abo/hydra" :keywords
|
|
||||||
'("bindings"))
|
|
||||||
;; Local Variables:
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; End:
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,117 +0,0 @@
|
|||||||
;;; lv.el --- Other echo area
|
|
||||||
|
|
||||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: Oleh Krehel
|
|
||||||
|
|
||||||
;; This file is part of GNU Emacs.
|
|
||||||
|
|
||||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation, either version 3 of the License, or
|
|
||||||
;; (at your option) any later version.
|
|
||||||
|
|
||||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; 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, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; This package provides `lv-message' intended to be used in place of
|
|
||||||
;; `message' when semi-permanent hints are needed, in order to not
|
|
||||||
;; interfere with Echo Area.
|
|
||||||
;;
|
|
||||||
;; "Я тихо-тихо пiдглядаю,
|
|
||||||
;; І тiшуся собi, як бачу то,
|
|
||||||
;; Шо страшить i не пiдпускає,
|
|
||||||
;; А iншi п’ють тебе, як воду пiсок."
|
|
||||||
;; -- Андрій Кузьменко, L.V.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(defgroup lv nil
|
|
||||||
"The other echo area."
|
|
||||||
:group 'minibuffer
|
|
||||||
:group 'hydra)
|
|
||||||
|
|
||||||
(defcustom lv-use-separator nil
|
|
||||||
"Whether to draw a line between the LV window and the Echo Area."
|
|
||||||
:group 'lv
|
|
||||||
:type 'boolean)
|
|
||||||
|
|
||||||
(defface lv-separator
|
|
||||||
'((((class color) (background light)) :background "grey80")
|
|
||||||
(((class color) (background dark)) :background "grey30"))
|
|
||||||
"Face used to draw line between the lv window and the echo area.
|
|
||||||
This is only used if option `lv-use-separator' is non-nil.
|
|
||||||
Only the background color is significant."
|
|
||||||
:group 'lv)
|
|
||||||
|
|
||||||
(defvar lv-wnd nil
|
|
||||||
"Holds the current LV window.")
|
|
||||||
|
|
||||||
(defun lv-window ()
|
|
||||||
"Ensure that LV window is live and return it."
|
|
||||||
(if (window-live-p lv-wnd)
|
|
||||||
lv-wnd
|
|
||||||
(let ((ori (selected-window))
|
|
||||||
buf)
|
|
||||||
(prog1 (setq lv-wnd
|
|
||||||
(select-window
|
|
||||||
(let ((ignore-window-parameters t))
|
|
||||||
(split-window
|
|
||||||
(frame-root-window) -1 'below))))
|
|
||||||
(if (setq buf (get-buffer " *LV*"))
|
|
||||||
(switch-to-buffer buf)
|
|
||||||
(switch-to-buffer " *LV*")
|
|
||||||
(set-window-hscroll lv-wnd 0)
|
|
||||||
(setq window-size-fixed t)
|
|
||||||
(setq mode-line-format nil)
|
|
||||||
(setq cursor-type nil)
|
|
||||||
(set-window-dedicated-p lv-wnd t)
|
|
||||||
(set-window-parameter lv-wnd 'no-other-window t))
|
|
||||||
(select-window ori)))))
|
|
||||||
|
|
||||||
(defvar golden-ratio-mode)
|
|
||||||
|
|
||||||
(defvar lv-force-update nil
|
|
||||||
"When non-nil, `lv-message' will refresh even for the same string.")
|
|
||||||
|
|
||||||
(defun lv-message (format-string &rest args)
|
|
||||||
"Set LV window contents to (`format' FORMAT-STRING ARGS)."
|
|
||||||
(let* ((str (apply #'format format-string args))
|
|
||||||
(n-lines (cl-count ?\n str))
|
|
||||||
deactivate-mark
|
|
||||||
golden-ratio-mode)
|
|
||||||
(with-selected-window (lv-window)
|
|
||||||
(unless (and (string= (buffer-string) str)
|
|
||||||
(null lv-force-update))
|
|
||||||
(delete-region (point-min) (point-max))
|
|
||||||
(insert str)
|
|
||||||
(when (and (window-system) lv-use-separator)
|
|
||||||
(unless (looking-back "\n" nil)
|
|
||||||
(insert "\n"))
|
|
||||||
(insert
|
|
||||||
(propertize "__" 'face 'lv-separator 'display '(space :height (1)))
|
|
||||||
(propertize "\n" 'face 'lv-separator 'line-height t)))
|
|
||||||
(set (make-local-variable 'window-min-height) n-lines)
|
|
||||||
(setq truncate-lines (> n-lines 1))
|
|
||||||
(let ((window-resize-pixelwise t)
|
|
||||||
(window-size-fixed nil))
|
|
||||||
(fit-window-to-buffer nil nil 1)))
|
|
||||||
(goto-char (point-min)))))
|
|
||||||
|
|
||||||
(defun lv-delete-window ()
|
|
||||||
"Delete LV window and kill its buffer."
|
|
||||||
(when (window-live-p lv-wnd)
|
|
||||||
(let ((buf (window-buffer lv-wnd)))
|
|
||||||
(delete-window lv-wnd)
|
|
||||||
(kill-buffer buf))))
|
|
||||||
|
|
||||||
(provide 'lv)
|
|
||||||
|
|
||||||
;;; lv.el ends here
|
|
||||||
@ -1,15 +0,0 @@
|
|||||||
;;; logito-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil nil ("logito.el") (22221 60700 987613 744000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; logito-autoloads.el ends here
|
|
||||||
@ -1 +0,0 @@
|
|||||||
(define-package "logito" "20120225.1255" "logging library for Emacs" '((eieio "1.3")) :keywords '("lisp" "tool"))
|
|
||||||
@ -1,98 +0,0 @@
|
|||||||
;;; logito.el --- logging library for Emacs
|
|
||||||
|
|
||||||
;; Copyright (C) 2012 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <yann.hodique@gmail.com>
|
|
||||||
;; Keywords: lisp, tool
|
|
||||||
;; Package-Version: 20120225.1255
|
|
||||||
;; Version: 0.1
|
|
||||||
;; Package-Requires: ((eieio "1.3"))
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; This module provides logging facility for Emacs
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl))
|
|
||||||
|
|
||||||
(require 'eieio)
|
|
||||||
|
|
||||||
(defclass logito-object ()
|
|
||||||
((level :initarg :level :initform nil)))
|
|
||||||
|
|
||||||
(defmethod logito-insert-log ((log logito-object) format &rest objects)
|
|
||||||
"Base implementation, do nothing")
|
|
||||||
|
|
||||||
(defmethod logito-should-log ((log logito-object) level)
|
|
||||||
(let ((l (oref log :level)))
|
|
||||||
(and (integerp l)
|
|
||||||
(<= level l))))
|
|
||||||
|
|
||||||
(defmethod logito-log ((log logito-object) level tag string &rest objects)
|
|
||||||
(when (logito-should-log log level)
|
|
||||||
(apply 'logito-insert-log log (format "[%s] %s" tag string) objects)))
|
|
||||||
|
|
||||||
(defmethod logito-log (log level tag string &rest objects)
|
|
||||||
"Fallback implementation, do nothing. This allows in particular
|
|
||||||
to pass nil as the log object."
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defclass logito-message-object (logito-object)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod logito-insert-log ((log logito-message-object) format &rest objects)
|
|
||||||
(apply 'message format objects))
|
|
||||||
|
|
||||||
(defclass logito-buffer-object (logito-object)
|
|
||||||
((buffer :initarg :buffer :initform nil)))
|
|
||||||
|
|
||||||
(defmethod logito-should-log ((log logito-buffer-object) level)
|
|
||||||
(and (oref log :buffer)
|
|
||||||
(call-next-method)))
|
|
||||||
|
|
||||||
(defmethod logito-insert-log ((log logito-buffer-object) format &rest objects)
|
|
||||||
(let ((buffer (get-buffer-create (oref log :buffer))))
|
|
||||||
(with-current-buffer buffer
|
|
||||||
(goto-char (point-max))
|
|
||||||
(insert (apply 'format format objects) "\n\n"))))
|
|
||||||
|
|
||||||
(defmacro logito-def-level (sym val &optional pkg)
|
|
||||||
"Define a constant logito-<SYM>-level and a macro logito:<SYM>
|
|
||||||
associated with this level."
|
|
||||||
(let* ((pkg (or pkg 'logito))
|
|
||||||
(const (intern (format "%s:%s-level"
|
|
||||||
(symbol-name pkg) (symbol-name sym))))
|
|
||||||
(mac (intern (format "%s:%s"
|
|
||||||
(symbol-name pkg) (symbol-name sym)))))
|
|
||||||
`(progn
|
|
||||||
(defconst ,const ,val)
|
|
||||||
(defmacro ,mac (log string &rest objects)
|
|
||||||
(append
|
|
||||||
(list 'logito-log log ,const '',sym string)
|
|
||||||
objects)))))
|
|
||||||
|
|
||||||
;; built-in log levels
|
|
||||||
(logito-def-level error 0)
|
|
||||||
(logito-def-level info 5)
|
|
||||||
(logito-def-level verbose 10)
|
|
||||||
(logito-def-level debug 15)
|
|
||||||
|
|
||||||
(provide 'logito)
|
|
||||||
;;; logito.el ends here
|
|
||||||
@ -1,33 +0,0 @@
|
|||||||
;;; marshal-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "marshal" "marshal.el" (22454 5328 305397 868000))
|
|
||||||
;;; Generated autoloads from marshal.el
|
|
||||||
|
|
||||||
(autoload 'marshal "marshal" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn OBJ TYPE)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'unmarshal "marshal" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn OBJ BLOB TYPE)" nil nil)
|
|
||||||
|
|
||||||
(autoload 'marshal-defclass "marshal" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn NAME SUPERCLASS SLOTS &rest OPTIONS-AND-DOC)" nil t)
|
|
||||||
|
|
||||||
(function-put 'marshal-defclass 'lisp-indent-function '2)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; marshal-autoloads.el ends here
|
|
||||||
@ -1,2 +0,0 @@
|
|||||||
;;; -*- no-byte-compile: t -*-
|
|
||||||
(define-package "marshal" "20160807.1954" "eieio extension for automatic (un)marshalling" '((eieio "1.4") (json "1.3") (ht "2.1")) :url "https://github.com/sigma/marshal.el" :keywords '("eieio"))
|
|
||||||
@ -1,492 +0,0 @@
|
|||||||
;;; marshal.el --- eieio extension for automatic (un)marshalling
|
|
||||||
|
|
||||||
;; Copyright (C) 2015 Yann Hodique
|
|
||||||
|
|
||||||
;; Author: Yann Hodique <hodiquey@vmware.com>
|
|
||||||
;; Keywords: eieio
|
|
||||||
;; Package-Version: 20160807.1954
|
|
||||||
;; Version: 0.7.0
|
|
||||||
;; URL: https://github.com/sigma/marshal.el
|
|
||||||
;; Package-Requires: ((eieio "1.4") (json "1.3") (ht "2.1"))
|
|
||||||
|
|
||||||
;; This file is free software; you can redistribute it and/or modify
|
|
||||||
;; it under the terms of the GNU General Public License as published by
|
|
||||||
;; the Free Software Foundation; either version 2, or (at your option)
|
|
||||||
;; any later version.
|
|
||||||
|
|
||||||
;; This file is distributed in the hope that it will be useful,
|
|
||||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;; GNU General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
||||||
;; Boston, MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; Inspired by Go tagged structs. 'alist, 'plist and 'json drivers are
|
|
||||||
;; provided, but implementing others just requires to inherit from
|
|
||||||
;; `marshal-driver'.
|
|
||||||
|
|
||||||
;; Sometimes the types are not enough (for example with lists, whose elements
|
|
||||||
;; are not explicitly typed. In those cases, a small extension on top of types
|
|
||||||
;; can be used. Like for example :marshal-type (list string)
|
|
||||||
|
|
||||||
;; Examples:
|
|
||||||
|
|
||||||
;; 1. Regular use:
|
|
||||||
|
|
||||||
;; (marshal-defclass plop ()
|
|
||||||
;; ((foo :initarg :foo :type string :marshal ((alist . field_foo)))
|
|
||||||
;; (bar :initarg :bar :type integer :marshal ((alist . field_bar)))
|
|
||||||
;; (baz :initarg :baz :type integer :marshal ((alist . field_baz)))))
|
|
||||||
|
|
||||||
;; (marshal-defclass plopi ()
|
|
||||||
;; ((alpha :marshal ((alist . field_alpha)))
|
|
||||||
;; (beta :type plop :marshal ((alist . field_beta)))))
|
|
||||||
|
|
||||||
;; (marshal (make-instance 'plop :foo "ok" :bar 42) 'alist)
|
|
||||||
;; => '((field_bar . 42) (field_foo . "ok"))
|
|
||||||
|
|
||||||
;; (unmarshal 'plop '((field_foo . "plop") (field_bar . 0) (field_baz . 1)) 'alist)
|
|
||||||
;; => '[object plop "plop" "plop" 0 1]
|
|
||||||
|
|
||||||
;; (marshal
|
|
||||||
;; (unmarshal 'plopi '((field_alpha . 42)
|
|
||||||
;; (field_beta . ((field_foo . "plop")
|
|
||||||
;; (field_bar . 0)
|
|
||||||
;; (field_baz . 1)))) 'alist)
|
|
||||||
;; 'alist)
|
|
||||||
;; => '((field_beta (field_baz . 1) (field_bar . 0) (field_foo . "plop")) (field_alpha . 42))
|
|
||||||
|
|
||||||
;; 2. Objects involving lists:
|
|
||||||
|
|
||||||
;; (marshal-defclass foo/tree ()
|
|
||||||
;; ((root :initarg :id :marshal ((plist . :root)))
|
|
||||||
;; (leaves :initarg :leaves :marshal ((plist . :leaves)) :marshal-type (list foo/tree))))
|
|
||||||
|
|
||||||
;; (marshal (make-instance 'foo/tree :id 0
|
|
||||||
;; :leaves (list (make-instance 'foo/tree :id 1)
|
|
||||||
;; (make-instance 'foo/tree :id 2
|
|
||||||
;; :leaves (list (make-instance 'foo/tree :id 3)))))
|
|
||||||
;; 'plist)
|
|
||||||
;; => (:root 0 :leaves ((:root 1) (:root 2 :leaves ((:root 3)))))
|
|
||||||
|
|
||||||
;; (unmarshal 'foo/tree '(:root 0 :leaves ((:root 1) (:root 2 :leaves ((:root 3))))) 'plist)
|
|
||||||
|
|
||||||
;; => [object foo/tree "foo/tree" 0
|
|
||||||
;; ([object foo/tree "foo/tree" 1 nil]
|
|
||||||
;; [object foo/tree "foo/tree" 2
|
|
||||||
;; ([object foo/tree "foo/tree" 3 nil])])]
|
|
||||||
|
|
||||||
;; 3. Json
|
|
||||||
|
|
||||||
;; (marshal (make-instance 'foo/tree :id 0
|
|
||||||
;; :leaves (list (make-instance 'foo/tree :id 1)
|
|
||||||
;; (make-instance 'foo/tree :id 2
|
|
||||||
;; :leaves (list (make-instance 'foo/tree :id 3)))))
|
|
||||||
;; 'json)
|
|
||||||
;; => "{\"leaves\":[{\"root\":1},{\"leaves\":[{\"root\":3}],\"root\":2}],\"root\":0}"
|
|
||||||
|
|
||||||
;; (unmarshal 'foo/tree "{\"leaves\":[{\"root\":1},{\"leaves\":[{\"root\":3}],\"root\":2}],\"root\":0}" 'json)
|
|
||||||
;; => [object foo/tree "foo/tree" 0
|
|
||||||
;; ([object foo/tree "foo/tree" 1 nil]
|
|
||||||
;; [object foo/tree "foo/tree" 2
|
|
||||||
;; ([object foo/tree "foo/tree" 3 nil])])]
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(require 'json)
|
|
||||||
(require 'eieio)
|
|
||||||
(require 'ht)
|
|
||||||
|
|
||||||
;;; eieio backward-compatibility
|
|
||||||
(dolist (sym '(object-class object-p oref oset))
|
|
||||||
(let ((new-sym (intern (concat "eieio-" (symbol-name sym)))))
|
|
||||||
(unless (fboundp new-sym)
|
|
||||||
(fset new-sym sym))))
|
|
||||||
|
|
||||||
;;; json hotfix
|
|
||||||
(when (json-alist-p '(((foo))))
|
|
||||||
(defun json-alist-p (list)
|
|
||||||
(while (consp list)
|
|
||||||
(setq list (if (and (consp (car list)) (atom (caar list)))
|
|
||||||
(cdr list)
|
|
||||||
'not-alist)))
|
|
||||||
(null list)))
|
|
||||||
|
|
||||||
;;; Defined drivers
|
|
||||||
|
|
||||||
(defvar marshal-drivers nil "Alist of drivers")
|
|
||||||
|
|
||||||
(defun marshal-register-driver (type driver)
|
|
||||||
(add-to-list 'marshal-drivers (cons type driver)))
|
|
||||||
|
|
||||||
;;; Marshalling driver interface
|
|
||||||
|
|
||||||
(defclass marshal-driver ()
|
|
||||||
((input :initarg :input)
|
|
||||||
(output :initarg :output)))
|
|
||||||
|
|
||||||
(defmethod marshal-open ((obj marshal-driver) &optional input)
|
|
||||||
(if input
|
|
||||||
(oset obj :input input)
|
|
||||||
(oset obj :output nil)))
|
|
||||||
|
|
||||||
(defmethod marshal-write ((obj marshal-driver) path value)
|
|
||||||
(unless (slot-boundp obj :output)
|
|
||||||
(error "Driver has not been opened in write mode")))
|
|
||||||
|
|
||||||
(defmethod marshal-read ((obj marshal-driver) path)
|
|
||||||
(unless (slot-boundp obj :input)
|
|
||||||
(error "Driver has not been opened in read mode")))
|
|
||||||
|
|
||||||
(defmethod marshal-close ((obj marshal-driver))
|
|
||||||
(when (slot-boundp obj :output)
|
|
||||||
(oref obj :output)))
|
|
||||||
|
|
||||||
(defmethod marshal-guess-type :static ((obj marshal-driver) blob)
|
|
||||||
(cond ((null blob) nil)
|
|
||||||
((booleanp blob) 'bool)
|
|
||||||
((stringp blob) 'string)
|
|
||||||
((numberp blob) 'number)
|
|
||||||
((listp blob) 'list)
|
|
||||||
((ht? blob) 'hash)))
|
|
||||||
|
|
||||||
(defmethod marshal-preprocess ((obj marshal-driver) blob)
|
|
||||||
blob)
|
|
||||||
|
|
||||||
(defmethod marshal-postprocess ((obj marshal-driver) blob)
|
|
||||||
blob)
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-null :static ((obj marshal-driver))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-null :static ((obj marshal-driver))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-string :static ((obj marshal-driver) s)
|
|
||||||
(format "%s" s))
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-string :static ((obj marshal-driver) s)
|
|
||||||
s)
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-number :static ((obj marshal-driver) i)
|
|
||||||
i)
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-number :static ((obj marshal-driver) i)
|
|
||||||
i)
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-bool :static ((obj marshal-driver) b)
|
|
||||||
(equal b t))
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-bool :static ((obj marshal-driver) b)
|
|
||||||
(equal b t))
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-list :static ((obj marshal-driver) l l-type)
|
|
||||||
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
||||||
obj)))
|
|
||||||
(cons (unmarshal-internal (when (consp l-type)
|
|
||||||
(cadr l-type))
|
|
||||||
(car l) type)
|
|
||||||
(unmarshal-internal l-type (cdr l) type))))
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-list :static ((obj marshal-driver) l)
|
|
||||||
(unless (null l)
|
|
||||||
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
||||||
obj)))
|
|
||||||
(cons (marshal-internal (car l) type)
|
|
||||||
(marshal-internal (cdr l) type)))))
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-hash :static ((obj marshal-driver) h h-type)
|
|
||||||
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
||||||
obj))
|
|
||||||
(k-type (when (consp h-type) (nth 1 h-type)))
|
|
||||||
(v-type (when (consp h-type) (nth 2 h-type))))
|
|
||||||
(ht<-alist
|
|
||||||
(mapcar (lambda (item)
|
|
||||||
(cons (unmarshal-internal k-type (car item) type)
|
|
||||||
(unmarshal-internal v-type (cdr item) type))) h))))
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-hash :static ((obj marshal-driver) h)
|
|
||||||
(unless (ht-empty? h)
|
|
||||||
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
||||||
obj)))
|
|
||||||
(mapcar (lambda (item)
|
|
||||||
(cons (marshal-internal (car item) type)
|
|
||||||
(marshal-internal (cadr item) type)))
|
|
||||||
(ht-items h)))))
|
|
||||||
|
|
||||||
;;; alist-based driver
|
|
||||||
|
|
||||||
(defclass marshal-driver-alist (marshal-driver)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod marshal-write ((obj marshal-driver-alist) path value)
|
|
||||||
(call-next-method)
|
|
||||||
(object-add-to-list obj :output (cons path value)))
|
|
||||||
|
|
||||||
(defmethod marshal-read ((obj marshal-driver-alist) path)
|
|
||||||
(call-next-method)
|
|
||||||
(cdr (assoc path (oref obj :input))))
|
|
||||||
|
|
||||||
;;; json driver
|
|
||||||
|
|
||||||
(defclass marshal-driver-json (marshal-driver-alist)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod marshal-preprocess ((obj marshal-driver-json) blob)
|
|
||||||
(let ((json-array-type 'list)
|
|
||||||
(json-object-type 'alist))
|
|
||||||
(json-read-from-string (call-next-method))))
|
|
||||||
|
|
||||||
(defmethod marshal-postprocess ((obj marshal-driver-json) blob)
|
|
||||||
(json-encode (call-next-method)))
|
|
||||||
|
|
||||||
(defmethod marshal-unmarshal-bool :static ((obj marshal-driver-json) b)
|
|
||||||
(not (eq b json-false)))
|
|
||||||
|
|
||||||
(defmethod marshal-marshal-bool :static ((obj marshal-driver-json) b)
|
|
||||||
(or b json-false))
|
|
||||||
|
|
||||||
;;; plist-based driver
|
|
||||||
|
|
||||||
(defclass marshal-driver-plist (marshal-driver)
|
|
||||||
())
|
|
||||||
|
|
||||||
(defmethod marshal-write ((obj marshal-driver-plist) path value)
|
|
||||||
(call-next-method)
|
|
||||||
(oset obj :output (plist-put (oref obj :output) path value)))
|
|
||||||
|
|
||||||
(defmethod marshal-read ((obj marshal-driver-plist) path)
|
|
||||||
(call-next-method)
|
|
||||||
(plist-get (oref obj :input) path))
|
|
||||||
|
|
||||||
;;; helper functions
|
|
||||||
|
|
||||||
(defun marshal--alist-add (alist key value &optional append)
|
|
||||||
(let ((existing (assoc key alist)))
|
|
||||||
(if (not existing)
|
|
||||||
(cons (cons key value) alist)
|
|
||||||
(setcdr existing (if append
|
|
||||||
(append (cdr existing) value)
|
|
||||||
value))
|
|
||||||
alist)))
|
|
||||||
|
|
||||||
(defun marshal--alist-merge (alist1 alist2 &optional append)
|
|
||||||
(let ((res alist1))
|
|
||||||
(if alist2
|
|
||||||
(let* ((pair (car alist2))
|
|
||||||
(x (car pair))
|
|
||||||
(y (cdr pair)))
|
|
||||||
(marshal--alist-merge
|
|
||||||
(marshal--alist-add alist1 x y append)
|
|
||||||
(cdr alist2)))
|
|
||||||
alist1)))
|
|
||||||
|
|
||||||
(defun marshal--transpose-alist2 (l)
|
|
||||||
(let (res
|
|
||||||
(rows l))
|
|
||||||
(while rows
|
|
||||||
(let* ((row (car rows))
|
|
||||||
(x (car row))
|
|
||||||
(cols (cdr row)))
|
|
||||||
(while cols
|
|
||||||
(let* ((col (car cols))
|
|
||||||
(y (car col))
|
|
||||||
(z (cdr col))
|
|
||||||
(target (or (assoc y res)
|
|
||||||
(let ((p (cons y nil)))
|
|
||||||
(setq res (push p res))
|
|
||||||
p))))
|
|
||||||
(setcdr target (cons (cons x z) (cdr target))))
|
|
||||||
(setq cols (cdr cols))))
|
|
||||||
(setq rows (cdr rows)))
|
|
||||||
res))
|
|
||||||
|
|
||||||
;;; base-class for serializable objects
|
|
||||||
|
|
||||||
(defclass marshal-base ()
|
|
||||||
((-marshal-info :allocation :class :initform nil :protection :protected)
|
|
||||||
(-type-info :allocation :class :initform nil :protection :protected)))
|
|
||||||
|
|
||||||
(defmethod marshal-get-marshal-info :static ((obj marshal-base))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod marshal-get-type-info :static ((obj marshal-base))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defun marshal-get-driver (type)
|
|
||||||
(let ((cls (or (and (class-p type) type)
|
|
||||||
(cdr (assoc type marshal-drivers))
|
|
||||||
'marshal-driver)))
|
|
||||||
(make-instance cls)))
|
|
||||||
|
|
||||||
(defmethod marshal-internal ((obj marshal-base) type &optional hint)
|
|
||||||
(let* ((type (or (and (class-p type)
|
|
||||||
(car (rassoc type marshal-drivers)))
|
|
||||||
type))
|
|
||||||
(driver (marshal-get-driver type))
|
|
||||||
(marshal-info (cdr (assoc type (marshal-get-marshal-info obj)))))
|
|
||||||
(marshal-open driver)
|
|
||||||
(when marshal-info
|
|
||||||
(dolist (s (object-slots obj))
|
|
||||||
(let ((path (cdr (assoc s marshal-info))))
|
|
||||||
(when (and path
|
|
||||||
(slot-boundp obj s))
|
|
||||||
|
|
||||||
(marshal-write driver path
|
|
||||||
(marshal-internal
|
|
||||||
(eieio-oref obj s)
|
|
||||||
type
|
|
||||||
(cdr (assoc s (marshal-get-type-info obj)))))))))
|
|
||||||
(marshal-close driver)))
|
|
||||||
|
|
||||||
(defmethod marshal-internal ((obj nil) type &optional hint)
|
|
||||||
(let ((driver (marshal-get-driver type)))
|
|
||||||
(cond ((and (null hint) (null obj))
|
|
||||||
(marshal-marshal-null driver))
|
|
||||||
((or (eq obj t)
|
|
||||||
(and (null obj) (eq hint 'bool)))
|
|
||||||
(marshal-marshal-bool driver obj))
|
|
||||||
((stringp obj)
|
|
||||||
(marshal-marshal-string driver obj))
|
|
||||||
((numberp obj)
|
|
||||||
(marshal-marshal-number driver obj))
|
|
||||||
((listp obj)
|
|
||||||
(marshal-marshal-list driver obj))
|
|
||||||
((ht? obj)
|
|
||||||
(marshal-marshal-hash driver obj)))))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun marshal (obj type)
|
|
||||||
(let ((driver (marshal-get-driver type)))
|
|
||||||
(marshal-postprocess driver
|
|
||||||
(marshal-internal obj type))))
|
|
||||||
|
|
||||||
(defmethod unmarshal--obj ((obj marshal-base) blob type)
|
|
||||||
(let ((driver (marshal-get-driver type))
|
|
||||||
(marshal-info (cdr (assoc type (marshal-get-marshal-info obj)))))
|
|
||||||
(marshal-open driver blob)
|
|
||||||
(when (and marshal-info blob)
|
|
||||||
(dolist (s (object-slots obj))
|
|
||||||
(let ((path (cdr (assoc s marshal-info))))
|
|
||||||
(when path
|
|
||||||
(eieio-oset obj s
|
|
||||||
(unmarshal-internal
|
|
||||||
(cdr (assoc s (marshal-get-type-info obj)))
|
|
||||||
(marshal-read driver path)
|
|
||||||
type))))))
|
|
||||||
(marshal-close driver)
|
|
||||||
obj))
|
|
||||||
|
|
||||||
(defun unmarshal-internal (obj blob type)
|
|
||||||
(let ((obj (if (class-p obj)
|
|
||||||
(make-instance obj)
|
|
||||||
obj)))
|
|
||||||
(unmarshal--internal obj blob type)))
|
|
||||||
|
|
||||||
(defmethod unmarshal--internal ((obj nil) blob type)
|
|
||||||
(let* ((driver (marshal-get-driver type))
|
|
||||||
(obj (or obj (marshal-guess-type driver blob))))
|
|
||||||
(cond ((or (null obj) (null blob))
|
|
||||||
(marshal-unmarshal-null driver))
|
|
||||||
((eq obj 'bool)
|
|
||||||
(marshal-unmarshal-bool driver blob))
|
|
||||||
((eq obj 'string)
|
|
||||||
(marshal-unmarshal-string driver blob))
|
|
||||||
((memq obj '(number integer))
|
|
||||||
(marshal-unmarshal-number driver blob))
|
|
||||||
((or (eq obj 'list)
|
|
||||||
(and (consp obj) (eq (car obj) 'list)))
|
|
||||||
(marshal-unmarshal-list driver blob obj))
|
|
||||||
((or (eq obj 'hash)
|
|
||||||
(and (consp obj) (eq (car obj) 'hash)))
|
|
||||||
(marshal-unmarshal-hash driver blob obj)))))
|
|
||||||
|
|
||||||
(defmethod unmarshal--internal ((obj marshal-base) blob type)
|
|
||||||
(let ((type (or (and (class-p type)
|
|
||||||
(car (rassoc type marshal-drivers)))
|
|
||||||
type)))
|
|
||||||
(unmarshal--obj obj blob type)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defun unmarshal (obj blob type)
|
|
||||||
(let ((driver (marshal-get-driver type)))
|
|
||||||
(unmarshal-internal obj (marshal-preprocess driver blob) type)))
|
|
||||||
|
|
||||||
;;;###autoload
|
|
||||||
(defmacro marshal-defclass (name superclass slots &rest options-and-doc)
|
|
||||||
(declare (debug t) (indent 2))
|
|
||||||
(let* ((options (if (stringp (car options-and-doc))
|
|
||||||
(cdr options-and-doc)
|
|
||||||
options-and-doc))
|
|
||||||
(default-spec-func (or (plist-get options :marshal-default-spec)
|
|
||||||
'ignore))
|
|
||||||
(base-cls (or (plist-get options :marshal-base-cls)
|
|
||||||
'marshal-base))
|
|
||||||
(marshal-info (marshal--transpose-alist2
|
|
||||||
(remove nil
|
|
||||||
(mapcar
|
|
||||||
(lambda (s)
|
|
||||||
(let ((name (car s)))
|
|
||||||
(let ((marshal
|
|
||||||
(or (plist-get (cdr s) :marshal)
|
|
||||||
(funcall default-spec-func name))))
|
|
||||||
(when marshal
|
|
||||||
(cons name
|
|
||||||
(mapcar
|
|
||||||
(lambda (p)
|
|
||||||
(if (consp p)
|
|
||||||
p
|
|
||||||
(cons p name)))
|
|
||||||
marshal))))))
|
|
||||||
slots))))
|
|
||||||
(type-info (remove nil
|
|
||||||
(mapcar (lambda (s)
|
|
||||||
(let ((name (car s)))
|
|
||||||
(let ((type (or (plist-get (cdr s) :marshal-type)
|
|
||||||
(plist-get (cdr s) :type))))
|
|
||||||
(when type
|
|
||||||
(cons name type)))))
|
|
||||||
slots))))
|
|
||||||
`(progn
|
|
||||||
(defclass ,name (,@superclass ,base-cls)
|
|
||||||
(,@slots)
|
|
||||||
,@options-and-doc)
|
|
||||||
|
|
||||||
(defmethod marshal-get-marshal-info :static ((obj ,name))
|
|
||||||
(let ((cls (if (eieio-object-p obj)
|
|
||||||
(eieio-object-class obj)
|
|
||||||
obj)))
|
|
||||||
(get cls :marshal-info)))
|
|
||||||
|
|
||||||
(put ',name :marshal-info ',marshal-info)
|
|
||||||
(dolist (cls ',superclass)
|
|
||||||
(put ',name :marshal-info
|
|
||||||
(marshal--alist-merge (get ',name :marshal-info)
|
|
||||||
(marshal-get-marshal-info cls) t)))
|
|
||||||
|
|
||||||
(defmethod marshal-get-type-info :static ((obj ,name))
|
|
||||||
(let ((cls (if (eieio-object-p obj)
|
|
||||||
(eieio-object-class obj)
|
|
||||||
obj)))
|
|
||||||
(get cls :type-info)))
|
|
||||||
|
|
||||||
(put ',name :type-info ',type-info)
|
|
||||||
(dolist (cls ',superclass)
|
|
||||||
(put ',name :type-info
|
|
||||||
(marshal--alist-merge (get ',name :type-info)
|
|
||||||
(marshal-get-type-info cls) t)))
|
|
||||||
|
|
||||||
,name)))
|
|
||||||
|
|
||||||
;;; Default drivers
|
|
||||||
(marshal-register-driver 'alist 'marshal-driver-alist)
|
|
||||||
(marshal-register-driver 'plist 'marshal-driver-plist)
|
|
||||||
(marshal-register-driver 'json 'marshal-driver-json)
|
|
||||||
|
|
||||||
(provide 'marshal)
|
|
||||||
;;; marshal.el ends here
|
|
||||||
@ -1,40 +0,0 @@
|
|||||||
2012-10-30 Stefan Monnier <monnier@iro.umontreal.ca>
|
|
||||||
|
|
||||||
Clean up copyright notices.
|
|
||||||
|
|
||||||
2011-07-30 Chong Yidong <cyd@stupidchicken.com>
|
|
||||||
|
|
||||||
Add Texinfo files for muse package.
|
|
||||||
|
|
||||||
2011-07-01 Chong Yidong <cyd@stupidchicken.com>
|
|
||||||
|
|
||||||
Remove version numbers from filenames in packages/ dir.
|
|
||||||
|
|
||||||
2011-06-30 Chong Yidong <cyd@stupidchicken.com>
|
|
||||||
|
|
||||||
Remove version numbers in packages/ directory
|
|
||||||
|
|
||||||
2011-01-09 Chong Yidong <cyd@stupidchicken.com>
|
|
||||||
|
|
||||||
Make Muse's *-link faces inherit from the basic link face.
|
|
||||||
|
|
||||||
* packages/muse-3.20/muse-colors.el (muse-link, muse-bad-link):
|
|
||||||
Inherit from link face.
|
|
||||||
|
|
||||||
2010-11-20 Ted Zlatanov <tzz@lifelogs.com>
|
|
||||||
|
|
||||||
* COPYING, ChangeLog, README, admin/org-synch.el,
|
|
||||||
admin/org-synch.sh, admin/package-update.sh: Initial import.
|
|
||||||
|
|
||||||
* packages/archive-contents, packages/auctex-11.86,
|
|
||||||
packages/auctex-readme.txt, packages/company-0.5/,
|
|
||||||
packages/company-readme.txt, packages/elpa.rss,
|
|
||||||
packages/js2-mode-20090814.el, packages/js2-mode-readme.txt,
|
|
||||||
packages/muse-3.20/, packages/muse-readme.txt,
|
|
||||||
packages/org-readme.txt, packages/rainbow-mode-0.1.el,
|
|
||||||
packages/rainbow-mode-readme.txt: Renamed from the root directory.
|
|
||||||
|
|
||||||
2010-11-18 ELPA admin
|
|
||||||
|
|
||||||
Initial repository contents
|
|
||||||
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
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, and Texinfo.
|
|
||||||
|
|
||||||
The markup rules used by Muse are intended to be very friendly to
|
|
||||||
people familiar with Emacs. See the included manual for more
|
|
||||||
information.
|
|
||||||
@ -1,217 +0,0 @@
|
|||||||
;;; cgi.el -- Using Emacs for CGI scripting
|
|
||||||
|
|
||||||
;; Copyright (C) 2000, 2006, 2012 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: Eric Marsden <emarsden@laas.fr>
|
|
||||||
;; Michael Olson <mwolson@gnu.org> (slight modifications)
|
|
||||||
;; Keywords: CGI web scripting slow
|
|
||||||
;; Version: 0.3
|
|
||||||
;; Time-stamp: <2001-08-24 emarsden>
|
|
||||||
|
|
||||||
;; 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, write to the Free
|
|
||||||
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
|
|
||||||
;; MA 02111-1307, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; People who like this sort of thing will find this the sort of
|
|
||||||
;; thing they like. -- Abraham Lincoln
|
|
||||||
;;
|
|
||||||
;;
|
|
||||||
;; Overview ==========================================================
|
|
||||||
;;
|
|
||||||
;; A simple library for the Common Gateway Interface for Emacs,
|
|
||||||
;; allowing you to service requests for non static web pages in elisp.
|
|
||||||
;; Provides routines for decoding arguments to GET- and POST-type CGI
|
|
||||||
;; requests.
|
|
||||||
;;
|
|
||||||
;; Usage: place a shell script such as the following in your web
|
|
||||||
;; server's CGI directory (typically called something like
|
|
||||||
;; /var/www/cgi-bin/):
|
|
||||||
;;
|
|
||||||
;; ,-------------------------------------------------------------------
|
|
||||||
;; | #!/bin/sh
|
|
||||||
;; |
|
|
||||||
;; | emacs -batch -l cgi.el -f cgi-calendar
|
|
||||||
;; `-------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; (`cgi-calendar' is a sample elisp CGI script provided at the end of
|
|
||||||
;; this file).
|
|
||||||
;;
|
|
||||||
;; Alternatively, if you're running version 2.x of the linux kernel
|
|
||||||
;; you could make .elc files directly executable via the binfmt_misc
|
|
||||||
;; mechanism and run them straight from the cgi-bin directory.
|
|
||||||
;;
|
|
||||||
;; Efficiency would be improved by having Emacs bind to the http
|
|
||||||
;; service port and spawn a thread per connection. Extending Emacs to
|
|
||||||
;; support server sockets and multithreading is left as an exercise
|
|
||||||
;; for the reader.
|
|
||||||
;;
|
|
||||||
;; References:
|
|
||||||
;; * rfc1738 "Uniform Resource Locators"
|
|
||||||
;; * rfc1630 "Universal Resource Identifiers in WWW"
|
|
||||||
;;
|
|
||||||
;; Thanks to Christoph Conrad <christoph.conrad@gmx.de> for pointing
|
|
||||||
;; out a bug in the URI-decoding.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(eval-when-compile
|
|
||||||
(require 'cl)
|
|
||||||
(require 'calendar))
|
|
||||||
|
|
||||||
(defconst cgi-url-unreserved-chars '(
|
|
||||||
?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m
|
|
||||||
?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
|
|
||||||
?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M
|
|
||||||
?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
|
|
||||||
?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
|
|
||||||
?\$ ?\- ?\_ ?\. ?\! ?\~ ?\* ?\' ?\( ?\) ?\,))
|
|
||||||
|
|
||||||
(defun cgi-int-char (i)
|
|
||||||
(if (fboundp 'int-char) (int-char i) i))
|
|
||||||
|
|
||||||
(defun cgi-hex-char-p (ch)
|
|
||||||
(declare (character ch))
|
|
||||||
(let ((hexchars '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
|
|
||||||
?A ?B ?C ?D ?E ?F)))
|
|
||||||
(member (upcase ch) hexchars)))
|
|
||||||
|
|
||||||
;; decode %xx to the corresponding character and + to ' '
|
|
||||||
(defun cgi-decode-string (str)
|
|
||||||
(do ((i 0)
|
|
||||||
(len (length str))
|
|
||||||
(decoded '()))
|
|
||||||
((>= i len) (concat (nreverse decoded)))
|
|
||||||
(let ((ch (aref str i)))
|
|
||||||
(cond ((eq ?+ ch)
|
|
||||||
(push ?\ decoded)
|
|
||||||
(incf i))
|
|
||||||
((and (eq ?% ch)
|
|
||||||
(< (+ i 2) len)
|
|
||||||
(cgi-hex-char-p (aref str (+ i 1)))
|
|
||||||
(cgi-hex-char-p (aref str (+ i 2))))
|
|
||||||
(let ((hex (string-to-number (substring str (+ i 1) (+ i 3)) 16)))
|
|
||||||
(push (cgi-int-char hex) decoded)
|
|
||||||
(incf i 3)))
|
|
||||||
(t (push ch decoded)
|
|
||||||
(incf i))))))
|
|
||||||
|
|
||||||
(defun cgi-position (item seq &optional start end)
|
|
||||||
(or start (setq start 0))
|
|
||||||
(or end (setq end (length seq)))
|
|
||||||
(while (and (< start end)
|
|
||||||
(not (equal item (aref seq start))))
|
|
||||||
(setq start (1+ start)))
|
|
||||||
(and (< start end) start))
|
|
||||||
|
|
||||||
;; Parse "foo=x&bar=y+re" into (("foo" . "x") ("bar" . "y re"))
|
|
||||||
;; Substrings are plus-decoded and then URI-decoded.
|
|
||||||
(defun cgi-decode (q)
|
|
||||||
(when q
|
|
||||||
(flet ((split-= (str)
|
|
||||||
(let ((pos (or (cgi-position ?= str) 0)))
|
|
||||||
(cons (cgi-decode-string (substring str 0 pos))
|
|
||||||
(cgi-decode-string (substring str (+ pos 1)))))))
|
|
||||||
(mapcar #'split-= (split-string q "&")))))
|
|
||||||
|
|
||||||
(defun cgi-lose (fmt &rest args)
|
|
||||||
(let ((why (apply #'format fmt args)))
|
|
||||||
(message "Script error: %s" why) ; to error_log
|
|
||||||
(princ "Content-type: text/html\n\n") ; to browser
|
|
||||||
(princ "<html><head><title>Script error</title></head>\r\n")
|
|
||||||
(princ "<body><h1>Script error</h1>\r\n<p>\r\n")
|
|
||||||
(princ why)
|
|
||||||
(princ "\r\n</body></html>\r\n")
|
|
||||||
(kill-emacs 0)))
|
|
||||||
|
|
||||||
(defmacro cgi-evaluate (&rest forms)
|
|
||||||
`(condition-case why
|
|
||||||
(princ (with-output-to-string ,@forms))
|
|
||||||
(error (cgi-lose "Emacs Lisp error: %s" why))))
|
|
||||||
|
|
||||||
(defun cgi-arguments ()
|
|
||||||
(let ((method (getenv "REQUEST_METHOD"))
|
|
||||||
req buf)
|
|
||||||
(cond ((null method)
|
|
||||||
(cgi-lose "No request method specified"))
|
|
||||||
((string= "GET" method)
|
|
||||||
(unless (getenv "QUERY_STRING")
|
|
||||||
(cgi-lose "No query string for GET request"))
|
|
||||||
(cgi-decode (getenv "QUERY_STRING")))
|
|
||||||
((string= "POST" method)
|
|
||||||
(setq req (getenv "CONTENT_LENGTH"))
|
|
||||||
(unless req
|
|
||||||
(cgi-lose "No content-length for POST request"))
|
|
||||||
(setq buf (get-buffer-create " *cgi*"))
|
|
||||||
(set-buffer buf)
|
|
||||||
(erase-buffer)
|
|
||||||
(loop for i from 1 to (string-to-number req)
|
|
||||||
do (insert (read-event)))
|
|
||||||
(cgi-decode (buffer-string)))
|
|
||||||
(t
|
|
||||||
(cgi-lose "Can't handle request method %s" method)))))
|
|
||||||
|
|
||||||
;; ====================================================================
|
|
||||||
;; a sample application: calendar via the web. If invoked without
|
|
||||||
;; arguments, presents a calendar for the three months around the
|
|
||||||
;; current date. You can request a calendar for a specific period by
|
|
||||||
;; specifying the year and the month in the query string:
|
|
||||||
;;
|
|
||||||
;; ~$ lynx -dump 'http://localhost/cgi-bin/cal?year=1975&month=6'
|
|
||||||
;;
|
|
||||||
;; When run in batch mode, text normally displayed in the echo area
|
|
||||||
;; (via `princ' for example) goes to stdout, and thus to the browser.
|
|
||||||
;; Text output using `message' goes to stderr, and thus normally to
|
|
||||||
;; your web server's error_log.
|
|
||||||
;; ====================================================================
|
|
||||||
|
|
||||||
(eval-and-compile
|
|
||||||
(if (fboundp 'calendar-extract-month)
|
|
||||||
(defalias 'cgi-calendar-extract-month 'calendar-extract-month)
|
|
||||||
(defalias 'cgi-calendar-extract-month 'extract-calendar-month))
|
|
||||||
|
|
||||||
(if (fboundp 'calendar-extract-year)
|
|
||||||
(defalias 'cgi-calendar-extract-year 'calendar-extract-year)
|
|
||||||
(defalias 'cgi-calendar-extract-year 'extract-calendar-year))
|
|
||||||
|
|
||||||
(if (fboundp 'calendar-generate)
|
|
||||||
(defalias 'cgi-calendar-generate 'calendar-generate)
|
|
||||||
(defalias 'cgi-calendar-generate 'generate-calendar)))
|
|
||||||
|
|
||||||
(defun cgi-calendar-string ()
|
|
||||||
(require 'calendar)
|
|
||||||
(let* ((args (cgi-arguments))
|
|
||||||
(now (calendar-current-date))
|
|
||||||
(mnth (cdr (assoc "month" args)))
|
|
||||||
(month (if mnth (string-to-number mnth)
|
|
||||||
(cgi-calendar-extract-month now)))
|
|
||||||
(yr (cdr (assoc "year" args)))
|
|
||||||
(year (if yr (string-to-number yr)
|
|
||||||
(cgi-calendar-extract-year now))))
|
|
||||||
(with-temp-buffer
|
|
||||||
(cgi-calendar-generate month year)
|
|
||||||
(buffer-string))))
|
|
||||||
|
|
||||||
(defun cgi-calendar ()
|
|
||||||
(cgi-evaluate
|
|
||||||
(princ "Content-type: text/html\n\n")
|
|
||||||
(princ "<html><head><title>Emacs calendar</title></head>\r\n")
|
|
||||||
(princ "<body> <h1>Emacs calendar</h1>\r\n")
|
|
||||||
(princ "<pre>\r\n")
|
|
||||||
(princ (cgi-calendar-string))
|
|
||||||
(princ "\r\n</pre></body></html>\r\n")))
|
|
||||||
|
|
||||||
(provide 'cgi)
|
|
||||||
;;; cgi.el ends here
|
|
||||||
@ -1,18 +0,0 @@
|
|||||||
This is the file .../info/dir, which contains the
|
|
||||||
topmost node of the Info hierarchy, called (dir)Top.
|
|
||||||
The first time you invoke Info you start off looking at this node.
|
|
||||||
|
|
||||||
File: dir, Node: Top This is the top of the INFO tree
|
|
||||||
|
|
||||||
This (the Directory node) gives a menu of major topics.
|
|
||||||
Typing "q" exits, "?" lists all Info commands, "d" returns here,
|
|
||||||
"h" gives a primer for first-timers,
|
|
||||||
"mEmacs<Return>" visits the Emacs manual, etc.
|
|
||||||
|
|
||||||
In Emacs, you can click mouse button 2 on a menu item or cross reference
|
|
||||||
to select it.
|
|
||||||
|
|
||||||
* Menu:
|
|
||||||
|
|
||||||
Emacs
|
|
||||||
* Muse: (muse). Authoring and publishing environment for Emacs.
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
;; This file provides a fix for htmlize.el and Emacs 23.
|
|
||||||
;; To use it, add the path to this directory to your load path and
|
|
||||||
;; add (require 'htmlize-hack) to your Emacs init file.
|
|
||||||
|
|
||||||
(require 'htmlize)
|
|
||||||
|
|
||||||
(when (equal htmlize-version "1.34")
|
|
||||||
(defun htmlize-face-size (face)
|
|
||||||
;; The size (height) of FACE, taking inheritance into account.
|
|
||||||
;; Only works in Emacs 21 and later.
|
|
||||||
(let ((size-list
|
|
||||||
(loop
|
|
||||||
for f = face then (face-attribute f :inherit)
|
|
||||||
until (or (null f) (eq f 'unspecified))
|
|
||||||
for h = (face-attribute f :height)
|
|
||||||
collect (if (eq h 'unspecified) nil h))))
|
|
||||||
(reduce 'htmlize-merge-size (cons nil size-list)))))
|
|
||||||
|
|
||||||
(provide 'htmlize-hack)
|
|
||||||
@ -1,288 +0,0 @@
|
|||||||
;;; httpd.el -- A web server in Emacs Lisp
|
|
||||||
|
|
||||||
;; Copyright (C) 2001, 2003, 2006, 2012 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: Eric Marsden <emarsden@laas.fr>
|
|
||||||
;; John Wiegley <johnw@gnu.org>
|
|
||||||
;; Michael Olson <mwolson@gnu.org> (slight modifications)
|
|
||||||
;; Version: 1.1
|
|
||||||
;; Keywords: games
|
|
||||||
|
|
||||||
;; 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, write to the Free
|
|
||||||
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
|
|
||||||
;; MA 02111-1307, USA.
|
|
||||||
;;
|
|
||||||
;; The latest version of this package should be available from
|
|
||||||
;;
|
|
||||||
;; <URL:http://purl.org/net/emarsden/home/downloads/>
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;; httpd.el is an HTTP server embedded in the Emacs. It can handle GET
|
|
||||||
;; and HEAD requests; adding support for POST should not be too
|
|
||||||
;; difficult. By default, httpd.el will listen on server side Emacs
|
|
||||||
;; sockets for HTTP requests.
|
|
||||||
;;
|
|
||||||
;; I have only tested this code with Emacs; it may need modifications
|
|
||||||
;; to work with XEmacs.
|
|
||||||
;;
|
|
||||||
;; This version has been modified to work with GNU Emacs 21 and 22.
|
|
||||||
;;
|
|
||||||
;;; Acknowledgements:
|
|
||||||
;;
|
|
||||||
;; httpd.el was inspired by pshttpd, an HTTP server written in
|
|
||||||
;; Postscript by Anders Karlsson <URL:http://www.pugo.org:8080/>.
|
|
||||||
;;
|
|
||||||
;; Thanks to John Wiegley and Cyprian Adam Laskowski.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(defvar httpd-document-root "/var/www")
|
|
||||||
|
|
||||||
(defvar httpd-path-handlers '()
|
|
||||||
"Alist of (path-regexp . handler) forms.
|
|
||||||
If a GET request is made for an URL whose path component matches
|
|
||||||
a PATH-REGEXP, the corresponding handler is called to generate
|
|
||||||
content.")
|
|
||||||
|
|
||||||
(defvar httpd-mime-types-alist
|
|
||||||
'(("html" . "text/html; charset=iso-8859-1")
|
|
||||||
("txt" . "text/plain; charset=iso-8859-1")
|
|
||||||
("jpg" . "image/jpeg")
|
|
||||||
("jpeg" . "image/jpeg")
|
|
||||||
("gif" . "image/gif")
|
|
||||||
("png" . "image/png")
|
|
||||||
("tif" . "image/tiff")
|
|
||||||
("tiff" . "image/tiff")
|
|
||||||
("css" . "text/css")
|
|
||||||
("gz" . "application/octet-stream")
|
|
||||||
("ps" . "application/postscript")
|
|
||||||
("pdf" . "application/pdf")
|
|
||||||
("eps" . "application/postscript")
|
|
||||||
("tar" . "application/x-tar")
|
|
||||||
("rpm" . "application/x-rpm")
|
|
||||||
("zip" . "application/zip")
|
|
||||||
("mp3" . "audio/mpeg")
|
|
||||||
("mp2" . "audio/mpeg")
|
|
||||||
("mid" . "audio/midi")
|
|
||||||
("midi" . "audio/midi")
|
|
||||||
("wav" . "audio/x-wav")
|
|
||||||
("au" . "audio/basic")
|
|
||||||
("ram" . "audio/pn-realaudio")
|
|
||||||
("ra" . "audio/x-realaudio")
|
|
||||||
("mpg" . "video/mpeg")
|
|
||||||
("mpeg" . "video/mpeg")
|
|
||||||
("qt" . "video/quicktime")
|
|
||||||
("mov" . "video/quicktime")
|
|
||||||
("avi" . "video/x-msvideo")))
|
|
||||||
|
|
||||||
(defun httpd-mime-type (filename)
|
|
||||||
(or (cdr (assoc (file-name-extension filename) httpd-mime-types-alist))
|
|
||||||
"text/plain"))
|
|
||||||
|
|
||||||
(put 'httpd-exception 'error-conditions '(httpd-exception error))
|
|
||||||
|
|
||||||
(defun defhttpd-exception (name code msg)
|
|
||||||
(put name 'error-conditions (list name 'httpd-exception 'error))
|
|
||||||
(put name 'httpd-code code)
|
|
||||||
(put name 'httpd-msg msg))
|
|
||||||
|
|
||||||
(defhttpd-exception 'httpd-moved/perm 301 "Moved permanently")
|
|
||||||
(defhttpd-exception 'httpd-moved/temp 302 "Moved temporarily")
|
|
||||||
(defhttpd-exception 'httpd-bad-request 400 "Bad request")
|
|
||||||
(defhttpd-exception 'httpd-forbidden 403 "Forbidden")
|
|
||||||
(defhttpd-exception 'httpd-file-not-found 404 "Not found")
|
|
||||||
(defhttpd-exception 'httpd-method-forbidden 405 "Method not allowed")
|
|
||||||
(defhttpd-exception 'httpd-unimplemented 500 "Internal server error")
|
|
||||||
(defhttpd-exception 'httpd-unimplemented 501 "Not implemented")
|
|
||||||
(defhttpd-exception 'httpd-unimplemented 503 "Service unavailable")
|
|
||||||
|
|
||||||
(defvar httpd-endl "\r\n")
|
|
||||||
|
|
||||||
(defvar httpd-process nil)
|
|
||||||
(defvar httpd-bytes-sent nil) ; only used with `httpd-process'
|
|
||||||
(defvar httpd-log-accesses t)
|
|
||||||
|
|
||||||
(defun httpd-add-handler (path-regexp handler)
|
|
||||||
(push (cons path-regexp handler) httpd-path-handlers))
|
|
||||||
|
|
||||||
(defun httpd-try-internal-handler (path &optional cont)
|
|
||||||
(catch 'result
|
|
||||||
(dolist (elem httpd-path-handlers)
|
|
||||||
(let ((regexp (car elem))
|
|
||||||
(handler (cdr elem)))
|
|
||||||
(if (string-match regexp path)
|
|
||||||
(throw 'result (funcall handler path cont)))))))
|
|
||||||
|
|
||||||
(defun httpd-date-stamp ()
|
|
||||||
(format-time-string "[%d/%b/%Y %H:%M:%S %z]"))
|
|
||||||
|
|
||||||
(defun httpd-log (&rest strings)
|
|
||||||
(if httpd-log-accesses
|
|
||||||
(save-excursion
|
|
||||||
(goto-char (point-max))
|
|
||||||
(with-current-buffer (get-buffer-create "*httpd access_log*")
|
|
||||||
(mapc 'insert strings)))))
|
|
||||||
|
|
||||||
(defun httpd-send-data (&rest strings)
|
|
||||||
(dolist (s strings)
|
|
||||||
(send-string httpd-process s)
|
|
||||||
(if httpd-bytes-sent
|
|
||||||
(setq httpd-bytes-sent (+ httpd-bytes-sent (length s))))))
|
|
||||||
|
|
||||||
(defun httpd-send (code msg &rest strings)
|
|
||||||
(httpd-log (number-to-string code) " ")
|
|
||||||
(apply 'httpd-send-data
|
|
||||||
"HTTP/1.0 " (number-to-string code) " " msg httpd-endl
|
|
||||||
strings))
|
|
||||||
|
|
||||||
(defun httpd-send-eof ()
|
|
||||||
(httpd-log (number-to-string httpd-bytes-sent) "\n")
|
|
||||||
(process-send-eof httpd-process))
|
|
||||||
|
|
||||||
(defun httpd-send-file (filename)
|
|
||||||
(with-temp-buffer
|
|
||||||
(insert-file-contents filename)
|
|
||||||
(httpd-send-data (buffer-string))))
|
|
||||||
|
|
||||||
(defun httpd-lose (code msg)
|
|
||||||
(httpd-send code msg
|
|
||||||
"Content-Type: text/html" httpd-endl
|
|
||||||
"Connection: close" httpd-endl
|
|
||||||
httpd-endl
|
|
||||||
"<html><head><title>Error</title></head>" httpd-endl
|
|
||||||
"<body><h1>" msg "</h1>" httpd-endl
|
|
||||||
"<p>" msg httpd-endl
|
|
||||||
"</body></html>" httpd-endl)
|
|
||||||
(httpd-send-eof))
|
|
||||||
|
|
||||||
(defun httpd-handle-redirect (req where)
|
|
||||||
"Redirect the client to new location WHERE."
|
|
||||||
(httpd-send 301 "Moved permanently"
|
|
||||||
"Location: " where httpd-endl
|
|
||||||
"URI: " where httpd-endl
|
|
||||||
"Connection: close" httpd-endl
|
|
||||||
httpd-endl)
|
|
||||||
(httpd-send-eof))
|
|
||||||
|
|
||||||
(defun httpd-handle-GET+HEAD (path &optional want-data req)
|
|
||||||
(if (zerop (length path))
|
|
||||||
(setq path "index.html"))
|
|
||||||
|
|
||||||
;; could use `expand-file-name' here instead of `concat', but we
|
|
||||||
;; don't want tilde expansion, etc.
|
|
||||||
(let ((filename (concat httpd-document-root "/" path))
|
|
||||||
modified-since)
|
|
||||||
(cond ((httpd-try-internal-handler path) t)
|
|
||||||
((file-directory-p filename)
|
|
||||||
(httpd-handle-redirect path (concat "http://" (system-name) "/"
|
|
||||||
path "/")))
|
|
||||||
((file-readable-p filename)
|
|
||||||
(let ((attrs (file-attributes filename)))
|
|
||||||
(if (and (string-match "^If-Modified-Since:\\s-+\\(.+\\)" req)
|
|
||||||
(setq modified-since
|
|
||||||
(apply 'encode-time
|
|
||||||
(parse-time-string (match-string 1 req))))
|
|
||||||
(time-less-p (nth 5 attrs) modified-since))
|
|
||||||
(httpd-send 304 "Not modified"
|
|
||||||
"Server: Emacs/httpd.el" httpd-endl
|
|
||||||
"Connection: close" httpd-endl
|
|
||||||
httpd-endl)
|
|
||||||
(httpd-send 200 "OK"
|
|
||||||
"Server: Emacs/httpd.el" httpd-endl
|
|
||||||
"Connection: close" httpd-endl
|
|
||||||
"MIME-Version: 1.0" httpd-endl
|
|
||||||
"Content-Type: "
|
|
||||||
(httpd-mime-type filename) httpd-endl
|
|
||||||
"Content-Length: "
|
|
||||||
(number-to-string (nth 7 attrs)) httpd-endl
|
|
||||||
httpd-endl)
|
|
||||||
(if want-data
|
|
||||||
(httpd-send-file filename)))
|
|
||||||
(httpd-send-eof)))
|
|
||||||
|
|
||||||
(t (signal 'httpd-file-not-found path)))))
|
|
||||||
|
|
||||||
(defun httpd-handle-request (req &optional cont)
|
|
||||||
(httpd-log (car (process-contact httpd-process)) " - - "
|
|
||||||
(httpd-date-stamp) " \"")
|
|
||||||
(if (not (string-match ".+" req))
|
|
||||||
(progn
|
|
||||||
(httpd-log "\"")
|
|
||||||
(error "HTTP request was empty"))
|
|
||||||
(let ((request (match-string 0 req)))
|
|
||||||
(httpd-log request "\" ")
|
|
||||||
(cond
|
|
||||||
((string-match "\\.\\." request)
|
|
||||||
;; reject requests containing ".." in the path. Should really
|
|
||||||
;; URI-decode first.
|
|
||||||
(signal 'httpd-forbidden request))
|
|
||||||
|
|
||||||
((string-match "\\`\\(GET\\|HEAD\\|POST\\)\\s-/\\(\\S-*\\)" request)
|
|
||||||
(let ((kind (match-string 1 request))
|
|
||||||
(arg (match-string 2 request)))
|
|
||||||
(if (string= kind "POST")
|
|
||||||
(unless (httpd-try-internal-handler arg cont)
|
|
||||||
(signal 'httpd-unimplemented arg))
|
|
||||||
(httpd-handle-GET+HEAD arg (string= kind "GET") req))))
|
|
||||||
|
|
||||||
(t (signal 'httpd-bad-request request))))))
|
|
||||||
|
|
||||||
(defun httpd-serve (proc string)
|
|
||||||
(let ((httpd-process proc)
|
|
||||||
(httpd-bytes-sent 0))
|
|
||||||
(condition-case why
|
|
||||||
(httpd-handle-request string)
|
|
||||||
(httpd-exception
|
|
||||||
(httpd-lose (get (car why) 'httpd-code)
|
|
||||||
(get (car why) 'httpd-msg)))
|
|
||||||
;; Comment out these two lines if you want to catch errors
|
|
||||||
;; inside Emacs itself.
|
|
||||||
(error
|
|
||||||
(httpd-lose 500 (format "Emacs Lisp error: %s" why)))
|
|
||||||
)))
|
|
||||||
|
|
||||||
(defun httpd-start (&optional port)
|
|
||||||
(interactive (list (read-string "Serve Web requests on port: " "8080")))
|
|
||||||
(if (null port)
|
|
||||||
(setq port 8080)
|
|
||||||
(if (stringp port)
|
|
||||||
(setq port (string-to-number port))))
|
|
||||||
(if httpd-process
|
|
||||||
(delete-process httpd-process))
|
|
||||||
(setq httpd-process
|
|
||||||
(if (fboundp 'make-network-process)
|
|
||||||
(make-network-process :name "httpd"
|
|
||||||
:buffer (generate-new-buffer "httpd")
|
|
||||||
:host 'local :service port
|
|
||||||
:server t :noquery t
|
|
||||||
:filter 'httpd-serve)
|
|
||||||
(and (fboundp 'open-network-stream-server)
|
|
||||||
(open-network-stream-server "httpd"
|
|
||||||
(generate-new-buffer "httpd")
|
|
||||||
port nil 'httpd-serve))))
|
|
||||||
(if (and (processp httpd-process)
|
|
||||||
(eq (process-status httpd-process) 'listen))
|
|
||||||
(message "httpd.el is listening on port %d" port)))
|
|
||||||
|
|
||||||
(defun httpd-stop ()
|
|
||||||
(interactive)
|
|
||||||
(when httpd-process
|
|
||||||
(message "httpd.el server on port %d has stopped"
|
|
||||||
(cadr (process-contact httpd-process)))
|
|
||||||
(delete-process httpd-process)
|
|
||||||
(setq httpd-process nil)))
|
|
||||||
|
|
||||||
(provide 'httpd)
|
|
||||||
;;; httpd.el ends here
|
|
||||||
@ -1,277 +0,0 @@
|
|||||||
;;; muse-autoloads.el --- automatically extracted autoloads
|
|
||||||
;;
|
|
||||||
;;; Code:
|
|
||||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
|
||||||
|
|
||||||
;;;### (autoloads nil "muse" "muse.el" (21705 22861 643843 136000))
|
|
||||||
;;; Generated autoloads from muse.el
|
|
||||||
(add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "muse-blosxom" "muse-blosxom.el" (21705 22862
|
|
||||||
;;;;;; 348828 281000))
|
|
||||||
;;; 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)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "muse-colors" "muse-colors.el" (21705 22862
|
|
||||||
;;;;;; 65834 245000))
|
|
||||||
;;; 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 nil "muse-import-docbook" "muse-import-docbook.el"
|
|
||||||
;;;;;; (21705 22862 962815 340000))
|
|
||||||
;;; 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 nil "muse-import-latex" "muse-import-latex.el"
|
|
||||||
;;;;;; (21705 22861 560844 887000))
|
|
||||||
;;; Generated autoloads from muse-import-latex.el
|
|
||||||
|
|
||||||
(autoload 'muse-import-latex "muse-import-latex" "\
|
|
||||||
|
|
||||||
|
|
||||||
\(fn)" t nil)
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;;;### (autoloads nil "muse-mode" "muse-mode.el" (21705 22863 3814
|
|
||||||
;;;;;; 476000))
|
|
||||||
;;; 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 nil "muse-project" "muse-project.el" (21705 22862
|
|
||||||
;;;;;; 680821 283000))
|
|
||||||
;;; 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 nil "muse-protocols" "muse-protocols.el" (21705
|
|
||||||
;;;;;; 22862 389827 417000))
|
|
||||||
;;; 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 nil "muse-publish" "muse-publish.el" (21705 22862
|
|
||||||
;;;;;; 730820 230000))
|
|
||||||
;;; 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 ("cgi.el" "htmlize-hack.el" "httpd.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-pkg.el" "muse-poem.el" "muse-regexps.el"
|
|
||||||
;;;;;; "muse-texinfo.el" "muse-wiki.el" "muse-xml-common.el" "muse-xml.el")
|
|
||||||
;;;;;; (21705 22863 153833 598000))
|
|
||||||
|
|
||||||
;;;***
|
|
||||||
|
|
||||||
;; Local Variables:
|
|
||||||
;; version-control: never
|
|
||||||
;; no-byte-compile: t
|
|
||||||
;; no-update-autoloads: t
|
|
||||||
;; End:
|
|
||||||
;;; muse-autoloads.el ends here
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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:
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,2 +0,0 @@
|
|||||||
(define-package "muse" "3.20"
|
|
||||||
"Authoring and publishing tool")
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -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
|
|
||||||
@ -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
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user