#+BEGIN_SRC emacs-lisp
;; (load-library "cfengine")
- (load-file (expand-file-name "~/.emacs.d/cfengine.el"))
+ (load-file (expand-file-name "~/.emacs.d/lisp/cfengine.el"))
(add-to-list 'auto-mode-alist '("\\.cf$" . cfengine3-mode))
;; post-commit and post-merge hook for git:
+++ /dev/null
-;;; cfengine-code-style.el --- C code style for CFEngine project.
-
-;; Author: Mikhail Gusarov <mikhail.gusarovNOSPAMcfengine.com>
-;; URL: https://github.com/cfengine/core
-
-;;; Commentary:
-
-;; Usage:
-;;
-;; To enable coding style for the current buffer:
-;;
-;; M-x c-set-style cfengine
-;;
-;; To enable coding style permanently, create file .dir-locals.el with the
-;; following contents in the directory with the source code:
-;;
-;; ((c-mode . ((c-file-style . "cfengine"))))
-;;
-
-;;
-;; TODO: special rule for C99 (Foo) { 1, 2, 3 } initializers.
-;; TODO: special rule for whitespace between if/while/for and paren.
-;;
-
-;;; Code:
-
-(defconst cfengine-c-style
- '(;; 4 spaces
- (c-basic-offset . 4)
- ;; Braces on new lines
- (c-hanging-braces-alist . ((substatement-open before after)
- (statement-cont)
- (brace-list-open)
- (brace-list-close)
- (brace-list-intro)
- (brace-entry-open)))
- ;; Newline after 'case' label
- (c-hanging-colons-alist . ((case-label after)))
- ;; Don't place comma on a separate line after array/aggregate
- (c-cleanup-list . (list-close-comma))
- ;; Indentation
- (c-offsets-alist . ((defun-open . 0)
- (defun-block-intro . +)
- (substatement-open . 0)
- (statement-cont . +))))
- "CFEngine Code Style")
-
-(c-add-style "CFEngine" cfengine-c-style)
-
-;;
-;; CFEngine uses CapitalizedWords for function names
-;;
-
-(defun cfengine-c-mode-hook ()
- (if (eq c-file-style "CFEngine")
- (progn
- (setq indent-tabs-mode nil)
- (setq c-tab-always-indent t)
- (setq tab-width 4)
- (subword-mode 1))))
-
-(add-hook 'c-mode-hook 'cfengine-c-mode-hook)
-
-(provide 'cfengine-code-style)
-
-;;; cfengine-code-style.el ends here
+++ /dev/null
-;;; cfengine.el --- mode for editing Cfengine files
-
-;; Copyright (C) 2001-2014 Free Software Foundation, Inc.
-
-;; Author: Dave Love <fxNOSPAMgnu.org>
-;; Maintainer: Ted Zlatanov <tzzNOSPAMlifelogs.com>
-;; Keywords: languages
-;; Version: 1.3
-
-;; This file is part of GNU Emacs, but has trivial compatibility
-;; modifications for Emacs versions before 24. Emacs 24 and newer
-;; includes this code and you should use that version. The following
-;; is the copyright notice from Emacs, which still applies to this
-;; code and all derivations thereof.
-
-;; 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:
-
-;; Provides support for editing GNU Cfengine files, including
-;; font-locking, Imenu and indentation, but with no special keybindings.
-
-;; By default, CFEngine 3.x syntax is used.
-
-;; You can set it up so either `cfengine2-mode' (2.x and earlier) or
-;; `cfengine3-mode' (3.x) will be picked, depending on the buffer
-;; contents:
-
-;; (add-to-list 'auto-mode-alist '("\\.cf\\'" . cfengine-auto-mode))
-
-;; OR you can choose to always use a specific version, if you prefer
-;; it:
-
-;; (add-to-list 'auto-mode-alist '("\\.cf\\'" . cfengine3-mode))
-;; (add-to-list 'auto-mode-alist '("^cf\\." . cfengine2-mode))
-;; (add-to-list 'auto-mode-alist '("^cfagent.conf\\'" . cfengine2-mode))
-
-;; It's *highly* recommended that you enable the eldoc minor mode:
-
-;; (add-hook 'cfengine3-mode-hook 'eldoc-mode)
-
-;; It's *highly* recommended that you use this mode with the latest
-;; Emacs, or at least 24.1.
-
-;; This is not the same as the mode written by Rolf Ebert
-;; <ebertNOSPAMwaporo.muc.de>, distributed with cfengine-2.0.5. It does
-;; better fontification and indentation, inter alia.
-
-;;; Code:
-
-;; Set up compatibility with Emacsen where prog-mode doesn't exist.
-(defalias 'cfengine-prog-mode (if (fboundp 'prog-mode)
- 'prog-mode
- 'fundamental-mode))
-
-;; `setq-local' was introduced in 24.3
-(eval-when-compile
- (or (fboundp 'setq-local)
- (defmacro setq-local (var val)
- `(set (make-local-variable ',var) ,val))))
-
-(autoload 'json-read "json")
-(autoload 'regexp-opt "regexp-opt")
-
-(defgroup cfengine ()
- "Editing CFEngine files."
- :group 'languages)
-
-(defcustom cfengine-indent 2
- "Size of a CFEngine indentation step in columns."
- :group 'cfengine
- :type 'integer)
-
-(defcustom cfengine-cf-promises
- (or (executable-find "cf-promises")
- (executable-find "/var/cfengine/bin/cf-promises")
- (executable-find "/usr/bin/cf-promises")
- (executable-find "/usr/sbin/cf-promises")
- (executable-find "/usr/local/bin/cf-promises")
- (executable-find "/usr/local/sbin/cf-promises")
- (executable-find "~/bin/cf-promises")
- (executable-find "~/sbin/cf-promises"))
- "The location of the cf-promises executable.
-Used for syntax discovery and checking. Set to nil to disable
-the `compile-command' override. In that case, the ElDoc support
-will use a fallback syntax definition."
- :version "24.4"
- :group 'cfengine
- :type '(choice file (const nil)))
-
-(defcustom cfengine-parameters-indent '(promise pname 0)
- "Indentation of CFEngine3 promise parameters (hanging indent).
-
-For example, say you have this code:
-
-bundle x y
-{
- section:
- class::
- promise ...
- promiseparameter => ...
-}
-
-You can choose to indent promiseparameter from the beginning of
-the line (absolutely) or from the word \"promise\" (relatively).
-
-You can also choose to indent the start of the word
-\"promiseparameter\" or the arrow that follows it.
-
-Finally, you can choose the amount of the indent.
-
-The default is to anchor at promise, indent parameter name, and offset 0:
-
-bundle agent rcfiles
-{
- files:
- any::
- \"/tmp/netrc\"
- comment => \"my netrc\",
- perms => mog(\"600\", \"tzz\", \"tzz\");
-}
-
-Here we anchor at beginning of line, indent arrow, and offset 10:
-
-bundle agent rcfiles
-{
- files:
- any::
- \"/tmp/netrc\"
- comment => \"my netrc\",
- perms => mog(\"600\", \"tzz\", \"tzz\");
-}
-
-Some, including cfengine_stdlib.cf, like to anchor at promise, indent
-arrow, and offset 16 or so:
-
-bundle agent rcfiles
-{
- files:
- any::
- \"/tmp/netrc\"
- comment => \"my netrc\",
- perms => mog(\"600\", \"tzz\", \"tzz\");
-}
-"
- :version "24.4"
- :group 'cfengine
- :type '(list
- (choice (const :tag "Anchor at beginning of promise" promise)
- (const :tag "Anchor at beginning of line" bol))
- (choice (const :tag "Indent parameter name" pname)
- (const :tag "Indent arrow" arrow))
- (integer :tag "Indentation amount from anchor")))
-
-(defvar cfengine-mode-debug nil
- "Whether `cfengine-mode' should print debugging info.")
-
-(defvar cfengine-mode-syntax-cache nil
- "Cache for `cfengine-mode' syntax trees obtained from 'cf-promises -s json'.")
-
-; Be sure to keep these two in sync with libpromises/cf3.defs.h
-(defconst cfengine3-uint-range "0,2147483647")
-(defconst cfengine3-sint-range "-2147483648,2147483647")
-
-(defconst cfengine3-fallback-syntax
- '((functions
- (userexists
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (usemodule
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (unique
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (translatepath
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (sum
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "real") (status . "normal"))
- (sublist
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "head,tail") (type . "option"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (strftime
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "gmtime,localtime") (type . "option"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (strcmp
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (splitstring
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (splayclass
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "daily,hourly") (type . "option"))])
- (returnType . "context") (status . "normal"))
- (sort
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "lex") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (some
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (shuffle
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (selectservers
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (reverse
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (rrange
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "-9.99999E100,9.99999E100") (type . "real"))
- ((range . "-9.99999E100,9.99999E100") (type . "real"))])
- (returnType . "rrange") (status . "normal"))
- (returnszero
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "useshell,noshell,powershell") (type . "option"))])
- (returnType . "context") (status . "normal"))
- (remoteclassesmatching
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "true,false,yes,no,on,off") (type . "option"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (remotescalar
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "true,false,yes,no,on,off") (type . "option"))])
- (returnType . "string") (status . "normal"))
- (regldap
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "subtree,onelevel,base") (type . "option"))
- ((range . ".*") (type . "string"))
- ((range . "none,ssl,sasl") (type . "option"))])
- (returnType . "context") (status . "normal"))
- (reglist
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (regline
- (category . "io") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (registryvalue
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (regextract
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (regcmp
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (regarray
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (readtcp
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (readstringlist
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (readstringarrayidx
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (readstringarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (readreallist
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "rlist") (status . "normal"))
- (readrealarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (readintlist
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "ilist") (status . "normal"))
- (readintarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (readfile
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (randomint
- (category . "data") (variadic . :json-false)
- (parameters . [((range . cfengine3-sint-range) (type . "int"))
- ((range . cfengine3-sint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (product
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "real") (status . "normal"))
- (peerleaders
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (peerleader
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (peers
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (parsestringarrayidx
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (parsestringarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (parserealarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (parseintarray
- (category . "io") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "int") (status . "normal"))
- (or
- (category . "data") (variadic . t)
- (parameters . [])
- (returnType . "string") (status . "normal"))
- (on
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "1970,3000") (type . "int"))
- ((range . "1,12") (type . "int"))
- ((range . "1,31") (type . "int"))
- ((range . "0,23") (type . "int"))
- ((range . "0,59") (type . "int"))
- ((range . "0,59") (type . "int"))])
- (returnType . "int") (status . "normal"))
- (nth
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (now
- (category . "system") (variadic . :json-false)
- (parameters . [])
- (returnType . "int") (status . "normal"))
- (not
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (none
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (maplist
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (maparray
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (lsdir
- (category . "files") (variadic . :json-false)
- (parameters . [((range . ".+") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "true,false,yes,no,on,off") (type . "option"))])
- (returnType . "slist") (status . "normal"))
- (length
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (ldapvalue
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "subtree,onelevel,base") (type . "option"))
- ((range . "none,ssl,sasl") (type . "option"))])
- (returnType . "string") (status . "normal"))
- (ldaplist
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "subtree,onelevel,base") (type . "option"))
- ((range . "none,ssl,sasl") (type . "option"))])
- (returnType . "slist") (status . "normal"))
- (ldaparray
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . "subtree,onelevel,base") (type . "option"))
- ((range . "none,ssl,sasl") (type . "option"))])
- (returnType . "context") (status . "normal"))
- (laterthan
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,40000") (type . "int"))])
- (returnType . "context") (status . "normal"))
- (lastnode
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (join
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (isvariable
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (isplain
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (isnewerthan
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (islink
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (islessthan
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (isgreaterthan
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (isexecutable
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (isdir
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (irange
- (category . "data") (variadic . :json-false)
- (parameters . [((range . cfengine3-sint-range) (type . "int"))
- ((range . cfengine3-sint-range) (type . "int"))])
- (returnType . "irange") (status . "normal"))
- (iprange
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (intersection
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (ifelse
- (category . "data") (variadic . t)
- (parameters . [])
- (returnType . "string") (status . "normal"))
- (hubknowledge
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (hostswithclass
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_]+") (type . "string"))
- ((range . "name,address") (type . "option"))])
- (returnType . "slist") (status . "normal"))
- (hostsseen
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . cfengine3-uint-range) (type . "int"))
- ((range . "lastseen,notseen") (type . "option"))
- ((range . "name,address") (type . "option"))])
- (returnType . "slist") (status . "normal"))
- (hostrange
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (hostinnetgroup
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (ip2host
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (host2ip
- (category . "communication") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (hashmatch
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "md5,sha1,crypt,cf_sha224,cf_sha256,cf_sha384,cf_sha512") (type . "option"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (hash
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "md5,sha1,sha256,sha512,sha384,crypt") (type . "option"))])
- (returnType . "string") (status . "normal"))
- (groupexists
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (grep
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (getvalues
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (getusers
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (getuid
- (category . "system") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (getindices
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (getgid
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (getfields
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))
- ((range . ".*") (type . "string"))
- ((range . ".*") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (getenv
- (category . "system") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "string") (status . "normal"))
- (format
- (category . "data") (variadic . t)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (filter
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "true,false,yes,no,on,off") (type . "option"))
- ((range . "true,false,yes,no,on,off") (type . "option"))
- ((range . cfengine3-uint-range) (type . "int"))])
- (returnType . "slist") (status . "normal"))
- (filestat
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "size,gid,uid,ino,nlink,ctime,atime,mtime,mode,modeoct,permstr,permoct,type,devno,dev_minor,dev_major,basename,dirname") (type . "option"))])
- (returnType . "string") (status . "normal"))
- (filesize
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (filesexist
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (fileexists
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (execresult
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".+") (type . "string"))
- ((range . "useshell,noshell,powershell") (type . "option"))])
- (returnType . "string") (status . "normal"))
- (every
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (escape
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (diskfree
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (dirname
- (category . "files") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (difference
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
- ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (countlinesmatching
- (category . "io") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (countclassesmatching
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "int") (status . "normal"))
- (classesmatching
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "slist") (status . "normal"))
- (classmatch
- (category . "utils") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (classify
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (changedbefore
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))
- (concat
- (category . "data") (variadic . t)
- (parameters . [])
- (returnType . "string") (status . "normal"))
- (canonify
- (category . "data") (variadic . :json-false)
- (parameters . [((range . ".*") (type . "string"))])
- (returnType . "string") (status . "normal"))
- (and
- (category . "data") (variadic . t)
- (parameters . [])
- (returnType . "string") (status . "normal"))
- (ago
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,40000") (type . "int"))])
- (returnType . "int") (status . "normal"))
- (accumulated
- (category . "data") (variadic . :json-false)
- (parameters . [((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,1000") (type . "int"))
- ((range . "0,40000") (type . "int"))])
- (returnType . "int") (status . "normal"))
- (accessedbefore
- (category . "files") (variadic . :json-false)
- (parameters . [((range . "\"?(/.*)") (type . "string"))
- ((range . "\"?(/.*)") (type . "string"))])
- (returnType . "context") (status . "normal"))))
- "Fallback CFEngine syntax, containing just function definitions.")
-
-(defvar cfengine-mode-syntax-functions-regex
- (regexp-opt (mapcar (lambda (def)
- (format "%s" (car def)))
- (cdr (assq 'functions cfengine3-fallback-syntax)))
- 'symbols))
-
-(defcustom cfengine-mode-abbrevs nil
- "Abbrevs for CFEngine2 mode."
- :group 'cfengine
- :type '(repeat (list (string :tag "Name")
- (string :tag "Expansion")
- (choice :tag "Hook" (const nil) function))))
-
-(make-obsolete-variable 'cfengine-mode-abbrevs 'edit-abbrevs "24.1")
-
-;; Taken from the doc for pre-release 2.1.
-(eval-and-compile
- (defconst cfengine2-actions
- '("acl" "alerts" "binservers" "broadcast" "control" "classes" "copy"
- "defaultroute" "disks" "directories" "disable" "editfiles" "files"
- "filters" "groups" "homeservers" "ignore" "import" "interfaces"
- "links" "mailserver" "methods" "miscmounts" "mountables"
- "processes" "packages" "rename" "required" "resolve"
- "shellcommands" "tidy" "unmount"
- ;; Keywords for cfservd.
- "admit" "grant" "deny")
- "List of the action keywords supported by Cfengine.
-This includes those for cfservd as well as cfagent.")
-
- (defconst cfengine3-defuns '("bundle" "body")
- "List of the CFEngine 3.x defun headings.")
-
- (defconst cfengine3-defuns-regex (regexp-opt cfengine3-defuns t)
- "Regex to match the CFEngine 3.x defuns.")
-
- (defconst cfengine3-defun-full-re (concat "^\\s-*" cfengine3-defuns-regex
- "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;type
- "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;id
- )
- "Regexp matching full defun declaration (excluding argument list).")
-
- (defconst cfengine3-class-selector-regex "\\([[:alnum:]_().&|!:]+\\)::")
-
- (defconst cfengine3-category-regex "\\([[:alnum:]_]+\\):")
-
- (defconst cfengine3-vartypes '("string" "int" "real" "slist" "ilist" "rlist"
- "irange" "rrange" "counter" "data")
- "List of the CFEngine 3.x variable types."))
-
-(defconst cfengine-font-lock-syntactic-keywords
- ;; In the main syntax-table, backslash is marked as a punctuation, because
- ;; of its use in DOS-style directory separators. Here we try to recognize
- ;; the cases where backslash is used as an escape inside strings.
- '(("\\(\\(?:\\\\\\)+\\)\"" 1 "\\")))
-
-(defvar cfengine2-font-lock-keywords
- `(;; Actions.
- ;; List the allowed actions explicitly, so that errors are more obvious.
- (,(concat "^[ \t]*" (eval-when-compile
- (regexp-opt cfengine2-actions t))
- ":")
- 1 font-lock-keyword-face)
- ;; Classes.
- ("^[ \t]*\\([[:alnum:]_().|!]+\\)::" 1 font-lock-function-name-face)
- ;; Variables.
- ("$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face)
- ("${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face)
- ;; Variable definitions.
- ("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
- ;; File, acl &c in group: { token ... }
- ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face)))
-
-(defvar cfengine3-font-lock-keywords
- `(
- ;; Defuns. This happens early so they don't get caught by looser
- ;; patterns.
- (,(concat "\\_<" cfengine3-defuns-regex "\\_>"
- "[ \t]+\\_<\\([[:alnum:]_.:]+\\)\\_>"
- "[ \t]+\\_<\\([[:alnum:]_.:]+\\)"
- ;; Optional parentheses with variable names inside.
- "\\(?:(\\([^)]*\\))\\)?")
- (1 font-lock-builtin-face)
- (2 font-lock-constant-face)
- (3 font-lock-function-name-face)
- (4 font-lock-variable-name-face nil t))
-
- ;; Class selectors.
- (,(concat "^[ \t]*" cfengine3-class-selector-regex)
- 1 font-lock-keyword-face)
-
- ;; Categories.
- (,(concat "^[ \t]*" cfengine3-category-regex)
- 1 font-lock-builtin-face)
-
- ;; Variables, including scope, e.g. module.var
- ("[@$](\\([[:alnum:]_.:]+\\))" 1 font-lock-variable-name-face)
- ("[@$]{\\([[:alnum:]_.:]+\\)}" 1 font-lock-variable-name-face)
-
- ;; Variable definitions.
- ("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
-
- ;; Variable types.
- (,(concat "\\_<" (eval-when-compile (regexp-opt cfengine3-vartypes t)) "\\_>")
- 1 font-lock-type-face)))
-
-(defvar cfengine2-imenu-expression
- `((nil ,(concat "^[ \t]*" (eval-when-compile
- (regexp-opt cfengine2-actions t))
- ":[^:]")
- 1)
- ("Variables/classes" "\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1)
- ("Variables/classes" "\\_<define=\\([[:alnum:]_]+\\)" 1)
- ("Variables/classes" "\\_<DefineClass\\>[ \t]+\\([[:alnum:]_]+\\)" 1))
- "`imenu-generic-expression' for CFEngine mode.")
-
-(defun cfengine2-outline-level ()
- "`outline-level' function for CFEngine mode."
- (if (looking-at "[^:]+\\(?:[:]+\\)$")
- (length (match-string 1))))
-
-(defun cfengine2-beginning-of-defun ()
- "`beginning-of-defun' function for CFEngine mode.
-Treats actions as defuns."
- (unless (<= (current-column) (current-indentation))
- (end-of-line))
- (if (re-search-backward "^[[:alpha:]]+: *$" nil t)
- (beginning-of-line)
- (goto-char (point-min)))
- t)
-
-(defun cfengine2-end-of-defun ()
- "`end-of-defun' function for CFEngine mode.
-Treats actions as defuns."
- (end-of-line)
- (if (re-search-forward "^[[:alpha:]]+: *$" nil t)
- (beginning-of-line)
- (goto-char (point-max)))
- t)
-
-;; Fixme: Should get an extra indent step in editfiles BeginGroup...s.
-
-(defun cfengine2-indent-line ()
- "Indent a line in Cfengine mode.
-Intended as the value of `indent-line-function'."
- (let ((pos (- (point-max) (point))))
- (save-restriction
- (narrow-to-defun)
- (back-to-indentation)
- (cond
- ;; Action selectors aren't indented; class selectors are
- ;; indented one step.
- ((looking-at "[[:alnum:]_().|!]+:\\(:\\)?")
- (if (match-string 1)
- (indent-line-to cfengine-indent)
- (indent-line-to 0)))
- ;; Outdent leading close brackets one step.
- ((or (eq ?\} (char-after))
- (eq ?\) (char-after)))
- (condition-case ()
- (indent-line-to (save-excursion
- (forward-char)
- (backward-sexp)
- (current-column)))
- (error nil)))
- ;; Inside brackets/parens: indent to start column of non-comment
- ;; token on line following open bracket or by one step from open
- ;; bracket's column.
- ((condition-case ()
- (progn (indent-line-to (save-excursion
- (backward-up-list)
- (forward-char)
- (skip-chars-forward " \t")
- (if (looking-at "[^\n#]")
- (current-column)
- (skip-chars-backward " \t")
- (+ (current-column) -1
- cfengine-indent))))
- t)
- (error nil)))
- ;; Indent by two steps after a class selector.
- ((save-excursion
- (re-search-backward "^[ \t]*[[:alnum:]_().|!]+::" nil t))
- (indent-line-to (* 2 cfengine-indent)))
- ;; Indent by one step if we're after an action header.
- ((save-excursion
- (goto-char (point-min))
- (looking-at "[[:alpha:]]+:[ \t]*$"))
- (indent-line-to cfengine-indent))
- ;; Else don't indent.
- (t
- (indent-line-to 0))))
- ;; If initial point was within line's indentation,
- ;; position after the indentation. Else stay at same point in text.
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos)))))
-
-;; This doesn't work too well in Emacs 21.2. See 22.1 development
-;; code.
-(defun cfengine-fill-paragraph (&optional justify)
- "Fill `paragraphs' in Cfengine code."
- (interactive "P")
- (or (if (fboundp 'fill-comment-paragraph)
- (fill-comment-paragraph justify) ; post Emacs 21.3
- ;; else do nothing in a comment
- (nth 4 (parse-partial-sexp (save-excursion
- (beginning-of-defun)
- (point))
- (point))))
- (let ((paragraph-start
- ;; Include start of parenthesized block.
- "\f\\|[ \t]*$\\|.*\(")
- (paragraph-separate
- ;; Include action and class lines, start and end of
- ;; bracketed blocks and end of parenthesized blocks to
- ;; avoid including these in fill. This isn't ideal.
- "[ \t\f]*$\\|.*#\\|.*[\){}]\\|\\s-*[[:alpha:]_().|!]+:")
- fill-paragraph-function)
- (fill-paragraph justify))
- t))
-
-(defun cfengine3-beginning-of-defun ()
- "`beginning-of-defun' function for Cfengine 3 mode.
-Treats body/bundle blocks as defuns."
- (unless (<= (current-column) (current-indentation))
- (end-of-line))
- (if (re-search-backward (concat "^[ \t]*" cfengine3-defuns-regex "\\_>") nil t)
- (beginning-of-line)
- (goto-char (point-min)))
- t)
-
-(defun cfengine3-end-of-defun ()
- "`end-of-defun' function for Cfengine 3 mode.
-Treats body/bundle blocks as defuns."
- (end-of-line)
- (if (re-search-forward (concat "^[ \t]*" cfengine3-defuns-regex "\\_>") nil t)
- (beginning-of-line)
- (goto-char (point-max)))
- t)
-
-(defun cfengine3-indent-line ()
- "Indent a line in Cfengine 3 mode.
-Intended as the value of `indent-line-function'."
- (let ((pos (- (point-max) (point)))
- parse)
- (save-restriction
- (narrow-to-defun)
- (back-to-indentation)
- (setq parse (parse-partial-sexp (point-min) (point)))
- (when cfengine-mode-debug
- (message "%S" parse))
-
- (cond
- ;; Body/bundle blocks start at 0.
- ((looking-at (concat cfengine3-defuns-regex "\\_>"))
- (indent-line-to 0))
- ;; Categories are indented one step.
- ((looking-at (concat cfengine3-category-regex "[ \t]*\\(#.*\\)*$"))
- (indent-line-to cfengine-indent))
- ;; Class selectors are indented two steps.
- ((looking-at (concat cfengine3-class-selector-regex "[ \t]*\\(#.*\\)*$"))
- (indent-line-to (* 2 cfengine-indent)))
- ;; Outdent leading close brackets one step.
- ((or (eq ?\} (char-after))
- (eq ?\) (char-after)))
- (condition-case ()
- (indent-line-to (save-excursion
- (forward-char)
- (backward-sexp)
- (move-beginning-of-line nil)
- (skip-chars-forward " \t")
- (current-column)))
- (error nil)))
- ;; Inside a string and it starts before this line: do nothing.
- ((and (nth 3 parse)
- (< (nth 8 parse) (save-excursion (beginning-of-line) (point))))
- )
-
- ;; Inside a defun, but not a nested list (depth is 1). This is
- ;; a promise, usually.
-
- ;; Indent to cfengine-indent times the nested depth
- ;; plus 2. That way, promises indent deeper than class
- ;; selectors, which in turn are one deeper than categories.
- ((= 1 (nth 0 parse))
- (let ((p-anchor (nth 0 cfengine-parameters-indent))
- (p-what (nth 1 cfengine-parameters-indent))
- (p-indent (nth 2 cfengine-parameters-indent)))
- ;; Do we have the parameter anchor and location and indent
- ;; defined, and are we looking at a promise parameter?
- (if (and p-anchor p-what p-indent
- (looking-at "\\([[:alnum:]_]+[ \t]*\\)=>"))
- (let* ((arrow-offset (* -1 (length (match-string 1))))
- (extra-offset (if (eq p-what 'arrow) arrow-offset 0))
- (base-offset (if (eq p-anchor 'promise)
- (* (+ 2 (nth 0 parse)) cfengine-indent)
- 0)))
- (indent-line-to (max 0 (+ p-indent base-offset extra-offset))))
- ;; Else, indent to cfengine-indent times the nested depth
- ;; plus 2. That way, promises indent deeper than class
- ;; selectors, which in turn are one deeper than categories.
- (indent-line-to (* (+ 2 (nth 0 parse)) cfengine-indent)))))
- ;; Inside brackets/parens: indent to start column of non-comment
- ;; token on line following open bracket or by one step from open
- ;; bracket's column.
- ((condition-case ()
- (progn (indent-line-to (save-excursion
- (backward-up-list)
- (forward-char)
- (skip-chars-forward " \t")
- (cond
- ((looking-at "[^\n#]")
- (current-column))
- ((looking-at "[^\n#]")
- (current-column))
- (t
- (skip-chars-backward " \t")
- (+ (current-column) -1
- cfengine-indent)))))
- t)
- (error nil)))
- ;; Else don't indent.
- (t (indent-line-to 0))))
- ;; If initial point was within line's indentation,
- ;; position after the indentation. Else stay at same point in text.
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos)))))
-
-;; CFEngine 3.x grammar
-
-;; specification: blocks
-;; blocks: block | blocks block;
-;; block: bundle typeid blockid bundlebody
-;; | bundle typeid blockid usearglist bundlebody
-;; | body typeid blockid bodybody
-;; | body typeid blockid usearglist bodybody;
-
-;; typeid: id
-;; blockid: id
-;; usearglist: '(' aitems ')';
-;; aitems: aitem | aitem ',' aitems |;
-;; aitem: id
-
-;; bundlebody: '{' statements '}'
-;; statements: statement | statements statement;
-;; statement: category | classpromises;
-
-;; bodybody: '{' bodyattribs '}'
-;; bodyattribs: bodyattrib | bodyattribs bodyattrib;
-;; bodyattrib: class | selections;
-;; selections: selection | selections selection;
-;; selection: id ASSIGN rval ';' ;
-
-;; classpromises: classpromise | classpromises classpromise;
-;; classpromise: class | promises;
-;; promises: promise | promises promise;
-;; category: CATEGORY
-;; promise: promiser ARROW rval constraints ';' | promiser constraints ';';
-;; constraints: constraint | constraints ',' constraint |;
-;; constraint: id ASSIGN rval;
-;; class: CLASS
-;; id: ID
-;; rval: ID | QSTRING | NAKEDVAR | list | usefunction
-;; list: '{' litems '}' ;
-;; litems: litem | litem ',' litems |;
-;; litem: ID | QSTRING | NAKEDVAR | list | usefunction
-
-;; functionid: ID | NAKEDVAR
-;; promiser: QSTRING
-;; usefunction: functionid givearglist
-;; givearglist: '(' gaitems ')'
-;; gaitems: gaitem | gaitems ',' gaitem |;
-;; gaitem: ID | QSTRING | NAKEDVAR | list | usefunction
-
-;; # from lexer:
-
-;; bundle: "bundle"
-;; body: "body"
-;; COMMENT #[^\n]*
-;; NAKEDVAR [$@][(][a-zA-Z0-9_\200-\377.]+[)]|[$@][{][a-zA-Z0-9_\200-\377.]+[}]
-;; ID: [a-zA-Z0-9_\200-\377]+
-;; ASSIGN: "=>"
-;; ARROW: "->"
-;; QSTRING: \"((\\\")|[^"])*\"|\'((\\\')|[^'])*\'|`[^`]*`
-;; CLASS: [.|&!()a-zA-Z0-9_\200-\377]+::
-;; CATEGORY: [a-zA-Z_]+:
-
-(defun cfengine3--current-function ()
- "Look up current CFEngine 3 function"
- (let* ((syntax (cfengine3-make-syntax-cache))
- (flist (assq 'functions syntax)))
- (when flist
- (let ((w (save-excursion
- (skip-syntax-forward "w_")
- (when (search-backward-regexp
- cfengine-mode-syntax-functions-regex
- (point-at-bol)
- t)
- (match-string 1)))))
- (and w (assq (intern w) flist))))))
-
-;; format from "cf-promises -s json", e.g. "sort" function:
-;; ((category . "data")
-;; (variadic . :json-false)
-;; (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
-;; ((range . "lex,int,real,IP,ip,MAC,mac") (type . "option"))])
-;; (returnType . "slist")
-;; (status . "normal"))
-
-(defun cfengine3-format-function-docstring (fdef)
- (let* ((f (format "%s" (car-safe fdef)))
- (def (cdr fdef))
- (rtype (cdr (assq 'returnType def)))
- (plist (cdr (assq 'parameters def)))
- (has-some-parameters (> (length plist) 0))
- (variadic (eq t (cdr (assq 'variadic def)))))
-
- ;; (format "[%S]%s %s(%s%s)" def
- (format "%s %s(%s%s)"
- (if rtype
- (propertize rtype 'face 'font-lock-variable-name-face)
- "???")
- (propertize f 'face 'font-lock-function-name-face)
- (mapconcat (lambda (p)
- (let ((type (cdr (assq 'type p)))
- (range (cdr (assq 'range p))))
- (cond
- ((not (stringp type)) "???type???")
- ((not (stringp range)) "???range???")
- ;; options are lists of possible keywords
- ((equal type "option")
- (propertize (concat "[" range "]")
- 'face
- 'font-lock-keyword-face))
- ;; anything else is a type name as a variable
- (t (propertize type
- 'face
- 'font-lock-variable-name-face)))))
- plist
- ", ")
- (if variadic
- (if has-some-parameters ", ..." "...")
- ""))))
-
-(defun cfengine3-clear-syntax-cache ()
- "Clear the internal syntax cache.
-Should not be necessary unless you reinstall CFEngine."
- (interactive)
- (setq cfengine-mode-syntax-functions-regex nil)
- (setq cfengine-mode-syntax-cache nil))
-
-(defun cfengine3-make-syntax-cache ()
- "Build the CFEngine 3 syntax cache and return the syntax.
-Calls `cfengine-cf-promises' with \"-s json\"."
- (or (cdr (assoc cfengine-cf-promises cfengine-mode-syntax-cache))
- (let ((syntax (or (when cfengine-cf-promises
- (with-demoted-errors "cfengine3-make-syntax-cache: %S"
- (with-temp-buffer
- (or (zerop (process-file cfengine-cf-promises
- nil ; no input
- t ; output
- nil ; no redisplay
- "-s" "json"))
- (error "%s" (buffer-substring
- (point-min)
- (progn (goto-char (point-min))
- (line-end-position)))))
- (goto-char (point-min))
- (json-read))))
- cfengine3-fallback-syntax)))
- (push (cons cfengine-cf-promises syntax)
- cfengine-mode-syntax-cache)
- (setq cfengine-mode-syntax-functions-regex
- (regexp-opt (mapcar (lambda (def)
- (format "%s" (car def)))
- (cdr (assq 'functions syntax)))
- 'symbols))
- syntax)))
-
-(defun cfengine3-documentation-function ()
- "Document CFengine 3 functions around point.
-Intended as the value of `eldoc-documentation-function', which see.
-Use it by enabling `eldoc-mode'."
- (let ((fdef (cfengine3--current-function)))
- (when fdef
- (cfengine3-format-function-docstring fdef))))
-
-(defun cfengine3-completion-function ()
- "Return completions for function name around or before point."
- (let* ((bounds (save-excursion
- (let ((p (point)))
- (skip-syntax-backward "w_" (point-at-bol))
- (list (point) p))))
- (syntax (cfengine3-make-syntax-cache))
- (flist (assq 'functions syntax)))
- (when bounds
- (append bounds (list (cdr flist))))))
-
-(defun cfengine-common-settings ()
- (if (fboundp 'syntax-propertize-rules)
- (set (make-local-variable 'syntax-propertize-function)
- ;; In the main syntax-table, \ is marked as a punctuation, because
- ;; of its use in DOS-style directory separators. Here we try to
- ;; recognize the cases where \ is used as an escape inside strings.
- (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\"))))
-
- ;; Backwards compatibility without `syntax-propertize-function'.
- (setq font-lock-defaults
- '(cfengine2-font-lock-keywords
- nil nil nil beginning-of-line
- (font-lock-syntactic-keywords
- . cfengine-font-lock-syntactic-keywords))))
-
- (set (make-local-variable 'parens-require-spaces) nil)
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
- ;; Like Lisp mode. Without this, we lose with, say,
- ;; `backward-up-list' when there's an unbalanced quote in a
- ;; preceding comment.
- (set (make-local-variable 'parse-sexp-ignore-comments) t))
-
-(defun cfengine-common-syntax (table)
- ;; The syntax defaults seem OK to give reasonable word movement.
- (modify-syntax-entry ?# "<" table)
- (modify-syntax-entry ?\n ">#" table)
- (modify-syntax-entry ?\" "\"" table) ; "string"
- (modify-syntax-entry ?\' "\"" table) ; 'string'
- ;; Variable substitution.
- (modify-syntax-entry ?$ "." table)
- ;; Doze path separators.
- (modify-syntax-entry ?\\ "." table))
-
-(defconst cfengine3--prettify-symbols-alist
- '(("->" . ?→)
- ("=>" . ?⇒)
- ("::" . ?∷)))
-
-(defun cfengine3-create-imenu-index ()
- "A function for `imenu-create-index-function'.
-Note: defun name is separated by space such as `body
-package_method opencsw' and imenu will replace spaces according
-to `imenu-space-replacement' (which see)."
- (goto-char (point-min))
- (let ((defuns ()))
- (while (re-search-forward cfengine3-defun-full-re nil t)
- (push (cons (mapconcat #'match-string '(1 2 3) " ")
- (copy-marker (match-beginning 3)))
- defuns))
- (nreverse defuns)))
-
-(defun cfengine3-current-defun ()
- "A function for `add-log-current-defun-function'."
- (end-of-line)
- (beginning-of-defun)
- (and (looking-at cfengine3-defun-full-re)
- (mapconcat #'match-string '(1 2 3) " ")))
-
-;;;###autoload
-(define-derived-mode cfengine3-mode cfengine-prog-mode "CFE3"
- "Major mode for editing CFEngine3 input.
-There are no special keybindings by default.
-
-Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
-to the action header."
- (cfengine-common-settings)
- (cfengine-common-syntax cfengine3-mode-syntax-table)
-
- (set (make-local-variable 'indent-line-function) #'cfengine3-indent-line)
-
- (setq font-lock-defaults
- '(cfengine3-font-lock-keywords
- nil nil nil beginning-of-defun))
- (setq-local prettify-symbols-alist cfengine3--prettify-symbols-alist)
-
- ;; `compile-command' is almost never a `make' call with CFEngine so
- ;; we override it
- (when cfengine-cf-promises
- (set (make-local-variable 'compile-command)
- (concat cfengine-cf-promises
- " -f "
- (when buffer-file-name
- (shell-quote-argument buffer-file-name)))))
-
- (setq-local flycheck-cfengine-executable cfengine-cf-promises)
-
- (setq-local eldoc-documentation-function #'cfengine3-documentation-function)
-
- (add-hook 'completion-at-point-functions
- #'cfengine3-completion-function nil t)
-
- ;; Use defuns as the essential syntax block.
- (setq-local beginning-of-defun-function #'cfengine3-beginning-of-defun)
- (setq-local end-of-defun-function #'cfengine3-end-of-defun)
-
- (setq-local imenu-create-index-function #'cfengine3-create-imenu-index)
- (setq-local add-log-current-defun-function #'cfengine3-current-defun))
-
-;;;###autoload
-(define-derived-mode cfengine2-mode cfengine-prog-mode "CFE2"
- "Major mode for editing CFEngine2 input.
-There are no special keybindings by default.
-
-Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
-to the action header."
- (cfengine-common-settings)
- (cfengine-common-syntax cfengine2-mode-syntax-table)
-
- ;; Shell commands can be quoted by single, double or back quotes.
- ;; It's debatable whether we should define string syntax, but it
- ;; should avoid potential confusion in some cases.
- (modify-syntax-entry ?\` "\"" cfengine2-mode-syntax-table)
-
- (set (make-local-variable 'indent-line-function) #'cfengine2-indent-line)
- (set (make-local-variable 'outline-regexp) "[ \t]*\\(\\sw\\|\\s_\\)+:+")
- (set (make-local-variable 'outline-level) #'cfengine2-outline-level)
- (set (make-local-variable 'fill-paragraph-function)
- #'cfengine-fill-paragraph)
- (define-abbrev-table 'cfengine-mode-abbrev-table cfengine2-mode-abbrevs)
- (setq font-lock-defaults
- '(cfengine2-font-lock-keywords nil nil nil beginning-of-line))
- ;; Fixme: set the args of functions in evaluated classes to string
- ;; syntax, and then obey syntax properties.
- (setq imenu-generic-expression cfengine2-imenu-expression)
- (set (make-local-variable 'beginning-of-defun-function)
- #'cfengine2-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function) #'cfengine2-end-of-defun))
-
-;;;###autoload
-(defun cfengine-auto-mode ()
- "Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents."
- (interactive)
- (if (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (forward-comment (point-max))
- (or (eobp)
- (re-search-forward
- (concat "^\\s-*" cfengine3-defuns-regex "\\_>") nil t))))
- (cfengine3-mode)
- (cfengine2-mode)))
-
-(defalias 'cfengine-mode 'cfengine3-mode)
-
-(provide 'cfengine3)
-(provide 'cfengine)
-
-;;; cfengine.el ends here
--- /dev/null
+;;; artbollocks-mode-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+
+\f
+;;;### (autoloads (artbollocks-mode) "artbollocks-mode" "artbollocks-mode.el"
+;;;;;; (21823 48772 0 0))
+;;; Generated autoloads from artbollocks-mode.el
+
+(autoload 'artbollocks-mode "artbollocks-mode" "\
+Highlight passive voice, weasel words and artbollocks jargon in text, and provide useful text metrics
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("artbollocks-mode-pkg.el") (21823 48772
+;;;;;; 360275 0))
+
+;;;***
+\f
+(provide 'artbollocks-mode-autoloads)
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; coding: utf-8
+;; End:
+;;; artbollocks-mode-autoloads.el ends here
--- /dev/null
+(define-package "artbollocks-mode" "20141212.1332" "Improve your writing (especially about art)" (quote nil))
--- /dev/null
+;;; artbollocks-mode.el --- Improve your writing (especially about art)
+;;
+;; Copyright (c) 2011,2012 Rob Myers <robNOSPAMrobmyers.org>
+;; Minor changes (c) 2012 Sacha Chua <sachaNOSPAMsachachua.com>
+;;
+;; Author: Rob Myers <robNOSPAMrobmyers.org>, Sacha Chua <sachaNOSPAMsachachua.com>
+;; URL: https://github.com/sachac/artbollocks-mode
+;; Package-Version: 20141212.1332
+;; Version: 1.1.2
+;;
+;; Based on fic-mode.el
+;; Copyright (C) 2010, Trey Jackson <bigfaceworm(at)gmail(dot)com>
+;;
+;; Non-artbollocks words from: http://matt.might.net/articles/
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero 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/>.
+;;
+;; 2012-06-16: Renamed functions and variables to avoid collisions.
+;; Incompatible changes, so please review your configuration. - Sacha
+;; Chua
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra thanks to:
+;; Brian van den Broek (words: contextuality, dialetic, problematize)
+;; Isabel Brison (words: alterity, mise en abîme)
+;; mneilsen, behaghel, russell, xfq, gleb, ejmr, tarsius (Emacs Lisp improvements)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Commentary:
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Usage
+;;
+;; To use, save artbollocks-mode.el to a directory in your load-path.
+;;
+;; (require 'artbollocks-mode)
+;; (add-hook 'text-mode-hook 'artbollocks-mode)
+;;
+;; or
+;;
+;; M-x artbollocks-mode
+;;
+;; NOTE: If you manually turn on artbollocks-mode,
+;; you you might need to force re-fontification initially:
+;;
+;; M-x font-lock-fontify-buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Code:
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Customization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Enable features individually
+
+(defcustom artbollocks-lexical-illusions t
+ "Whether to check for lexical illusions"
+ :type '(boolean)
+ :group 'artbollocks-mode)
+
+(defcustom artbollocks-passive-voice t
+ "Whether to check for passive voice"
+ :type '(boolean)
+ :group 'artbollocks-mode)
+
+(defcustom artbollocks-weasel-words t
+ "Whether to check for weasel words"
+ :type '(boolean)
+ :group 'artbollocks-mode)
+
+(defcustom artbollocks-jargon t
+ "Whether to check for artbollocks jargon"
+ :type '(boolean)
+ :group 'artbollocks-mode)
+
+(defface artbollocks-lexical-illusions-face
+ '((t (:foreground "black" :background "magenta")))
+ "The face for lexical illusions words"
+ :group 'artbollocks-mode)
+
+(defface artbollocks-passive-voice-face
+ '((t (:foreground "Gray" :background "White")))
+ "The face for passive voice words"
+ :group 'artbollocks-mode)
+
+(defface artbollocks-weasel-words-face
+ '((t (:foreground "Brown" :background "White")))
+ "The face for weasel-words words"
+ :group 'artbollocks-mode)
+
+(defface artbollocks-face
+ '((t (:foreground "Purple" :background "White")))
+ "The face for weasel-words words"
+ :group 'artbollocks-mode)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Lexical illusions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst artbollocks-lexical-illusions-regex "\\b\\(\\w+\\)\\W+\\(\\1\\)\\b")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Passive voice
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst artbollocks-passive-voice-regex "\\b\\(am\\|are\\|were\\|being\\|is\\|been\\|was\\|be\\)\\s-+\\(\\w+ed\\|awoken\\|been\\|born\\|beat\\|become\\|begun\\|bent\\|beset\\|bet\\|bid\\|bidden\\|bound\\|bitten\\|bled\\|blown\\|broken\\|bred\\|brought\\|broadcast\\|built\\|burnt\\|burst\\|bought\\|cast\\|caught\\|chosen\\|clung\\|come\\|cost\\|crept\\|cut\\|dealt\\|dug\\|dived\\|done\\|drawn\\|dreamt\\|driven\\|drunk\\|eaten\\|fallen\\|fed\\|felt\\|fought\\|found\\|fit\\|fled\\|flung\\\|wrung\\|written\\)\\b")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Weasel words
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst artbollocks-weasel-words-regex "\\b\\(many\\|various\\|very\\|fairly\\|several\\|extremely\\|exceedingly\\|quite\\|remarkably\\|few\\|surprisingly\\|mostly\\|largely\\|huge\\|tiny\\|\\(\\(are\\|is\\) a number\\)\\|excellent\\|interestingly\\|significantly\\|substantially\\|clearly\\|vast\\|relatively\\|completely\\)\\b")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Artbollocks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst artbollocks-jargon-regex "\\b\\(a priori\\|ad hoc\\|affirmation\\|affirm\\|affirms\\|alterity\\|altermodern\\|aporia\\|aporetic\\|appropriates\\|appropriation\\|archetypal\\|archetypical\\|archetype\\|archetypes\\|autonomous\\|autonomy\\|baudrillardian\\|baudrillarian\\|commodification\\|committed\\|commitment\\|commonalities\\|contemporaneity\\|context\\|contexts\\|contextual\\|contextualise\\|contextualises\\|contextualisation\\|contextialize\\|contextializes\\|contextualization\\|contextuality\\|convention\\|conventional\\|conventions\\|coterminous\\|critique\\|cunning\\|cunningly\\|death of the author\\|debunk\\|debunked\\|debunking\\|debunks\\|deconstruct\\|deconstruction\\|deconstructs\\|deleuzian\\|desire\\|desires\\|dialectic\\|dialectical\\|dialectically\\|discourse\\|discursive\\|disrupt\\|disrupts\\|engage\\|engagement\\|engages\\|episteme\\|epistemic\\|ergo\pular notions\\|position\\|post hoc\\|post internet\\|post-internet\\|postmodernism\\|postmodernist\\|postmodernity\\|postmodern\\|practice\\|practise\\|praxis\\|problematic\\|problematics\\|problematise\\|problematize\\|proposition\\|qua\\|reading\\|readings\\|reification\\|relation\\|relational\\|relationality\\|relations\\|representation\\|representations\\|rhizomatic\\|rhizome\\|simulacra\\|simulacral\\|simulation\\|simulationism\\|simulationism\\|situate\\|situated\\|situates\\|stereotype\\|stereotypes\\|strategy\\|strategies\\|subjective\\|subjectivity\\|subjectivities\\|subvert\\|subversion\\|subverts\\|text\\|textual\\|textuality\\|thinker\\|thinkers\\|trajectory\\|transgress\\|transgresses\\|transgression\\|transgressive\\|unfolding\\|undermine\\|undermining\\|undermines\\|work\\|works\\|wry\\|wryly\\|zizekian\\|zižekian\\)\\b")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Highlighting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun artbollocks-search-for-keyword (regex limit)
+ "Match REGEX in buffer until LIMIT."
+ (let (match-data-to-set
+ found)
+ (save-match-data
+ (while (and (null match-data-to-set)
+ (re-search-forward regex limit t))
+ (setq match-data-to-set (match-data))))
+ (when match-data-to-set
+ (set-match-data match-data-to-set)
+ (goto-char (match-end 0))
+ t)))
+
+(defun artbollocks-lexical-illusions-search-for-keyword (limit)
+ (artbollocks-search-for-keyword artbollocks-lexical-illusions-regex limit))
+
+(defun artbollocks-passive-voice-search-for-keyword (limit)
+ (artbollocks-search-for-keyword artbollocks-passive-voice-regex limit))
+
+(defun artbollocks-weasel-words-search-for-keyword (limit)
+ (artbollocks-search-for-keyword artbollocks-weasel-words-regex limit))
+
+(defun artbollocks-search-for-jargon (limit)
+ (artbollocks-search-for-keyword artbollocks-jargon-regex limit))
+
+(defconst artbollocks-lexicalkwlist
+ '((artbollocks-lexical-illusions-search-for-keyword
+ (2 'artbollocks-lexical-illusions-face t))))
+
+(defconst artbollocks-passivekwlist
+ '((artbollocks-passive-voice-search-for-keyword
+ (0 'artbollocks-passive-voice-face t))))
+
+(defconst artbollocks-weaselkwlist
+ '((artbollocks-weasel-words-search-for-keyword
+ (0 'artbollocks-weasel-words-face t))))
+
+(defconst artbollocks-kwlist
+ '((artbollocks-search-for-jargon
+ (0 'artbollocks-face t))))
+
+(defun artbollocks-add-keywords ()
+ (when artbollocks-lexical-illusions
+ (font-lock-add-keywords nil artbollocks-lexicalkwlist))
+ (when artbollocks-passive-voice
+ (font-lock-add-keywords nil artbollocks-passivekwlist))
+ (when artbollocks-weasel-words
+ (font-lock-add-keywords nil artbollocks-weaselkwlist))
+ (when artbollocks-jargon
+ (font-lock-add-keywords nil artbollocks-kwlist)))
+
+(defun artbollocks-remove-keywords ()
+ (font-lock-remove-keywords nil artbollocks-lexicalkwlist)
+ (font-lock-remove-keywords nil artbollocks-passivekwlist)
+ (font-lock-remove-keywords nil artbollocks-weaselkwlist)
+ (font-lock-remove-keywords nil artbollocks-kwlist))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utility macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro interactive-optional-region ()
+ "Flexible variation of (interactive \"r\").
+Bind START and END parameters to either a selected region or the
+entire buffer, subject to narrowing."
+ `(interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Text metrics
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun artbollocks-count-letters (&optional start end)
+ (how-many "\\w" (or start (point-min)) (or end (point-max))))
+
+(defun artbollocks-count-syllables (&optional start end)
+ ;; Naively count vowel runs as syllable markers
+ (how-many "[aeiouy]+" (or start (point-min)) (or end (point-max))))
+
+(defun artbollocks-count-words (&optional start end)
+ "Count the number of words between START and END."
+ (interactive-optional-region)
+ (let* ((s (or start (point-min)))
+ (e (or end (point-max)))
+ (result
+ (if (fboundp 'count-words)
+ (count-words s e)
+ (how-many "\\w+" s e))))
+ (if (called-interactively-p 'any)
+ (message "Word count: %s" result))
+ result))
+
+(defun artbollocks-count-sentences (&optional start end)
+ "Count the number of words between START and END."
+ (interactive-optional-region)
+ (let* ((s (or start (point-min)))
+ (e (or end (point-max)))
+ (result
+ (how-many "\\w[!?.]" s e)))
+ (if (called-interactively-p 'any)
+ (message "Sentence count: %s" result))
+ result))
+
+(defun artbollocks-automated-readability-index (&optional start end)
+ (let ((words (float (artbollocks-count-words start end)))
+ (letters (float (artbollocks-count-letters start end)))
+ (sentences (float (artbollocks-count-sentences start end))))
+ (if (and (> words 0) (> sentences 0))
+ (- (+ (* 4.71 (/ letters words))
+ (* 0.5 (/ words sentences)))
+ 21.43)
+ 0.0)))
+
+(defun artbollocks-flesch-reading-ease (&optional start end)
+ (let ((words (float (artbollocks-count-words start end)))
+ (sentences (float (artbollocks-count-sentences start end))))
+ (if (and (> sentences 0) (> words 0))
+ (- 206.834
+ (* 1.015 (/ words sentences))
+ (* 84.6 (/ syllables words)))
+ 0.0)))
+
+(defun artbollocks-flesch-kinkaid-grade-level (&optional start end)
+ (let ((words (float (artbollocks-count-words start end)))
+ (sentences (float (artbollocks-count-sentences start end)))
+ (syllables (float (artbollocks-count-syllables start end))))
+ (if (and (> words 0) (> sentences 0))
+ (- (+ (* 11.8 (/ syllables words))
+ (* 0.39 (/ words sentences)))
+ 15.59)
+ 0.0)))
+
+(defalias 'artbollocks-word-count 'artbollocks-count-words)
+(defalias 'artbollocks-sentence-count 'artbollocks-count-sentences)
+
+(defun artbollocks-readability-index (&optional start end)
+ "Determine the automated readability index between START and END."
+ (interactive-optional-region)
+ (message "Readability index: %s" (artbollocks-automated-readability-index start end)))
+
+(defun artbollocks-reading-ease (&optional start end)
+ "Determine the Flesch reading ease between START and END."
+ (interactive-optional-region)
+ (message "Reading ease: %s" (artbollocks-flesch-reading-ease start end)))
+
+(defun artbollocks-grade-level (&optional start end)
+ "Determine the Flesch-Kinkaid grade level between START and END."
+ (interactive-optional-region)
+ (message "Grade level: %s" (artbollocks-flesch-kinkaid-grade-level start end)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The mode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst artbollocks-mode-keymap (make-keymap))
+
+(define-key artbollocks-mode-keymap (kbd "C-c [") 'artbollocks-word-count)
+(define-key artbollocks-mode-keymap (kbd "C-c ]") 'artbollocks-sentence-count)
+(define-key artbollocks-mode-keymap (kbd "C-c \\") 'artbollocks-readability-index)
+(define-key artbollocks-mode-keymap (kbd "C-c /") 'artbollocks-reading-ease)
+(define-key artbollocks-mode-keymap (kbd "C-c =") 'artbollocks-grade-level)
+
+;;;###autoload
+(define-minor-mode artbollocks-mode "Highlight passive voice, weasel words and artbollocks jargon in text, and provide useful text metrics"
+ :lighter " AB"
+ :keymap artbollocks-mode-keymap
+ :group 'artbollocks-mode
+ (if artbollocks-mode
+ (artbollocks-add-keywords)
+ (artbollocks-remove-keywords)))
+
+(provide 'artbollocks-mode)
+
+;; TODO
+;; Toggle adding word/sentence count to status bar
+;; Pluralization
+;; Incorporate diction commands if available (and advise on installation if not)
+;; Split general writing back out
+
+;;; artbollocks-mode.el ends here
--- /dev/null
+Usage
+
+To use, save artbollocks-mode.el to a directory in your load-path.
+
+(require 'artbollocks-mode)
+(add-hook 'text-mode-hook 'artbollocks-mode)
+
+or
+
+M-x artbollocks-mode
+
+NOTE: If you manually turn on artbollocks-mode,
+you you might need to force re-fontification initially:
+
+ M-x font-lock-fontify-buffer
+++ /dev/null
-;;; package.el --- Simple package system for Emacs
-
-;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
-
-;; Author: Tom Tromey <tromeyNOSPAMredhat.com>
-;; Created: 10 Mar 2007
-;; Version: 1.0
-;; Keywords: tools
-;; Package-Requires: ((tabulated-list "0"))
-
-;; 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/>.
-
-;;; Change Log:
-
-;; 2 Apr 2007 - now using ChangeLog file
-;; 15 Mar 2007 - updated documentation
-;; 14 Mar 2007 - Changed how obsolete packages are handled
-;; 13 Mar 2007 - Wrote package-install-from-buffer
-;; 12 Mar 2007 - Wrote package-menu mode
-
-;;; Commentary:
-
-;; The idea behind package.el is to be able to download packages and
-;; install them. Packages are versioned and have versioned
-;; dependencies. Furthermore, this supports built-in packages which
-;; may or may not be newer than user-specified packages. This makes
-;; it possible to upgrade Emacs and automatically disable packages
-;; which have moved from external to core. (Note though that we don't
-;; currently register any of these, so this feature does not actually
-;; work.)
-
-;; A package is described by its name and version. The distribution
-;; format is either a tar file or a single .el file.
-
-;; A tar file should be named "NAME-VERSION.tar". The tar file must
-;; unpack into a directory named after the package and version:
-;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el"
-;; which consists of a call to define-package. It may also contain a
-;; "dir" file and the info files it references.
-
-;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
-;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
-
-;; The downloader downloads all dependent packages. By default,
-;; packages come from the official GNU sources, but others may be
-;; added by customizing the `package-archives' alist. Packages get
-;; byte-compiled at install time.
-
-;; At activation time we will set up the load-path and the info path,
-;; and we will load the package's autoloads. If a package's
-;; dependencies are not available, we will not activate that package.
-
-;; Conceptually a package has multiple state transitions:
-;;
-;; * Download. Fetching the package from ELPA.
-;; * Install. Untar the package, or write the .el file, into
-;; ~/.emacs.d/elpa/ directory.
-;; * Byte compile. Currently this phase is done during install,
-;; but we may change this.
-;; * Activate. Evaluate the autoloads for the package to make it
-;; available to the user.
-;; * Load. Actually load the package and run some code from it.
-
-;; Other external functions you may want to use:
-;;
-;; M-x list-packages
-;; Enters a mode similar to buffer-menu which lets you manage
-;; packages. You can choose packages for install (mark with "i",
-;; then "x" to execute) or deletion (not implemented yet), and you
-;; can see what packages are available. This will automatically
-;; fetch the latest list of packages from ELPA.
-;;
-;; M-x package-install-from-buffer
-;; Install a package consisting of a single .el file that appears
-;; in the current buffer. This only works for packages which
-;; define a Version header properly; package.el also supports the
-;; extension headers Package-Version (in case Version is an RCS id
-;; or similar), and Package-Requires (if the package requires other
-;; packages).
-;;
-;; M-x package-install-file
-;; Install a package from the indicated file. The package can be
-;; either a tar file or a .el file. A tar file must contain an
-;; appropriately-named "-pkg.el" file; a .el file must be properly
-;; formatted as with package-install-from-buffer.
-
-;;; Thanks:
-;;; (sorted by sort-lines):
-
-;; Jim Blandy <jimbNOSPAMred-bean.com>
-;; Karl Fogel <kfogelNOSPAMred-bean.com>
-;; Kevin Ryde <user42NOSPAMzip.com.au>
-;; Lawrence Mitchell
-;; Michael Olson <mwolsonNOSPAMmember.fsf.org>
-;; Sebastian Tennant <sebyteNOSPAMsmolny.plus.com>
-;; Stefan Monnier <monnierNOSPAMiro.umontreal.ca>
-;; Vinicius Jose Latorre <viniciusjlNOSPAMig.com.br>
-;; Phil Hagelberg <philNOSPAMhagelb.org>
-
-;;; ToDo:
-
-;; - a trust mechanism, since compiling a package can run arbitrary code.
-;; For example, download package signatures and check that they match.
-;; - putting info dirs at the start of the info path means
-;; users see a weird ordering of categories. OTOH we want to
-;; override later entries. maybe emacs needs to enforce
-;; the standard layout?
-;; - put bytecode in a separate directory tree
-;; - perhaps give users a way to recompile their bytecode
-;; or do it automatically when emacs changes
-;; - give users a way to know whether a package is installed ok
-;; - give users a way to view a package's documentation when it
-;; only appears in the .el
-;; - use/extend checkdoc so people can tell if their package will work
-;; - "installed" instead of a blank in the status column
-;; - tramp needs its files to be compiled in a certain order.
-;; how to handle this? fix tramp?
-;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22?
-;; - maybe we need separate .elc directories for various emacs versions
-;; and also emacs-vs-xemacs. That way conditional compilation can
-;; work. But would this break anything?
-;; - should store the package's keywords in archive-contents, then
-;; let the users filter the package-menu by keyword. See
-;; finder-by-keyword. (We could also let people view the
-;; Commentary, but it isn't clear how useful this is.)
-;; - William Xu suggests being able to open a package file without
-;; installing it
-;; - Interface with desktop.el so that restarting after an install
-;; works properly
-;; - Implement M-x package-upgrade, to upgrade any/all existing packages
-;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info
-;; ... except maybe lisp?
-;; - It may be nice to have a macro that expands to the package's
-;; private data dir, aka ".../etc". Or, maybe data-directory
-;; needs to be a list (though this would be less nice)
-;; a few packages want this, eg sokoban
-;; - package menu needs:
-;; ability to know which packages are built-in & thus not deletable
-;; it can sometimes print odd results, like 0.3 available but 0.4 active
-;; why is that?
-;; - Allow multiple versions on the server...?
-;; [ why bother? ]
-;; - Don't install a package which will invalidate dependencies overall
-;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5))
-;; [ currently thinking, why bother.. KISS ]
-;; - Allow optional package dependencies
-;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
-;; and just don't compile to add to load path ...?
-;; - Have a list of archive URLs? [ maybe there's no point ]
-;; - David Kastrup pointed out on the xemacs list that for GPL it
-;; is friendlier to ship the source tree. We could "support" that
-;; by just having a "src" subdir in the package. This isn't ideal
-;; but it probably is not worth trying to support random source
-;; tree layouts, build schemes, etc.
-;; - Our treatment of the info path is somewhat bogus
-;; - perhaps have an "unstable" tree in ELPA as well as a stable one
-
-;;; Code:
-
-(require 'tabulated-list)
-
-(defgroup package nil
- "Manager for Emacs Lisp packages."
- :group 'applications
- :version "24.1")
-
-;;;###autoload
-(defcustom package-enable-at-startup t
- "Whether to activate installed packages when Emacs starts.
-If non-nil, packages are activated after reading the init file
-and before `after-init-hook'. Activation is not done if
-`user-init-file' is nil (e.g. Emacs was started with \"-q\").
-
-Even if the value is nil, you can type \\[package-initialize] to
-activate the package system at any time."
- :type 'boolean
- :group 'package
- :version "24.1")
-
-(defcustom package-load-list '(all)
- "List of packages for `package-initialize' to load.
-Each element in this list should be a list (NAME VERSION), or the
-symbol `all'. The symbol `all' says to load the latest installed
-versions of all packages not specified by other elements.
-
-For an element (NAME VERSION), NAME is a package name (a symbol).
-VERSION should be t, a string, or nil.
-If VERSION is t, all versions are loaded, though obsolete ones
- will be put in `package-obsolete-alist' and not activated.
-If VERSION is a string, only that version is ever loaded.
- Any other version, even if newer, is silently ignored.
- Hence, the package is \"held\" at that version.
-If VERSION is nil, the package is not loaded (it is \"disabled\")."
- :type '(repeat symbol)
- :risky t
- :group 'package
- :version "24.1")
-
-(defvar Info-directory-list)
-(declare-function info-initialize "info" ())
-(declare-function url-http-parse-response "url-http" ())
-(declare-function lm-header "lisp-mnt" (header))
-(declare-function lm-commentary "lisp-mnt" (&optional file))
-(defvar url-http-end-of-headers)
-
-(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
- "An alist of archives from which to fetch.
-The default value points to the GNU Emacs package repository.
-
-Each element has the form (ID . LOCATION).
- ID is an archive name, as a string.
- LOCATION specifies the base location for the archive.
- If it starts with \"http:\", it is treated as a HTTP URL;
- otherwise it should be an absolute directory name.
- (Other types of URL are currently not supported.)
-
-Only add locations that you trust, since fetching and installing
-a package can run arbitrary code."
- :type '(alist :key-type (string :tag "Archive name")
- :value-type (string :tag "URL or directory name"))
- :risky t
- :group 'package
- :version "24.1")
-
-(defconst package-archive-version 1
- "Version number of the package archive understood by this file.
-Lower version numbers than this will probably be understood as well.")
-
-(defconst package-el-version "1.0"
- "Version of package.el.")
-
-;; We don't prime the cache since it tends to get out of date.
-(defvar package-archive-contents nil
- "Cache of the contents of the Emacs Lisp Package Archive.
-This is an alist mapping package names (symbols) to package
-descriptor vectors. These are like the vectors for `package-alist'
-but have extra entries: one which is 'tar for tar packages and
-'single for single-file packages, and one which is the name of
-the archive from which it came.")
-(put 'package-archive-contents 'risky-local-variable t)
-
-(defcustom package-user-dir (locate-user-emacs-file "elpa")
- "Directory containing the user's Emacs Lisp packages.
-The directory name should be absolute.
-Apart from this directory, Emacs also looks for system-wide
-packages in `package-directory-list'."
- :type 'directory
- :risky t
- :group 'package
- :version "24.1")
-
-(defcustom package-directory-list
- ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
- (let (result)
- (dolist (f load-path)
- (and (stringp f)
- (equal (file-name-nondirectory f) "site-lisp")
- (push (expand-file-name "elpa" f) result)))
- (nreverse result))
- "List of additional directories containing Emacs Lisp packages.
-Each directory name should be absolute.
-
-These directories contain packages intended for system-wide; in
-contrast, `package-user-dir' contains packages for personal use."
- :type '(repeat directory)
- :risky t
- :group 'package
- :version "24.1")
-
-;; The value is precomputed in finder-inf.el, but don't load that
-;; until it's needed (i.e. when `package-initialize' is called).
-(defvar package--builtins nil
- "Alist of built-in packages.
-The actual value is initialized by loading the library
-`finder-inf'; this is not done until it is needed, e.g. by the
-function `package-built-in-p'.
-
-Each element has the form (PKG . DESC), where PKG is a package
-name (a symbol) and DESC is a vector that describes the package.
-The vector DESC has the form [VERSION-LIST REQS DOCSTRING].
- VERSION-LIST is a version list.
- REQS is a list of packages required by the package, each
- requirement having the form (NAME VL), where NAME is a string
- and VL is a version list.
- DOCSTRING is a brief description of the package.")
-(put 'package--builtins 'risky-local-variable t)
-
-(defvar package-alist nil
- "Alist of all packages available for activation.
-Each element has the form (PKG . DESC), where PKG is a package
-name (a symbol) and DESC is a vector that describes the package.
-
-The vector DESC has the form [VERSION-LIST REQS DOCSTRING].
- VERSION-LIST is a version list.
- REQS is a list of packages required by the package, each
- requirement having the form (NAME VL) where NAME is a string
- and VL is a version list.
- DOCSTRING is a brief description of the package.
-
-This variable is set automatically by `package-load-descriptor',
-called via `package-initialize'. To change which packages are
-loaded and/or activated, customize `package-load-list'.")
-(put 'package-alist 'risky-local-variable t)
-
-(defvar package-activated-list nil
- "List of the names of currently activated packages.")
-(put 'package-activated-list 'risky-local-variable t)
-
-(defvar package-obsolete-alist nil
- "Representation of obsolete packages.
-Like `package-alist', but maps package name to a second alist.
-The inner alist is keyed by version.")
-(put 'package-obsolete-alist 'risky-local-variable t)
-
-(defun package-version-join (vlist)
- "Return the version string corresponding to the list VLIST.
-This is, approximately, the inverse of `version-to-list'.
-\(Actually, it returns only one of the possible inverses, since
-`version-to-list' is a many-to-one operation.)"
- (if (null vlist)
- ""
- (let ((str-list (list "." (int-to-string (car vlist)))))
- (dolist (num (cdr vlist))
- (cond
- ((>= num 0)
- (push (int-to-string num) str-list)
- (push "." str-list))
- ((< num -3)
- (error "Invalid version list `%s'" vlist))
- (t
- ;; pre, or beta, or alpha
- (cond ((equal "." (car str-list))
- (pop str-list))
- ((not (string-match "[0-9]+" (car str-list)))
- (error "Invalid version list `%s'" vlist)))
- (push (cond ((= num -1) "pre")
- ((= num -2) "beta")
- ((= num -3) "alpha"))
- str-list))))
- (if (equal "." (car str-list))
- (pop str-list))
- (apply 'concat (nreverse str-list)))))
-
-(defun package-strip-version (dirname)
- "Strip the version from a combined package name and version.
-E.g., if given \"quux-23.0\", will return \"quux\""
- (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
- (match-string 1 dirname)))
-
-(defun package-load-descriptor (dir package)
- "Load the description file in directory DIR for package PACKAGE.
-Here, PACKAGE is a string of the form NAME-VERSION, where NAME is
-the package name and VERSION is its version."
- (let* ((pkg-dir (expand-file-name package dir))
- (pkg-file (expand-file-name
- (concat (package-strip-version package) "-pkg")
- pkg-dir)))
- (when (and (file-directory-p pkg-dir)
- (file-exists-p (concat pkg-file ".el")))
- (load pkg-file nil t))))
-
-(defun package-load-all-descriptors ()
- "Load descriptors for installed Emacs Lisp packages.
-This looks for package subdirectories in `package-user-dir' and
-`package-directory-list'. The variable `package-load-list'
-controls which package subdirectories may be loaded.
-
-In each valid package subdirectory, this function loads the
-description file containing a call to `define-package', which
-updates `package-alist' and `package-obsolete-alist'."
- (let ((regexp (concat "\\`" package-subdirectory-regexp "\\'")))
- (dolist (dir (cons package-user-dir package-directory-list))
- (when (file-directory-p dir)
- (dolist (subdir (directory-files dir))
- (when (string-match regexp subdir)
- (package-maybe-load-descriptor (match-string 1 subdir)
- (match-string 2 subdir)
- dir)))))))
-
-(defun package-maybe-load-descriptor (name version dir)
- "Maybe load a specific package from directory DIR.
-NAME and VERSION are the package's name and version strings.
-This function checks `package-load-list', before actually loading
-the package by calling `package-load-descriptor'."
- (let ((force (assq (intern name) package-load-list))
- (subdir (concat name "-" version)))
- (and (file-directory-p (expand-file-name subdir dir))
- ;; Check `package-load-list':
- (cond ((null force)
- (memq 'all package-load-list))
- ((null (setq force (cadr force)))
- nil) ; disabled
- ((eq force t)
- t)
- ((stringp force) ; held
- (version-list-= (version-to-list version)
- (version-to-list force)))
- (t
- (error "Invalid element in `package-load-list'")))
- ;; Actually load the descriptor:
- (package-load-descriptor dir subdir))))
-
-(defsubst package-desc-vers (desc)
- "Extract version from a package description vector."
- (aref desc 0))
-
-(defsubst package-desc-reqs (desc)
- "Extract requirements from a package description vector."
- (aref desc 1))
-
-(defsubst package-desc-doc (desc)
- "Extract doc string from a package description vector."
- (aref desc 2))
-
-(defsubst package-desc-kind (desc)
- "Extract the kind of download from an archive package description vector."
- (aref desc 3))
-
-(defun package--dir (name version)
- "Return the directory where a package is installed, or nil if none.
-NAME and VERSION are both strings."
- (let* ((subdir (concat name "-" version))
- (dir-list (cons package-user-dir package-directory-list))
- pkg-dir)
- (while dir-list
- (let ((subdir-full (expand-file-name subdir (car dir-list))))
- (if (file-directory-p subdir-full)
- (setq pkg-dir subdir-full
- dir-list nil)
- (setq dir-list (cdr dir-list)))))
- pkg-dir))
-
-(defun package-activate-1 (package pkg-vec)
- (let* ((name (symbol-name package))
- (version-str (package-version-join (package-desc-vers pkg-vec)))
- (pkg-dir (package--dir name version-str)))
- (unless pkg-dir
- (error "Internal error: unable to find directory for `%s-%s'"
- name version-str))
- ;; Add info node.
- (when (file-exists-p (expand-file-name "dir" pkg-dir))
- ;; FIXME: not the friendliest, but simple.
- (require 'info)
- (info-initialize)
- (push pkg-dir Info-directory-list))
- ;; Add to load path, add autoloads, and activate the package.
- (push pkg-dir load-path)
- (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
- (push package package-activated-list)
- ;; Don't return nil.
- t))
-
-(defun package-built-in-p (package &optional min-version)
- "Return true if PACKAGE is built-in to Emacs.
-Optional arg MIN-VERSION, if non-nil, should be a version list
-specifying the minimum acceptable version."
- (require 'finder-inf nil t) ; For `package--builtins'.
- (if (eq package 'emacs)
- (version-list-<= min-version (version-to-list emacs-version))
- (let ((elt (assq package package--builtins)))
- (and elt (version-list-<= min-version
- (package-desc-vers (cdr elt)))))))
-
-;; This function goes ahead and activates a newer version of a package
-;; if an older one was already activated. This is not ideal; we'd at
-;; least need to check to see if the package has actually been loaded,
-;; and not merely activated.
-(defun package-activate (package min-version)
- "Activate package PACKAGE, of version MIN-VERSION or newer.
-MIN-VERSION should be a version list.
-If PACKAGE has any dependencies, recursively activate them.
-Return nil if the package could not be activated."
- (let ((pkg-vec (cdr (assq package package-alist)))
- available-version found)
- ;; Check if PACKAGE is available in `package-alist'.
- (when pkg-vec
- (setq available-version (package-desc-vers pkg-vec)
- found (version-list-<= min-version available-version)))
- (cond
- ;; If no such package is found, maybe it's built-in.
- ((null found)
- (package-built-in-p package min-version))
- ;; If the package is already activated, just return t.
- ((memq package package-activated-list)
- t)
- ;; Otherwise, proceed with activation.
- (t
- (let ((fail (catch 'dep-failure
- ;; Activate its dependencies recursively.
- (dolist (req (package-desc-reqs pkg-vec))
- (unless (package-activate (car req) (cadr req))
- (throw 'dep-failure req))))))
- (if fail
- (warn "Unable to activate package `%s'.
-Required package `%s-%s' is unavailable"
- package (car fail) (package-version-join (cadr fail)))
- ;; If all goes well, activate the package itself.
- (package-activate-1 package pkg-vec)))))))
-
-(defun package-mark-obsolete (package pkg-vec)
- "Put package on the obsolete list, if not already there."
- (let ((elt (assq package package-obsolete-alist)))
- (if elt
- ;; If this obsolete version does not exist in the list, update
- ;; it the list.
- (unless (assoc (package-desc-vers pkg-vec) (cdr elt))
- (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec)
- (cdr elt))))
- ;; Make a new association.
- (push (cons package (list (cons (package-desc-vers pkg-vec)
- pkg-vec)))
- package-obsolete-alist))))
-
-(defun define-package (name-string version-string
- &optional docstring requirements
- &rest _extra-properties)
- "Define a new package.
-NAME-STRING is the name of the package, as a string.
-VERSION-STRING is the version of the package, as a string.
-DOCSTRING is a short description of the package, a string.
-REQUIREMENTS is a list of dependencies on other packages.
- Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
- where OTHER-VERSION is a string.
-
-EXTRA-PROPERTIES is currently unused."
- (let* ((name (intern name-string))
- (version (version-to-list version-string))
- (new-pkg-desc
- (cons name
- (vector version
- (mapcar
- (lambda (elt)
- (list (car elt)
- (version-to-list (car (cdr elt)))))
- requirements)
- docstring)))
- (old-pkg (assq name package-alist)))
- (cond
- ;; If there's no old package, just add this to `package-alist'.
- ((null old-pkg)
- (push new-pkg-desc package-alist))
- ((version-list-< (package-desc-vers (cdr old-pkg)) version)
- ;; Remove the old package and declare it obsolete.
- (package-mark-obsolete name (cdr old-pkg))
- (setq package-alist (cons new-pkg-desc
- (delq old-pkg package-alist))))
- ;; You can have two packages with the same version, e.g. one in
- ;; the system package directory and one in your private
- ;; directory. We just let the first one win.
- ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
- ;; The package is born obsolete.
- (package-mark-obsolete name (cdr new-pkg-desc))))))
-
-;; From Emacs 22.
-(defun package-autoload-ensure-default-file (file)
- "Make sure that the autoload file FILE exists and if not create it."
- (unless (file-exists-p file)
- (write-region
- (concat ";;; " (file-name-nondirectory file)
- " --- automatically extracted autoloads\n"
- ";;\n"
- ";;; Code:\n\n"
- "\f\n;; Local Variables:\n"
- ";; version-control: never\n"
- ";; no-byte-compile: t\n"
- ";; no-update-autoloads: t\n"
- ";; End:\n"
- ";;; " (file-name-nondirectory file)
- " ends here\n")
- nil file))
- file)
-
-(defun package-generate-autoloads (name pkg-dir)
- (require 'autoload) ;Load before we let-bind generated-autoload-file!
- (let* ((auto-name (concat name "-autoloads.el"))
- ;;(ignore-name (concat name "-pkg.el"))
- (generated-autoload-file (expand-file-name auto-name pkg-dir))
- (version-control 'never))
- (unless (fboundp 'autoload-ensure-default-file)
- (package-autoload-ensure-default-file generated-autoload-file))
- (update-directory-autoloads pkg-dir)
- (let ((buf (find-buffer-visiting generated-autoload-file)))
- (when buf (kill-buffer buf)))))
-
-(defvar tar-parse-info)
-(declare-function tar-untar-buffer "tar-mode" ())
-(declare-function tar-header-name "tar-mode" (tar-header))
-(declare-function tar-header-link-type "tar-mode" (tar-header))
-
-(defun package-untar-buffer (dir)
- "Untar the current buffer.
-This uses `tar-untar-buffer' from Tar mode. All files should
-untar into a directory named DIR; otherwise, signal an error."
- (require 'tar-mode)
- (tar-mode)
- ;; Make sure everything extracts into DIR.
- (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
- (case-fold-search (memq system-type '(windows-nt ms-dos cygwin))))
- (dolist (tar-data tar-parse-info)
- (let ((name (expand-file-name (tar-header-name tar-data))))
- (or (string-match regexp name)
- ;; Tarballs created by some utilities don't list
- ;; directories with a trailing slash (Bug#13136).
- (and (string-equal dir name)
- (eq (tar-header-link-type tar-data) 5))
- (error "Package does not untar cleanly into directory %s/" dir)))))
- (tar-untar-buffer))
-
-(defun package-unpack (package version)
- (let* ((name (symbol-name package))
- (dirname (concat name "-" version))
- (pkg-dir (expand-file-name dirname package-user-dir)))
- (make-directory package-user-dir t)
- ;; FIXME: should we delete PKG-DIR if it exists?
- (let* ((default-directory (file-name-as-directory package-user-dir)))
- (package-untar-buffer dirname)
- (package--make-autoloads-and-compile name pkg-dir))))
-
-(defun package--make-autoloads-and-compile (name pkg-dir)
- "Generate autoloads and do byte-compilation for package named NAME.
-PKG-DIR is the name of the package directory."
- (package-generate-autoloads name pkg-dir)
- (let ((load-path (cons pkg-dir load-path)))
- ;; We must load the autoloads file before byte compiling, in
- ;; case there are magic cookies to set up non-trivial paths.
- (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
- (byte-recompile-directory pkg-dir 0 t)))
-
-(defun package--write-file-no-coding (file-name)
- (let ((buffer-file-coding-system 'no-conversion))
- (write-region (point-min) (point-max) file-name)))
-
-(defun package-unpack-single (file-name version desc requires)
- "Install the contents of the current buffer as a package."
- ;; Special case "package".
- (if (string= file-name "package")
- (package--write-file-no-coding
- (expand-file-name (concat file-name ".el") package-user-dir))
- (let* ((pkg-dir (expand-file-name (concat file-name "-"
- (package-version-join
- (version-to-list version)))
- package-user-dir))
- (el-file (expand-file-name (concat file-name ".el") pkg-dir))
- (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
- (make-directory pkg-dir t)
- (package--write-file-no-coding el-file)
- (let ((print-level nil)
- (print-length nil))
- (write-region
- (concat
- (prin1-to-string
- (list 'define-package
- file-name
- version
- desc
- (list 'quote
- ;; Turn version lists into string form.
- (mapcar
- (lambda (elt)
- (list (car elt)
- (package-version-join (cadr elt))))
- requires))))
- "\n")
- nil
- pkg-file
- nil nil nil 'excl))
- (package--make-autoloads-and-compile file-name pkg-dir))))
-
-(defmacro package--with-work-buffer (location file &rest body)
- "Run BODY in a buffer containing the contents of FILE at LOCATION.
-LOCATION is the base location of a package archive, and should be
-one of the URLs (or file names) specified in `package-archives'.
-FILE is the name of a file relative to that base location.
-
-This macro retrieves FILE from LOCATION into a temporary buffer,
-and evaluates BODY while that buffer is current. This work
-buffer is killed afterwards. Return the last value in BODY."
- `(let* ((http (string-match "\\`https?:" ,location))
- (buffer
- (if http
- (url-retrieve-synchronously (concat ,location ,file))
- (generate-new-buffer "*package work buffer*"))))
- (prog1
- (with-current-buffer buffer
- (if http
- (progn (package-handle-response)
- (re-search-forward "^$" nil 'move)
- (forward-char)
- (delete-region (point-min) (point)))
- (unless (file-name-absolute-p ,location)
- (error "Archive location %s is not an absolute file name"
- ,location))
- (insert-file-contents (expand-file-name ,file ,location)))
- ,@body)
- (kill-buffer buffer))))
-
-(defun package-handle-response ()
- "Handle the response from a `url-retrieve-synchronously' call.
-Parse the HTTP response and throw if an error occurred.
-The url package seems to require extra processing for this.
-This should be called in a `save-excursion', in the download buffer.
-It will move point to somewhere in the headers."
- ;; We assume HTTP here.
- (require 'url-http)
- (let ((response (url-http-parse-response)))
- (when (or (< response 200) (>= response 300))
- (error "Error during download request:%s"
- (buffer-substring-no-properties (point) (progn
- (end-of-line)
- (point)))))))
-
-(defun package-download-single (name version desc requires)
- "Download and install a single-file package."
- (let ((location (package-archive-base name))
- (file (concat (symbol-name name) "-" version ".el")))
- (package--with-work-buffer location file
- (package-unpack-single (symbol-name name) version desc requires))))
-
-(defun package-download-tar (name version)
- "Download and install a tar package."
- (let ((location (package-archive-base name))
- (file (concat (symbol-name name) "-" version ".tar")))
- (package--with-work-buffer location file
- (package-unpack name version))))
-
-(defvar package--initialized nil)
-
-(defun package-installed-p (package &optional min-version)
- "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
-MIN-VERSION should be a version list."
- (unless package--initialized (error "package.el is not yet initialized!"))
- (let ((pkg-desc (assq package package-alist)))
- (if pkg-desc
- (version-list-<= min-version
- (package-desc-vers (cdr pkg-desc)))
- ;; Also check built-in packages.
- (package-built-in-p package min-version))))
-
-(defun package-compute-transaction (package-list requirements)
- "Return a list of packages to be installed, including PACKAGE-LIST.
-PACKAGE-LIST should be a list of package names (symbols).
-
-REQUIREMENTS should be a list of additional requirements; each
-element in this list should have the form (PACKAGE VERSION-LIST),
-where PACKAGE is a package name and VERSION-LIST is the required
-version of that package.
-
-This function recursively computes the requirements of the
-packages in REQUIREMENTS, and returns a list of all the packages
-that must be installed. Packages that are already installed are
-not included in this list."
- (dolist (elt requirements)
- (let* ((next-pkg (car elt))
- (next-version (cadr elt)))
- (unless (package-installed-p next-pkg next-version)
- ;; A package is required, but not installed. It might also be
- ;; blocked via `package-load-list'.
- (let ((pkg-desc (assq next-pkg package-archive-contents))
- hold)
- (when (setq hold (assq next-pkg package-load-list))
- (setq hold (cadr hold))
- (cond ((eq hold t))
- ((eq hold nil)
- (error "Required package '%s' is disabled"
- (symbol-name next-pkg)))
- ((null (stringp hold))
- (error "Invalid element in `package-load-list'"))
- ((version-list-< (version-to-list hold) next-version)
- (error "Package `%s' held at version %s, \
-but version %s required"
- (symbol-name next-pkg) hold
- (package-version-join next-version)))))
- (unless pkg-desc
- (error "Package `%s-%s' is unavailable"
- (symbol-name next-pkg)
- (package-version-join next-version)))
- (unless (version-list-<= next-version
- (package-desc-vers (cdr pkg-desc)))
- (error
- "Need package `%s-%s', but only %s is available"
- (symbol-name next-pkg) (package-version-join next-version)
- (package-version-join (package-desc-vers (cdr pkg-desc)))))
- ;; Only add to the transaction if we don't already have it.
- (unless (memq next-pkg package-list)
- (push next-pkg package-list))
- (setq package-list
- (package-compute-transaction package-list
- (package-desc-reqs
- (cdr pkg-desc))))))))
- package-list)
-
-(defun package-read-from-string (str)
- "Read a Lisp expression from STR.
-Signal an error if the entire string was not used."
- (let* ((read-data (read-from-string str))
- (more-left
- (condition-case nil
- ;; The call to `ignore' suppresses a compiler warning.
- (progn (ignore (read-from-string
- (substring str (cdr read-data))))
- t)
- (end-of-file nil))))
- (if more-left
- (error "Can't read whole string")
- (car read-data))))
-
-(defun package--read-archive-file (file)
- "Re-read archive file FILE, if it exists.
-Will return the data from the file, or nil if the file does not exist.
-Will throw an error if the archive version is too new."
- (let ((filename (expand-file-name file package-user-dir)))
- (when (file-exists-p filename)
- (with-temp-buffer
- (insert-file-contents-literally filename)
- (let ((contents (read (current-buffer))))
- (if (> (car contents) package-archive-version)
- (error "Package archive version %d is higher than %d"
- (car contents) package-archive-version))
- (cdr contents))))))
-
-(defun package-read-all-archive-contents ()
- "Re-read `archive-contents', if it exists.
-If successful, set `package-archive-contents'."
- (setq package-archive-contents nil)
- (dolist (archive package-archives)
- (package-read-archive-contents (car archive))))
-
-(defun package-read-archive-contents (archive)
- "Re-read archive contents for ARCHIVE.
-If successful, set the variable `package-archive-contents'.
-If the archive version is too new, signal an error."
- ;; Version 1 of 'archive-contents' is identical to our internal
- ;; representation.
- (let* ((dir (concat "archives/" archive))
- (contents-file (concat dir "/archive-contents"))
- contents)
- (when (setq contents (package--read-archive-file contents-file))
- (dolist (package contents)
- (package--add-to-archive-contents package archive)))))
-
-(defun package--add-to-archive-contents (package archive)
- "Add the PACKAGE from the given ARCHIVE if necessary.
-Also, add the originating archive to the end of the package vector."
- (let* ((name (car package))
- (version (package-desc-vers (cdr package)))
- (entry (cons name
- (vconcat (cdr package) (vector archive))))
- (existing-package (assq name package-archive-contents)))
- (cond ((not existing-package)
- (add-to-list 'package-archive-contents entry))
- ((version-list-< (package-desc-vers (cdr existing-package))
- version)
- ;; Replace the entry with this one.
- (setq package-archive-contents
- (cons entry
- (delq existing-package
- package-archive-contents)))))))
-
-(defun package-download-transaction (package-list)
- "Download and install all the packages in PACKAGE-LIST.
-PACKAGE-LIST should be a list of package names (symbols).
-This function assumes that all package requirements in
-PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
-using `package-compute-transaction'."
- (dolist (elt package-list)
- (let* ((desc (cdr (assq elt package-archive-contents)))
- ;; As an exception, if package is "held" in
- ;; `package-load-list', download the held version.
- (hold (cadr (assq elt package-load-list)))
- (v-string (or (and (stringp hold) hold)
- (package-version-join (package-desc-vers desc))))
- (kind (package-desc-kind desc)))
- (cond
- ((eq kind 'tar)
- (package-download-tar elt v-string))
- ((eq kind 'single)
- (package-download-single elt v-string
- (package-desc-doc desc)
- (package-desc-reqs desc)))
- (t
- (error "Unknown package kind: %s" (symbol-name kind))))
- ;; If package A depends on package B, then A may `require' B
- ;; during byte compilation. So we need to activate B before
- ;; unpacking A.
- (package-maybe-load-descriptor (symbol-name elt) v-string
- package-user-dir)
- (package-activate elt (version-to-list v-string)))))
-
-;;;###autoload
-(defun package-install (name)
- "Install the package named NAME.
-NAME should be the name of one of the available packages in an
-archive in `package-archives'. Interactively, prompt for NAME."
- (interactive
- (progn
- ;; Initialize the package system to get the list of package
- ;; symbols for completion.
- (unless package--initialized
- (package-initialize t))
- (unless package-archive-contents
- (package-refresh-contents))
- (list (intern (completing-read
- "Install package: "
- (mapcar (lambda (elt)
- (cons (symbol-name (car elt))
- nil))
- package-archive-contents)
- nil t)))))
- (let ((pkg-desc (assq name package-archive-contents)))
- (unless pkg-desc
- (error "Package `%s' is not available for installation"
- (symbol-name name)))
- (package-download-transaction
- (package-compute-transaction (list name)
- (package-desc-reqs (cdr pkg-desc))))))
-
-(defun package-strip-rcs-id (str)
- "Strip RCS version ID from the version string STR.
-If the result looks like a dotted numeric version, return it.
-Otherwise return nil."
- (when str
- (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
- (setq str (substring str (match-end 0))))
- (condition-case nil
- (if (version-to-list str)
- str)
- (error nil))))
-
-(defun package-buffer-info ()
- "Return a vector describing the package in the current buffer.
-The vector has the form
-
- [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
-
-FILENAME is the file name, a string, sans the \".el\" extension.
-REQUIRES is a list of requirements, each requirement having the
- form (NAME VER); NAME is a string and VER is a version list.
-DESCRIPTION is the package description, a string.
-VERSION is the version, a string.
-COMMENTARY is the commentary section, a string, or nil if none.
-
-If the buffer does not contain a conforming package, signal an
-error. If there is a package, narrow the buffer to the file's
-boundaries."
- (goto-char (point-min))
- (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
- (error "Packages lacks a file header"))
- (let ((file-name (match-string-no-properties 1))
- (desc (match-string-no-properties 2))
- (start (line-beginning-position)))
- (unless (search-forward (concat ";;; " file-name ".el ends here"))
- (error "Package lacks a terminating comment"))
- ;; Try to include a trailing newline.
- (forward-line)
- (narrow-to-region start (point))
- (require 'lisp-mnt)
- ;; Use some headers we've invented to drive the process.
- (let* ((requires-str (lm-header "package-requires"))
- (requires (if requires-str
- (package-read-from-string requires-str)))
- ;; Prefer Package-Version; if defined, the package author
- ;; probably wants us to use it. Otherwise try Version.
- (pkg-version
- (or (package-strip-rcs-id (lm-header "package-version"))
- (package-strip-rcs-id (lm-header "version"))))
- (commentary (lm-commentary)))
- (unless pkg-version
- (error
- "Package lacks a \"Version\" or \"Package-Version\" header"))
- ;; Turn string version numbers into list form.
- (setq requires
- (mapcar
- (lambda (elt)
- (list (car elt)
- (version-to-list (car (cdr elt)))))
- requires))
- (vector file-name requires desc pkg-version commentary))))
-
-(defun package-tar-file-info (file)
- "Find package information for a tar file.
-FILE is the name of the tar file to examine.
-The return result is a vector like `package-buffer-info'."
- (let ((default-directory (file-name-directory file))
- (file (file-name-nondirectory file)))
- (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
- file)
- (error "Invalid package name `%s'" file))
- (let* ((pkg-name (match-string-no-properties 1 file))
- (pkg-version (match-string-no-properties 2 file))
- ;; Extract the package descriptor.
- (pkg-def-contents (shell-command-to-string
- ;; Requires GNU tar.
- (concat "tar -xOf " file " "
-
- pkg-name "-" pkg-version "/"
- pkg-name "-pkg.el")))
- (pkg-def-parsed (package-read-from-string pkg-def-contents)))
- (unless (eq (car pkg-def-parsed) 'define-package)
- (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
- (let ((name-str (nth 1 pkg-def-parsed))
- (version-string (nth 2 pkg-def-parsed))
- (docstring (nth 3 pkg-def-parsed))
- (requires (nth 4 pkg-def-parsed))
- (readme (shell-command-to-string
- ;; Requires GNU tar.
- (concat "tar -xOf " file " "
- pkg-name "-" pkg-version "/README"))))
- (unless (equal pkg-version version-string)
- (error "Package has inconsistent versions"))
- (unless (equal pkg-name name-str)
- (error "Package has inconsistent names"))
- ;; Kind of a hack.
- (if (string-match ": Not found in archive" readme)
- (setq readme nil))
- ;; Turn string version numbers into list form.
- (if (eq (car requires) 'quote)
- (setq requires (car (cdr requires))))
- (setq requires
- (mapcar (lambda (elt)
- (list (car elt)
- (version-to-list (cadr elt))))
- requires))
- (vector pkg-name requires docstring version-string readme)))))
-
-;;;###autoload
-(defun package-install-from-buffer (pkg-info type)
- "Install a package from the current buffer.
-When called interactively, the current buffer is assumed to be a
-single .el file that follows the packaging guidelines; see info
-node `(elisp)Packaging'.
-
-When called from Lisp, PKG-INFO is a vector describing the
-information, of the type returned by `package-buffer-info'; and
-TYPE is the package type (either `single' or `tar')."
- (interactive (list (package-buffer-info) 'single))
- (save-excursion
- (save-restriction
- (let* ((file-name (aref pkg-info 0))
- (requires (aref pkg-info 1))
- (desc (if (string= (aref pkg-info 2) "")
- "No description available."
- (aref pkg-info 2)))
- (pkg-version (aref pkg-info 3)))
- ;; Download and install the dependencies.
- (let ((transaction (package-compute-transaction nil requires)))
- (package-download-transaction transaction))
- ;; Install the package itself.
- (cond
- ((eq type 'single)
- (package-unpack-single file-name pkg-version desc requires))
- ((eq type 'tar)
- (package-unpack (intern file-name) pkg-version))
- (t
- (error "Unknown type: %s" (symbol-name type))))
- ;; Try to activate it.
- (package-initialize)))))
-
-;;;###autoload
-(defun package-install-file (file)
- "Install a package from a file.
-The file can either be a tar file or an Emacs Lisp file."
- (interactive "fPackage file name: ")
- (with-temp-buffer
- (insert-file-contents-literally file)
- (cond
- ((string-match "\\.el$" file)
- (package-install-from-buffer (package-buffer-info) 'single))
- ((string-match "\\.tar$" file)
- (package-install-from-buffer (package-tar-file-info file) 'tar))
- (t (error "Unrecognized extension `%s'" (file-name-extension file))))))
-
-(defun package-delete (name version)
- (let ((dir (package--dir name version)))
- (if (string-equal (file-name-directory dir)
- (file-name-as-directory
- (expand-file-name package-user-dir)))
- (progn
- (delete-directory dir t t)
- (message "Package `%s-%s' deleted." name version))
- ;; Don't delete "system" packages
- (error "Package `%s-%s' is a system package, not deleting"
- name version))))
-
-(defun package-archive-base (name)
- "Return the archive containing the package NAME."
- (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
- (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
-
-(defun package--download-one-archive (archive file)
- "Retrieve an archive file FILE from ARCHIVE, and cache it.
-ARCHIVE should be a cons cell of the form (NAME . LOCATION),
-similar to an entry in `package-alist'. Save the cached copy to
-\"archives/NAME/archive-contents\" in `package-user-dir'."
- (let* ((dir (expand-file-name "archives" package-user-dir))
- (dir (expand-file-name (car archive) dir)))
- (package--with-work-buffer (cdr archive) file
- ;; Read the retrieved buffer to make sure it is valid (e.g. it
- ;; may fetch a URL redirect page).
- (when (listp (read buffer))
- (make-directory dir t)
- (setq buffer-file-name (expand-file-name file dir))
- (let ((version-control 'never))
- (save-buffer))))))
-
-;;;###autoload
-(defun package-refresh-contents ()
- "Download the ELPA archive description if needed.
-This informs Emacs about the latest versions of all packages, and
-makes them available for download."
- (interactive)
- (unless (file-exists-p package-user-dir)
- (make-directory package-user-dir t))
- (dolist (archive package-archives)
- (condition-case-unless-debug nil
- (package--download-one-archive archive "archive-contents")
- (error (message "Failed to download `%s' archive."
- (car archive)))))
- (package-read-all-archive-contents))
-
-;;;###autoload
-(defun package-initialize (&optional no-activate)
- "Load Emacs Lisp packages, and activate them.
-The variable `package-load-list' controls which packages to load.
-If optional arg NO-ACTIVATE is non-nil, don't activate packages."
- (interactive)
- (setq package-alist nil
- package-obsolete-alist nil)
- (package-load-all-descriptors)
- (package-read-all-archive-contents)
- (unless no-activate
- (dolist (elt package-alist)
- (package-activate (car elt) (package-desc-vers (cdr elt)))))
- (setq package--initialized t))
-
-\f
-;;;; Package description buffer.
-
-;;;###autoload
-(defun describe-package (package)
- "Display the full documentation of PACKAGE (a symbol)."
- (interactive
- (let* ((guess (function-called-at-point))
- packages val)
- (require 'finder-inf nil t)
- ;; Load the package list if necessary (but don't activate them).
- (unless package--initialized
- (package-initialize t))
- (setq packages (append (mapcar 'car package-alist)
- (mapcar 'car package-archive-contents)
- (mapcar 'car package--builtins)))
- (unless (memq guess packages)
- (setq guess nil))
- (setq packages (mapcar 'symbol-name packages))
- (setq val
- (completing-read (if guess
- (format "Describe package (default %s): "
- guess)
- "Describe package: ")
- packages nil t nil nil guess))
- (list (if (equal val "") guess (intern val)))))
- (if (or (null package) (not (symbolp package)))
- (message "No package specified")
- (help-setup-xref (list #'describe-package package)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- (with-current-buffer standard-output
- (describe-package-1 package)))))
-
-(defun describe-package-1 (package)
- (require 'lisp-mnt)
- (let ((package-name (symbol-name package))
- (built-in (assq package package--builtins))
- desc pkg-dir reqs version installable archive)
- (prin1 package)
- (princ " is ")
- (cond
- ;; Loaded packages are in `package-alist'.
- ((setq desc (cdr (assq package package-alist)))
- (setq version (package-version-join (package-desc-vers desc)))
- (if (setq pkg-dir (package--dir package-name version))
- (insert "an installed package.\n\n")
- ;; This normally does not happen.
- (insert "a deleted package.\n\n")))
- ;; Available packages are in `package-archive-contents'.
- ((setq desc (cdr (assq package package-archive-contents)))
- (setq version (package-version-join (package-desc-vers desc))
- archive (aref desc (- (length desc) 1))
- installable t)
- (if built-in
- (insert "a built-in package.\n\n")
- (insert "an uninstalled package.\n\n")))
- (built-in
- (setq desc (cdr built-in)
- version (package-version-join (package-desc-vers desc)))
- (insert "a built-in package.\n\n"))
- (t
- (insert "an orphan package.\n\n")))
-
- (insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
- (cond (pkg-dir
- (insert (propertize "Installed"
- 'font-lock-face 'font-lock-comment-face))
- (insert " in `")
- ;; Todo: Add button for uninstalling.
- (help-insert-xref-button (file-name-as-directory pkg-dir)
- 'help-package-def pkg-dir)
- (if built-in
- (insert "',\n shadowing a "
- (propertize "built-in package"
- 'font-lock-face 'font-lock-builtin-face)
- ".")
- (insert "'.")))
- (installable
- (if built-in
- (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
- " Alternate version available")
- (insert "Available"))
- (insert " from " archive)
- (insert " -- ")
- (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
- (button-face (if (display-graphic-p)
- '(:box (:line-width 2 :color "dark grey")
- :background "light grey"
- :foreground "black")
- 'link)))
- (insert-text-button button-text 'face button-face 'follow-link t
- 'package-symbol package
- 'action 'package-install-button-action)))
- (built-in
- (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
- (t (insert "Deleted.")))
- (insert "\n")
- (and version (> (length version) 0)
- (insert " "
- (propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
-
- (setq reqs (if desc (package-desc-reqs desc)))
- (when reqs
- (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
- (let ((first t)
- name vers text)
- (dolist (req reqs)
- (setq name (car req)
- vers (cadr req)
- text (format "%s-%s" (symbol-name name)
- (package-version-join vers)))
- (cond (first (setq first nil))
- ((>= (+ 2 (current-column) (length text))
- (window-width))
- (insert ",\n "))
- (t (insert ", ")))
- (help-insert-xref-button text 'help-package name))
- (insert "\n")))
- (insert " " (propertize "Summary" 'font-lock-face 'bold)
- ": " (if desc (package-desc-doc desc)) "\n\n")
-
- (if built-in
- ;; For built-in packages, insert the commentary.
- (let ((fn (locate-file (concat package-name ".el") load-path
- load-file-rep-suffixes))
- (opoint (point)))
- (insert (or (lm-commentary fn) ""))
- (save-excursion
- (goto-char opoint)
- (when (re-search-forward "^;;; Commentary:\n" nil t)
- (replace-match ""))
- (while (re-search-forward "^\\(;+ ?\\)" nil t)
- (replace-match ""))))
- (let ((readme (expand-file-name (concat package-name "-readme.txt")
- package-user-dir))
- readme-string)
- ;; For elpa packages, try downloading the commentary. If that
- ;; fails, try an existing readme file in `package-user-dir'.
- (cond ((condition-case nil
- (package--with-work-buffer (package-archive-base package)
- (concat package-name "-readme.txt")
- (setq buffer-file-name
- (expand-file-name readme package-user-dir))
- (let ((version-control 'never))
- (save-buffer))
- (setq readme-string (buffer-string))
- t)
- (error nil))
- (insert readme-string))
- ((file-readable-p readme)
- (insert-file-contents readme)
- (goto-char (point-max))))))))
-
-(defun package-install-button-action (button)
- (let ((package (button-get button 'package-symbol)))
- (when (y-or-n-p (format "Install package `%s'? " package))
- (package-install package)
- (revert-buffer nil t)
- (goto-char (point-min)))))
-
-\f
-;;;; Package menu mode.
-
-(defvar package-menu-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Package")))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map "\C-m" 'package-menu-describe-package)
- (define-key map "u" 'package-menu-mark-unmark)
- (define-key map "\177" 'package-menu-backup-unmark)
- (define-key map "d" 'package-menu-mark-delete)
- (define-key map "i" 'package-menu-mark-install)
- (define-key map "U" 'package-menu-mark-upgrades)
- (define-key map "r" 'package-menu-refresh)
- (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
- (define-key map "x" 'package-menu-execute)
- (define-key map "h" 'package-menu-quick-help)
- (define-key map "?" 'package-menu-describe-package)
- (define-key map [menu-bar package-menu] (cons "Package" menu-map))
- (define-key menu-map [mq]
- '(menu-item "Quit" quit-window
- :help "Quit package selection"))
- (define-key menu-map [s1] '("--"))
- (define-key menu-map [mn]
- '(menu-item "Next" next-line
- :help "Next Line"))
- (define-key menu-map [mp]
- '(menu-item "Previous" previous-line
- :help "Previous Line"))
- (define-key menu-map [s2] '("--"))
- (define-key menu-map [mu]
- '(menu-item "Unmark" package-menu-mark-unmark
- :help "Clear any marks on a package and move to the next line"))
- (define-key menu-map [munm]
- '(menu-item "Unmark Backwards" package-menu-backup-unmark
- :help "Back up one line and clear any marks on that package"))
- (define-key menu-map [md]
- '(menu-item "Mark for Deletion" package-menu-mark-delete
- :help "Mark a package for deletion and move to the next line"))
- (define-key menu-map [mi]
- '(menu-item "Mark for Install" package-menu-mark-install
- :help "Mark a package for installation and move to the next line"))
- (define-key menu-map [mupgrades]
- '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades
- :help "Mark packages that have a newer version for upgrading"))
- (define-key menu-map [s3] '("--"))
- (define-key menu-map [mg]
- '(menu-item "Update Package List" revert-buffer
- :help "Update the list of packages"))
- (define-key menu-map [mr]
- '(menu-item "Refresh Package List" package-menu-refresh
- :help "Download the ELPA archive"))
- (define-key menu-map [s4] '("--"))
- (define-key menu-map [mt]
- '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion
- :help "Mark all obsolete packages for deletion"))
- (define-key menu-map [mx]
- '(menu-item "Execute Actions" package-menu-execute
- :help "Perform all the marked actions"))
- (define-key menu-map [s5] '("--"))
- (define-key menu-map [mh]
- '(menu-item "Help" package-menu-quick-help
- :help "Show short key binding help for package-menu-mode"))
- (define-key menu-map [mc]
- '(menu-item "View Commentary" package-menu-view-commentary
- :help "Display information about this package"))
- map)
- "Local keymap for `package-menu-mode' buffers.")
-
-(defvar package-menu--new-package-list nil
- "List of newly-available packages since `list-packages' was last called.")
-
-(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
- "Major mode for browsing a list of packages.
-Letters do not insert themselves; instead, they are commands.
-\\<package-menu-mode-map>
-\\{package-menu-mode-map}"
- (setq tabulated-list-format [("Package" 18 package-menu--name-predicate)
- ("Version" 12 nil)
- ("Status" 10 package-menu--status-predicate)
- ("Description" 0 nil)])
- (setq tabulated-list-padding 2)
- (setq tabulated-list-sort-key (cons "Status" nil))
- (tabulated-list-init-header))
-
-(defmacro package--push (package desc status listname)
- "Convenience macro for `package-menu--generate'.
-If the alist stored in the symbol LISTNAME lacks an entry for a
-package PACKAGE with descriptor DESC, add one. The alist is
-keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is
-a symbol and VERSION-LIST is a version list."
- `(let* ((version (package-desc-vers ,desc))
- (key (cons ,package version)))
- (unless (assoc key ,listname)
- (push (list key ,status (package-desc-doc ,desc)) ,listname))))
-
-(defun package-menu--generate (remember-pos packages)
- "Populate the Package Menu.
-If REMEMBER-POS is non-nil, keep point on the same entry.
-PACKAGES should be t, which means to display all known packages,
-or a list of package names (symbols) to display."
- ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION).
- (let (info-list name)
- ;; Installed packages:
- (dolist (elt package-alist)
- (setq name (car elt))
- (when (or (eq packages t) (memq name packages))
- (package--push name (cdr elt)
- (if (stringp (cadr (assq name package-load-list)))
- "held" "installed")
- info-list)))
-
- ;; Built-in packages:
- (dolist (elt package--builtins)
- (setq name (car elt))
- (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
- (or (eq packages t) (memq name packages)))
- (package--push name (cdr elt) "built-in" info-list)))
-
- ;; Available and disabled packages:
- (dolist (elt package-archive-contents)
- (setq name (car elt))
- (when (or (eq packages t) (memq name packages))
- (let ((hold (assq name package-load-list)))
- (package--push name (cdr elt)
- (cond
- ((and hold (null (cadr hold))) "disabled")
- ((memq name package-menu--new-package-list) "new")
- (t "available"))
- info-list))))
-
- ;; Obsolete packages:
- (dolist (elt package-obsolete-alist)
- (dolist (inner-elt (cdr elt))
- (when (or (eq packages t) (memq (car elt) packages))
- (package--push (car elt) (cdr inner-elt) "obsolete" info-list))))
-
- ;; Print the result.
- (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list))
- (tabulated-list-print remember-pos)))
-
-(defun package-menu--print-info (pkg)
- "Return a package entry suitable for `tabulated-list-entries'.
-PKG has the form ((PACKAGE . VERSION) STATUS DOC).
-Return (KEY [NAME VERSION STATUS DOC]), where KEY is the
-identifier (NAME . VERSION-LIST)."
- (let* ((package (caar pkg))
- (version (cdr (car pkg)))
- (status (nth 1 pkg))
- (doc (or (nth 2 pkg) ""))
- (face (cond
- ((string= status "built-in") 'font-lock-builtin-face)
- ((string= status "available") 'default)
- ((string= status "new") 'bold)
- ((string= status "held") 'font-lock-constant-face)
- ((string= status "disabled") 'font-lock-warning-face)
- ((string= status "installed") 'font-lock-comment-face)
- (t 'font-lock-warning-face)))) ; obsolete.
- (list (cons package version)
- (vector (list (symbol-name package)
- 'face 'link
- 'follow-link t
- 'package-symbol package
- 'action 'package-menu-describe-package)
- (propertize (package-version-join version)
- 'font-lock-face face)
- (propertize status 'font-lock-face face)
- (propertize doc 'font-lock-face face)))))
-
-(defun package-menu-refresh ()
- "Download the Emacs Lisp package archive.
-This fetches the contents of each archive specified in
-`package-archives', and then refreshes the package menu."
- (interactive)
- (unless (derived-mode-p 'package-menu-mode)
- (error "The current buffer is not a Package Menu"))
- (package-refresh-contents)
- (package-menu--generate t t))
-
-(defun package-menu-describe-package (&optional button)
- "Describe the current package.
-If optional arg BUTTON is non-nil, describe its associated package."
- (interactive)
- (let ((package (if button (button-get button 'package-symbol)
- (car (tabulated-list-get-id)))))
- (if package
- (describe-package package))))
-
-;; fixme numeric argument
-(defun package-menu-mark-delete (&optional _num)
- "Mark a package for deletion and move to the next line."
- (interactive "p")
- (if (member (package-menu-get-status) '("installed" "obsolete"))
- (tabulated-list-put-tag "D" t)
- (forward-line)))
-
-(defun package-menu-mark-install (&optional _num)
- "Mark a package for installation and move to the next line."
- (interactive "p")
- (if (member (package-menu-get-status) '("available" "new"))
- (tabulated-list-put-tag "I" t)
- (forward-line)))
-
-(defun package-menu-mark-unmark (&optional _num)
- "Clear any marks on a package and move to the next line."
- (interactive "p")
- (tabulated-list-put-tag " " t))
-
-(defun package-menu-backup-unmark ()
- "Back up one line and clear any marks on that package."
- (interactive)
- (forward-line -1)
- (tabulated-list-put-tag " "))
-
-(defun package-menu-mark-obsolete-for-deletion ()
- "Mark all obsolete packages for deletion."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (if (equal (package-menu-get-status) "obsolete")
- (tabulated-list-put-tag "D" t)
- (forward-line 1)))))
-
-(defun package-menu-quick-help ()
- "Show short key binding help for package-menu-mode."
- (interactive)
- (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
-
-(define-obsolete-function-alias
- 'package-menu-view-commentary 'package-menu-describe-package "24.1")
-
-(defun package-menu-get-status ()
- (let* ((pkg (tabulated-list-get-id))
- (entry (and pkg (assq pkg tabulated-list-entries))))
- (if entry
- (aref (cadr entry) 2)
- "")))
-
-(defun package-menu--find-upgrades ()
- (let (installed available upgrades)
- ;; Build list of installed/available packages in this buffer.
- (dolist (entry tabulated-list-entries)
- ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC])
- (let ((pkg (car entry))
- (status (aref (cadr entry) 2)))
- (cond ((equal status "installed")
- (push pkg installed))
- ((member status '("available" "new"))
- (push pkg available)))))
- ;; Loop through list of installed packages, finding upgrades
- (dolist (pkg installed)
- (let ((avail-pkg (assq (car pkg) available)))
- (and avail-pkg
- (version-list-< (cdr pkg) (cdr avail-pkg))
- (push avail-pkg upgrades))))
- upgrades))
-
-(defun package-menu-mark-upgrades ()
- "Mark all upgradable packages in the Package Menu.
-For each installed package with a newer version available, place
-an (I)nstall flag on the available version and a (D)elete flag on
-the installed version. A subsequent \\[package-menu-execute]
-call will upgrade the package."
- (interactive)
- (unless (derived-mode-p 'package-menu-mode)
- (error "The current buffer is not a Package Menu"))
- (let ((upgrades (package-menu--find-upgrades)))
- (if (null upgrades)
- (message "No packages to upgrade.")
- (widen)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (let* ((pkg (tabulated-list-get-id))
- (upgrade (assq (car pkg) upgrades)))
- (cond ((null upgrade)
- (forward-line 1))
- ((equal pkg upgrade)
- (package-menu-mark-install))
- (t
- (package-menu-mark-delete))))))
- (message "%d package%s marked for upgrading."
- (length upgrades)
- (if (= (length upgrades) 1) "" "s")))))
-
-(defun package-menu-execute (&optional noquery)
- "Perform marked Package Menu actions.
-Packages marked for installation are downloaded and installed;
-packages marked for deletion are removed.
-Optional argument NOQUERY non-nil means do not ask the user to confirm."
- (interactive)
- (unless (derived-mode-p 'package-menu-mode)
- (error "The current buffer is not in Package Menu mode"))
- (let (install-list delete-list cmd id)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (setq cmd (char-after))
- (unless (eq cmd ?\s)
- ;; This is the key (PACKAGE . VERSION-LIST).
- (setq id (tabulated-list-get-id))
- (cond ((eq cmd ?D)
- (push (cons (symbol-name (car id))
- (package-version-join (cdr id)))
- delete-list))
- ((eq cmd ?I)
- (push (car id) install-list))))
- (forward-line)))
- (when install-list
- (if (or
- noquery
- (yes-or-no-p
- (if (= (length install-list) 1)
- (format "Install package `%s'? " (car install-list))
- (format "Install these %d packages (%s)? "
- (length install-list)
- (mapconcat 'symbol-name install-list ", ")))))
- (mapc 'package-install install-list)))
- ;; Delete packages, prompting if necessary.
- (when delete-list
- (if (or
- noquery
- (yes-or-no-p
- (if (= (length delete-list) 1)
- (format "Delete package `%s-%s'? "
- (caar delete-list)
- (cdr (car delete-list)))
- (format "Delete these %d packages (%s)? "
- (length delete-list)
- (mapconcat (lambda (elt)
- (concat (car elt) "-" (cdr elt)))
- delete-list
- ", ")))))
- (dolist (elt delete-list)
- (condition-case-unless-debug err
- (package-delete (car elt) (cdr elt))
- (error (message (cadr err)))))
- (error "Aborted")))
- ;; If we deleted anything, regenerate `package-alist'. This is done
- ;; automatically if we installed a package.
- (and delete-list (null install-list)
- (package-initialize))
- (if (or delete-list install-list)
- (package-menu--generate t t)
- (message "No operations specified."))))
-
-(defun package-menu--version-predicate (A B)
- (let ((vA (or (aref (cadr A) 1) '(0)))
- (vB (or (aref (cadr B) 1) '(0))))
- (if (version-list-= vA vB)
- (package-menu--name-predicate A B)
- (version-list-< vA vB))))
-
-(defun package-menu--status-predicate (A B)
- (let ((sA (aref (cadr A) 2))
- (sB (aref (cadr B) 2)))
- (cond ((string= sA sB)
- (package-menu--name-predicate A B))
- ((string= sA "new") t)
- ((string= sB "new") nil)
- ((string= sA "available") t)
- ((string= sB "available") nil)
- ((string= sA "installed") t)
- ((string= sB "installed") nil)
- ((string= sA "held") t)
- ((string= sB "held") nil)
- ((string= sA "built-in") t)
- ((string= sB "built-in") nil)
- ((string= sA "obsolete") t)
- ((string= sB "obsolete") nil)
- (t (string< sA sB)))))
-
-(defun package-menu--description-predicate (A B)
- (let ((dA (aref (cadr A) 3))
- (dB (aref (cadr B) 3)))
- (if (string= dA dB)
- (package-menu--name-predicate A B)
- (string< dA dB))))
-
-(defun package-menu--name-predicate (A B)
- (string< (symbol-name (caar A))
- (symbol-name (caar B))))
-
-;;;###autoload
-(defun list-packages (&optional no-fetch)
- "Display a list of packages.
-This first fetches the updated list of packages before
-displaying, unless a prefix argument NO-FETCH is specified.
-The list is displayed in a buffer named `*Packages*'."
- (interactive "P")
- (require 'finder-inf nil t)
- ;; Initialize the package system if necessary.
- (unless package--initialized
- (package-initialize t))
- (let (old-archives new-packages)
- (unless no-fetch
- ;; Read the locally-cached archive-contents.
- (package-read-all-archive-contents)
- (setq old-archives package-archive-contents)
- ;; Fetch the remote list of packages.
- (package-refresh-contents)
- ;; Find which packages are new.
- (dolist (elt package-archive-contents)
- (unless (assq (car elt) old-archives)
- (push (car elt) new-packages))))
-
- ;; Generate the Package Menu.
- (let ((buf (get-buffer-create "*Packages*")))
- (with-current-buffer buf
- (package-menu-mode)
- (set (make-local-variable 'package-menu--new-package-list)
- new-packages)
- (package-menu--generate nil t))
- ;; The package menu buffer has keybindings. If the user types
- ;; `M-x list-packages', that suggests it should become current.
- (switch-to-buffer buf))
-
- (let ((upgrades (package-menu--find-upgrades)))
- (if upgrades
- (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
- (length upgrades)
- (if (= (length upgrades) 1) "" "s")
- (substitute-command-keys "\\[package-menu-mark-upgrades]")
- (if (= (length upgrades) 1) "it" "them"))))))
-
-;;;###autoload
-(defalias 'package-list-packages 'list-packages)
-
-;; Used in finder.el
-(defun package-show-package-list (packages)
- "Display PACKAGES in a *Packages* buffer.
-This is similar to `list-packages', but it does not fetch the
-updated list of packages, and it only displays packages with
-names in PACKAGES (which should be a list of symbols)."
- (require 'finder-inf nil t)
- (let ((buf (get-buffer-create "*Packages*")))
- (with-current-buffer buf
- (package-menu-mode)
- (package-menu--generate nil packages))
- (switch-to-buffer buf)))
-
-(defun package-list-packages-no-fetch ()
- "Display a list of packages.
-Does not fetch the updated list of packages before displaying.
-The list is displayed in a buffer named `*Packages*'."
- (interactive)
- (list-packages t))
-
-(provide 'package)
-
-;;; package.el ends here
--- /dev/null
+;;; visual-regexp-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+
+\f
+;;;### (autoloads (vr/query-replace vr/replace vr/mc-mark) "visual-regexp"
+;;;;;; "visual-regexp.el" (21823 48542 0 0))
+;;; Generated autoloads from visual-regexp.el
+
+(autoload 'vr/mc-mark "visual-regexp" "\
+Convert regexp selection to multiple cursors.
+
+\(fn REGEXP START END)" nil nil)
+
+(autoload 'vr/replace "visual-regexp" "\
+Regexp-replace with live visual feedback.
+
+\(fn REGEXP REPLACE START END)" t nil)
+
+(autoload 'vr/query-replace "visual-regexp" "\
+Use vr/query-replace like you would use query-replace-regexp.
+
+\(fn REGEXP REPLACE START END)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("visual-regexp-pkg.el") (21823 48542 600071
+;;;;;; 0))
+
+;;;***
+\f
+(provide 'visual-regexp-autoloads)
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; coding: utf-8
+;; End:
+;;; visual-regexp-autoloads.el ends here
--- /dev/null
+(define-package "visual-regexp" "20150329.954" "A regexp/replace command for Emacs with interactive visual feedback" (quote ((cl-lib "0.2"))))
--- /dev/null
+;;; visual-regexp.el --- A regexp/replace command for Emacs with interactive visual feedback
+
+;; Copyright (C) 2013-2015 Marko Bencun
+
+;; Author: Marko Bencun <mbencunNOSPAMgmail.com>
+;; URL: https://github.com/benma/visual-regexp.el/
+;; Package-Version: 20150329.954
+;; Version: 0.8
+;; Package-Requires: ((cl-lib "0.2"))
+;; Keywords: regexp, replace, visual, feedback
+
+;; This file is part of visual-regexp.
+
+;; visual-regexp 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.
+
+;; visual-regexp 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 visual-regexp. If not, see <http://www.gnu.org/licenses/>.
+
+;;; WHAT'S NEW
+;; 0.8: Error handling for vr--get-regexp-string. Bug-fixes regarding error display.
+;; 0.7: Customizable separator (arrow) string and face.
+;; 0.6: distinguish prompts in vr/replace, vr/query-replace, vr/mc-mark.
+;; 0.5: emulate case-conversion of replace-regexp.
+;; 0.4: vr/mc-mark: interface to multiple-cursors.
+;; 0.3: use the same history as the regular Emacs replace commands;
+;; 0.2: support for lisp expressions in the replace string, same as in (query-)replace-regexp
+;; 0.1: initial release
+
+;;; Tip Jar
+;; If you found this useful, please consider donating.
+;; BTC: 1BxauiLGMQPb2pavkkQkuFe5CgrGMrUat2
+
+;;; What's This?
+
+;; visual-regexp for Emacs is like `replace-regexp`, but with live visual feedback directly in the buffer.
+;; While constructing the regexp in the minibuffer, you get live visual feedback for the matches, including group matches.
+;; While constructing the replacement in the minibuffer, you get live visual feedback for the replacements.
+;; It can be used to replace all matches in one go (like `replace-regexp`), or a decision can be made on each match (like `query-replace-regexp`).
+;; Thanks to Detlev Zundel for his re-builder.
+
+;;; Where does visual-regexp come from?
+;;
+;; I was not happy with the way I used emacs' replace-regexp before. Constructing the regular expression is error prone and emacs' regular expressions are limited
+;; (for example, no lookaheads, named groups, etc.).
+;; Using re-builder to interactively build regular expressions was a step into the right direction, but manually copying over the regexp
+;; to the minibuffer is cumbersome.
+;; Using the idea of interactive feedback of re-builder, this package makes it possible to use just the minibuffer to construct (with live visual feedback) the regexp and replacement,
+;; using Emacs style regular expressions, or optionally, regular expressions powered by other (mode modern) engines, for the replacement. For the latter part, see the package visual-regexp-steroids.
+
+;;; Installation
+
+;; If you are using Emacs 24, you can get visual-regexp from [melpa](http://melpa.milkbox.net/) with the package manager.
+;; Add the following code to your init file. Of course you can select your own key bindings.
+;; ----------------------------------------------------------
+;; (add-to-list 'load-path "folder-in-which-visual-regexp-files-are-in/") ;; if the files are not already in the load path
+;; (require 'visual-regexp)
+;; (define-key global-map (kbd "C-c r") 'vr/replace)
+;; (define-key global-map (kbd "C-c q") 'vr/query-replace)
+;; ;; if you use multiple-cursors, this is for you:
+;; (define-key global-map (kbd "C-c m") 'vr/mc-mark)
+;; ----------------------------------------------------------
+;; To customize, use `M-x customize-group [RET] visual-regexp`.
+
+;;; Code:
+(unless (fboundp 'make-overlay)
+ (require 'overlay))
+
+;; cl is used for the (loop ...) macro
+(require 'cl-lib)
+
+;;; faces
+
+(defcustom vr/match-separator-use-custom-face nil
+ "If activated, vr/match-separator-face is used to display the separator. Otherwise, use the same face as the current match."
+ :type 'boolean
+ :group 'visual-regexp)
+
+
+(defface vr/match-separator-face
+ '((((class color))
+ :foreground "red"
+ :bold t)
+ (t
+ :inverse-video t))
+ "Face for the arrow between match and replacement. To use this, you must activate vr/match-separator-use-custom-face"
+ :group 'visual-regexp)
+
+(defcustom vr/match-separator-string " => "
+ "This string is used to separate a match from the replacement during feedback."
+ :type 'string
+ :group 'visual-regexp)
+
+(defface vr/match-0
+ '((((class color) (background light))
+ :background "lightblue")
+ (((class color) (background dark))
+ :background "steelblue4")
+ (t
+ :inverse-video t))
+ "First face for displaying a whole match."
+ :group 'visual-regexp)
+
+(defface vr/match-1
+ '((((class color) (background light))
+ :background "pale turquoise")
+ (((class color) (background dark))
+ :background "dodgerblue4")
+ (t
+ :inverse-video t))
+ "Second face for displaying a whole match."
+ :group 'visual-regexp)
+
+(defface vr/group-0
+ '((((class color) (background light))
+ :background "aquamarine")
+ (((class color) (background dark))
+ :background "blue3")
+ (t
+ :inverse-video t))
+ "First face for displaying a matching group."
+ :group 'visual-regexp)
+
+(defface vr/group-1
+ '((((class color) (background light))
+ :background "springgreen")
+ (((class color) (background dark))
+ :background "chartreuse4")
+ (t
+ :inverse-video t))
+ "Second face for displaying a matching group."
+ :group 'visual-regexp)
+
+(defface vr/group-2
+ '((((min-colors 88) (class color) (background light))
+ :background "yellow1")
+ (((class color) (background light))
+ :background "yellow")
+ (((class color) (background dark))
+ :background "sienna4")
+ (t
+ :inverse-video t))
+ "Third face for displaying a matching group."
+ :group 'visual-regexp)
+
+;;; variables
+
+(defcustom vr/auto-show-help t
+ "Show help message automatically when the minibuffer is entered."
+ :type 'boolean
+ :group 'visual-regexp)
+
+(defcustom vr/default-feedback-limit 50
+ "Limit number of matches shown in visual feedback.
+If nil, don't limit the number of matches shown in visual feedback."
+ :type 'integer
+ :group 'visual-regexp)
+
+(defcustom vr/default-replace-preview nil
+ "Preview of replacement activated by default? If activated, the original is not shown alongside the replacement."
+ :type 'boolean
+ :group 'visual-regexp)
+
+(defcustom vr/query-replace-from-history-variable query-replace-from-history-variable
+ "History list to use for the FROM argument. The default is to use the same history as Emacs' query-replace commands."
+ :type 'symbol
+ :group 'visual-regexp)
+
+(defcustom vr/query-replace-to-history-variable query-replace-to-history-variable
+ "History list to use for the TO argument. The default is to use the same history as Emacs' query-replace commands."
+ :type 'symbol
+ :group 'visual-regexp)
+
+(defvar vr/initialize-hook nil
+ "Hook called before vr/replace and vr/query-replace")
+
+;;; private variables
+
+(defconst vr--match-faces '(vr/match-0 vr/match-1)
+ "Faces in list for convenience")
+
+(defconst vr--group-faces '(vr/group-0 vr/group-1 vr/group-2)
+ "Faces in list for convenience")
+
+(defconst vr--overlay-priority 1001
+ "Starting priority of visual-regexp overlays.")
+
+(defvar vr--in-minibuffer nil
+ "Is visual-regexp currently being used?")
+
+(defvar vr--calling-func nil
+ "Which function invoked vr--interactive-get-args?")
+
+(defvar vr--last-minibuffer-contents nil
+ "Keeping track of minibuffer changes")
+
+(defvar vr--target-buffer-start nil
+ "Starting position in target buffer.")
+
+(defvar vr--target-buffer-end nil
+ "Ending position in target buffer.")
+
+(defvar vr--regexp-string nil
+ "Entered regexp.")
+
+(defvar vr--replace-string nil
+ "Entered replacement.")
+
+(defvar vr--feedback-limit nil
+ "Feedback limit currently in use.")
+
+(defvar vr--replace-preview nil
+ "Preview of replacement activated?")
+
+(defvar vr--target-buffer nil
+ "Buffer to which visual-regexp is applied to.")
+
+(defvar vr--overlays (make-hash-table :test 'equal)
+ "Overlays used in target buffer.")
+
+(defvar vr--visible-overlays (list)
+ "Overlays currently visible.")
+
+(defvar vr--minibuffer-message-overlay nil)
+
+;;; keymap
+
+(defvar vr/minibuffer-regexp-keymap
+ (let ((map (copy-keymap minibuffer-local-map)))
+ (define-key map (kbd "C-c ?") 'vr--minibuffer-help)
+
+ (define-key map (kbd "C-c a") 'vr--shortcut-toggle-limit)
+ map)
+ "Keymap used while using visual-regexp,")
+
+(defvar vr/minibuffer-replace-keymap
+ (let ((map (copy-keymap minibuffer-local-map)))
+ (define-key map (kbd "C-c ?") 'vr--minibuffer-help)
+ (define-key map (kbd "C-c m") 'vr--shortcut-show-matches)
+ (define-key map (kbd "C-c p") 'vr--shortcut-toggle-preview)
+
+ (define-key map (kbd "C-c a") 'vr--shortcut-toggle-limit)
+ map)
+ "Keymap used while using visual-regexp,")
+
+;;; helper functions
+
+(defun vr--shortcut-show-matches ()
+ (interactive)
+ (vr--delete-overlay-displays)
+ ;; wait for any input to redisplay replacements
+ (sit-for 100000000 t)
+ (vr--do-replace-feedback))
+
+(defun vr--shortcut-toggle-preview ()
+ (interactive)
+ (setq vr--replace-preview (not vr--replace-preview))
+ (vr--update-minibuffer-prompt)
+ (vr--do-replace-feedback))
+
+(defun vr--shortcut-toggle-limit ()
+ "Toggle the limit of overlays shown (default limit / no limit)"
+ (interactive)
+ (if vr--feedback-limit
+ (setq vr--feedback-limit nil)
+ (setq vr--feedback-limit vr/default-feedback-limit))
+ (cond ((equal vr--in-minibuffer 'vr--minibuffer-regexp)
+ (vr--feedback))
+ ((equal vr--in-minibuffer 'vr--minibuffer-replace)
+ (vr--feedback t) ;; update overlays
+ (vr--do-replace-feedback))))
+
+(defun vr--get-regexp-string (&optional for-display)
+ (concat (if (equal vr--in-minibuffer 'vr--minibuffer-regexp)
+ (minibuffer-contents-no-properties)
+ vr--regexp-string)))
+
+(defun vr--format-error (err)
+ (if (eq (car err) 'error)
+ (car (cdr err))
+ (format "%s" err)))
+
+;;; minibuffer functions
+
+(defun vr--minibuffer-set-prompt (prompt)
+ "Updates minibuffer prompt. Call when minibuffer is active."
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (minibuffer-prompt-end) 'display prompt)))
+
+(defun vr--set-minibuffer-prompt-regexp ()
+ (cond ((equal vr--calling-func 'vr--calling-func-query-replace)
+ "Query regexp: ")
+ ((equal vr--calling-func 'vr--calling-func-mc-mark)
+ "Mark regexp: ")
+ (t
+ "Regexp: ")))
+
+(defun vr--set-minibuffer-prompt-replace ()
+ (let (prefix)
+ (setq prefix (cond ((equal vr--calling-func 'vr--calling-func-query-replace)
+ "Query replace")
+ (t
+ "Replace")))
+
+ (concat prefix
+ (let ((flag-infos (mapconcat 'identity
+ (delq nil (list (when vr--replace-preview "preview")))
+ ", ")))
+ (when (not (string= "" flag-infos ))
+ (format " (%s)" flag-infos)))
+ (format " %s" (vr--get-regexp-string t))
+ " with: ")))
+
+(defun vr--update-minibuffer-prompt ()
+ (when (and vr--in-minibuffer (minibufferp))
+ (vr--minibuffer-set-prompt
+ (cond ((equal vr--in-minibuffer 'vr--minibuffer-regexp)
+ (vr--set-minibuffer-prompt-regexp))
+ ((equal vr--in-minibuffer 'vr--minibuffer-replace)
+ (vr--set-minibuffer-prompt-replace))))))
+
+
+(defun vr--minibuffer-message (message &rest args)
+ "Adaptation of minibuffer-message that does not use sit-for
+to make the message disappear. The problem with this was that during sit-for,
+ the cursor was shown at the beginning of the message regardless of whether
+ the point was actually there or not. Workaround: we let the message stay
+visible all the time in the minibuffer."
+ (if (not (and vr--in-minibuffer (minibufferp (current-buffer))))
+ ;; fallback
+ (apply 'minibuffer-message message args)
+ ;; Clear out any old echo-area message to make way for our new thing.
+ (message nil)
+ (setq message (concat " [" message "]"))
+ (when args (setq message (apply 'format message args)))
+ (unless (zerop (length message))
+ ;; The current C cursor code doesn't know to use the overlay's
+ ;; marker's stickiness to figure out whether to place the cursor
+ ;; before or after the string, so let's spoon-feed it the pos.
+ (put-text-property 0 1 'cursor t message))
+ (unless (overlayp vr--minibuffer-message-overlay)
+ (setq vr--minibuffer-message-overlay (make-overlay (point-max) (point-max) nil t t)))
+ (move-overlay vr--minibuffer-message-overlay (point-max) (point-max))
+ (overlay-put vr--minibuffer-message-overlay 'after-string message)))
+
+(defun vr/minibuffer-help-regexp ()
+ (vr--minibuffer-message (format (substitute-command-keys "\\<vr/minibuffer-regexp-keymap>\\[vr--minibuffer-help]: helps \\[vr--shortcut-toggle-limit]: toggle show all"))))
+
+(defun vr/minibuffer-help-replace ()
+ (vr--minibuffer-message (format (substitute-command-keys "\\<vr/minibuffer-replace-keymap>\\[vr--minibuffer-help]: help \\[vr--shortcut-show-matches]: show matches/groups, \\[vr--shortcut-toggle-preview]: toggle preview, \\[vr--shortcut-toggle-limit]: toggle show all"))))
+
+(defun vr--minibuffer-help ()
+ (interactive)
+ (cond ((equal vr--in-minibuffer 'vr--minibuffer-regexp)
+ (vr/minibuffer-help-regexp))
+ ((equal vr--in-minibuffer 'vr--minibuffer-replace)
+ (vr/minibuffer-help-replace))))
+
+;;; overlay functions
+
+(defun vr--get-overlay (i j)
+ "i: match index, j: submatch index"
+ (let (overlay)
+ (setq overlay (gethash (list i j) vr--overlays))
+ (unless overlay ;; create new one if overlay does not exist yet
+ (setq overlay (make-overlay 0 0))
+ (if (= 0 j)
+ (overlay-put overlay 'face (nth (mod i (length vr--match-faces)) vr--match-faces))
+ (overlay-put overlay 'face (nth (mod j (length vr--group-faces)) vr--group-faces)))
+ (overlay-put overlay 'priority (+ vr--overlay-priority (if (= j 0) 0 1)))
+ (overlay-put overlay 'vr-ij (list i j))
+ (puthash (list i j) overlay vr--overlays))
+ overlay))
+
+(defun vr--delete-overlays ()
+ "Delete all visible overlays."
+ (mapc (lambda (overlay)
+ (delete-overlay overlay))
+ vr--visible-overlays)
+ (setq vr--visible-overlays (list)))
+
+(defun vr--delete-overlay-display (overlay)
+ (overlay-put overlay 'display nil)
+ (overlay-put overlay 'after-string nil)
+ (overlay-put overlay 'priority vr--overlay-priority))
+
+(defun vr--delete-overlay-displays ()
+ "Delete the display of all visible overlays. Call before vr--delete-overlays."
+ (mapc (lambda (overlay)
+ (cl-multiple-value-bind (i j) (overlay-get overlay 'vr-ij)
+ (when (= 0 j)
+ (vr--delete-overlay-display overlay))))
+ vr--visible-overlays))
+
+;;; hooks
+
+(defun vr--update (beg end len)
+ (when (and vr--in-minibuffer (minibufferp))
+ ;; minibuffer-up temporarily deletes minibuffer contents before inserting new one.
+ ;; don't do anything then as the messages shown by visual-regexp are irritating while browsing the history.
+ (unless (and (string= "" (minibuffer-contents-no-properties))
+ (equal last-command 'previous-history-element))
+ ;; do something when minibuffer contents changes
+ (unless (string= vr--last-minibuffer-contents (minibuffer-contents-no-properties))
+ (setq vr--last-minibuffer-contents (minibuffer-contents-no-properties))
+ ;; minibuffer contents has changed, update visual feedback.
+ ;; not using after-change-hook because this hook applies to the whole minibuffer, including minibuffer-messages
+ ;; that disappear after a while.
+ (cond ((equal vr--in-minibuffer 'vr--minibuffer-regexp)
+ (vr--feedback))
+ ((equal vr--in-minibuffer 'vr--minibuffer-replace)
+ (vr--do-replace-feedback)))))))
+(add-hook 'after-change-functions 'vr--update)
+
+(defun vr--minibuffer-setup ()
+ "Setup prompt and help when entering minibuffer."
+ (when vr--in-minibuffer
+ (progn
+ (vr--update-minibuffer-prompt)
+ (when vr/auto-show-help (vr--minibuffer-help)))))
+(add-hook 'minibuffer-setup-hook 'vr--minibuffer-setup)
+
+;;; helper functions
+
+(defun vr--target-window ()
+ (if vr--target-buffer
+ (get-buffer-window vr--target-buffer)
+ nil))
+
+(defun vr--compose-messages (&rest msgs)
+ (mapconcat 'identity (delq nil (mapcar (lambda (msg) (if (or (not msg) (string= "" msg)) nil msg)) msgs)) " - "))
+
+;;; show feedback functions
+(defun vr--feedback-function (forward feedback-limit callback)
+ "Feedback function for emacs-style regexp search"
+ (let ((message-line "")
+ (err))
+ (with-current-buffer vr--target-buffer
+ (save-excursion
+ (goto-char (if forward vr--target-buffer-start vr--target-buffer-end))
+ (let ((i 0)
+ (looping t))
+ (while (and looping
+ (condition-case err
+ (if forward
+ (re-search-forward regexp-string vr--target-buffer-end t)
+ (re-search-backward regexp-string vr--target-buffer-start t))
+ (invalid-regexp (progn (setq message-line (car (cdr err))) nil))))
+ (when (or (not feedback-limit) (< i feedback-limit)) ;; let outer loop finish so we can get the matches count
+ (cl-loop for (start end) on (match-data) by 'cddr
+ for j from 0
+ when (and start end)
+ do
+ (funcall callback i j start end)))
+ (when (= (match-beginning 0) (match-end 0))
+ (cond ;; don't get stuck on zero-width matches
+ ((and forward (> vr--target-buffer-end (point))) (forward-char))
+ ((and (not forward) (< vr--target-buffer-start (point))) (backward-char))
+ (t (setq looping nil))))
+ (setq i (1+ i)))
+ (if (string= "" message-line)
+ (setq message-line (format "%s matches" i))))))
+ message-line))
+
+(defun vr--feedback-match-callback (i j begin end)
+ (with-current-buffer vr--target-buffer
+ (save-excursion
+ (when (= 0 i) ;; make first match visible
+ (with-selected-window (vr--target-window)
+ (goto-char end)))
+ (let ((overlay (vr--get-overlay i j)))
+ (move-overlay overlay begin end vr--target-buffer)
+ (if (and (= 0 j) (= begin end)) ;; empty match; indicate by a pipe
+ (overlay-put overlay 'after-string (propertize "|" 'face (nth (mod i (length vr--match-faces)) vr--match-faces) 'help-echo "empty match"))
+ (overlay-put overlay 'after-string nil))
+ (setq vr--visible-overlays (cons overlay vr--visible-overlays)))
+ ;; mark if we have reached the specified feedback limit
+ (when (and vr--feedback-limit (= vr--feedback-limit (1+ i)) )
+ (setq limit-reached t)))))
+
+(defun vr--feedback (&optional inhibit-message)
+ "Show visual feedback for matches."
+ (vr--delete-overlays)
+ (let ((limit-reached nil)
+ message-line)
+ (setq message-line
+ (let ((regexp-string))
+ (condition-case err
+ (progn
+ (setq regexp-string (vr--get-regexp-string))
+ (vr--feedback-function t vr--feedback-limit 'vr--feedback-match-callback))
+ (error (vr--format-error err)))))
+ (unless inhibit-message
+ (let ((msg (vr--compose-messages message-line (when limit-reached (format "%s matches shown, hit C-c a to show all" vr--feedback-limit)))))
+ (unless (string= "" msg)
+ (vr--minibuffer-message msg))))))
+
+(defun vr--get-replacement (replacement match-data i)
+ (with-current-buffer vr--target-buffer
+ (let*
+ ;; emulate case-conversion of (perform-replace)
+ ((case-fold-search (if (and case-fold-search search-upper-case)
+ (ignore-errors (isearch-no-upper-case-p (vr--get-regexp-string) t))
+ case-fold-search))
+ (nocasify (not (and case-replace case-fold-search))))
+ ;; we need to set the match data again, s.t. match-substitute-replacement works correctly.
+ ;; (match-data) could have been modified in the meantime, e.g. by vr--get-regexp-string->pcre-to-elisp.
+ (set-match-data match-data)
+ (if (stringp replacement)
+ (match-substitute-replacement replacement nocasify)
+ (match-substitute-replacement (funcall (car replacement) (cdr replacement) i) nocasify)))))
+
+(defun vr--do-replace-feedback-match-callback (replacement match-data i)
+ (let ((begin (cl-first match-data))
+ (end (cl-second match-data))
+ (replacement (vr--get-replacement replacement match-data i)))
+ (let* ((overlay (vr--get-overlay i 0))
+ (empty-match (= begin end)))
+ (move-overlay overlay begin end vr--target-buffer)
+ (vr--delete-overlay-display overlay)
+ (let ((current-face (nth (mod i (length vr--match-faces)) vr--match-faces)))
+ (if (or empty-match vr--replace-preview)
+ (progn
+ (overlay-put overlay (if empty-match 'after-string 'display) (propertize replacement 'face current-face))
+ (overlay-put overlay 'priority (+ vr--overlay-priority 2)))
+ (progn
+ (overlay-put overlay 'after-string
+ (concat (propertize vr/match-separator-string 'face
+ (if vr/match-separator-use-custom-face
+ 'vr/match-separator-face
+ current-face))
+ (propertize replacement 'face current-face)))
+ (overlay-put overlay 'priority (+ vr--overlay-priority 0))))))))
+
+(defun vr--get-replacements (feedback feedback-limit)
+ "Get replacements using emacs-style regexp."
+ (let ((regexp-string)
+ (message-line "")
+ (i 0)
+ (limit-reached nil)
+ (replacements (list))
+ (err)
+ (buffer-contents (with-current-buffer vr--target-buffer
+ (buffer-substring-no-properties (point-min) (point-max)))))
+
+ (condition-case err
+ (progn
+ ;; can signal invalid-regexp
+ (setq regexp-string (vr--get-regexp-string))
+
+ (with-current-buffer vr--target-buffer
+ (goto-char vr--target-buffer-start)
+ (let ((looping t))
+ (while (and
+ looping
+ (condition-case err
+ (re-search-forward regexp-string vr--target-buffer-end t)
+ ('invalid-regexp (progn (setq message-line (car (cdr err))) nil))))
+ (condition-case err
+ (progn
+ (if (or (not feedback) (not feedback-limit) (< i feedback-limit))
+ (setq replacements (cons
+ (let ((match-data (mapcar 'marker-position (match-data))))
+ (list (query-replace-compile-replacement replace-string t) match-data i))
+ replacements))
+ (setq limit-reached t))
+ (when (= (match-beginning 0) (match-end 0))
+ (if (> vr--target-buffer-end (point))
+ (forward-char) ;; don't get stuck on zero-width matches
+ (setq looping nil)))
+ (setq i (1+ i)))
+ ('error (progn
+ (setq message-line (vr--format-error err))
+ (setq replacements (list))
+ (setq looping nil))))))))
+ (invalid-regexp (setq message-line (car (cdr err))))
+ (error (setq message-line (vr--format-error err))))
+ (if feedback
+ (if (string= "" message-line)
+ (setq message-line (vr--compose-messages (format "%s matches" i) (when limit-reached (format "%s matches shown, hit C-c a to show all" feedback-limit)))))
+ (setq message-line (format "replaced %d matches" i)))
+ (list replacements message-line)))
+
+(defun vr--do-replace-feedback ()
+ "Show visual feedback for replacements."
+ (vr--feedback t) ;; only really needed when regexp has not been changed from default (=> no overlays have been created)
+ (let ((replace-string (minibuffer-contents-no-properties)))
+ (cl-multiple-value-bind (replacements message-line) (vr--get-replacements t vr--feedback-limit)
+ ;; visual feedback for matches
+ (condition-case err
+ (mapc (lambda (replacement-info) (apply 'vr--do-replace-feedback-match-callback replacement-info)) replacements)
+ ('error (setq message-line (vr--format-error err))))
+ (unless (string= "" message-line)
+ (vr--minibuffer-message message-line)))))
+
+;;; vr/replace
+
+(defun vr--do-replace (&optional silent)
+ "Replace matches."
+ (vr--delete-overlay-displays)
+ (vr--delete-overlays)
+ (let ((replace-string vr--replace-string))
+ (cl-multiple-value-bind (replacements message-line) (vr--get-replacements nil nil)
+ (let ((replace-count 0)
+ (cumulative-offset 0)
+ last-match-data)
+ (cl-loop for replacement-info in replacements
+ for counter from 0 do
+ (setq replace-count (1+ replace-count))
+ (cl-multiple-value-bind (replacement match-data i) replacement-info
+ ;; replace match
+ (let* ((replacement (vr--get-replacement replacement match-data i))
+ (begin (cl-first match-data))
+ (end (cl-second match-data)))
+ (with-current-buffer vr--target-buffer
+ (save-excursion
+ ;; first insert, then delete
+ ;; this ensures that if we had an active region before, the replaced match is still part of the region
+ (goto-char begin)
+ (insert replacement)
+ (setq cumulative-offset (+ cumulative-offset (- (point) end)))
+ (delete-char (- end begin))))
+ (when (= 0 counter)
+ (setq last-match-data match-data))
+ )))
+ (unless (or silent (string= "" message-line))
+ (vr--minibuffer-message message-line))
+ ;; needed to correctly position the mark after query replace (finished with 'automatic ('!'))
+ (set-match-data (mapcar (lambda (el) (+ cumulative-offset el)) last-match-data))
+ replace-count))))
+
+(defun vr--interactive-get-args (mode calling-func)
+ "Get interactive args for the vr/replace and vr/query-replace functions."
+ (unwind-protect
+ (progn
+ (let ((buffer-read-only t)) ;; make target buffer
+ (when vr--in-minibuffer (error "visual-regexp already in use."))
+ (setq vr--calling-func calling-func)
+ (setq vr--target-buffer (current-buffer))
+ (setq vr--target-buffer-start (if (region-active-p)
+ (region-beginning)
+ (point)))
+ (setq vr--target-buffer-end (if (region-active-p)
+ (region-end)
+ (point-max)))
+
+ (run-hooks 'vr/initialize-hook)
+ (setq vr--feedback-limit vr/default-feedback-limit)
+
+ (setq vr--replace-preview vr/default-replace-preview)
+
+ (save-excursion
+ ;; deactivate mark so that we can see our faces instead of region-face.
+ (deactivate-mark)
+ (progn
+ (setq vr--in-minibuffer 'vr--minibuffer-regexp)
+ (setq vr--last-minibuffer-contents "")
+ (setq vr--regexp-string
+ (read-from-minibuffer
+ " " ;; prompt will be set in vr--minibuffer-setup
+ nil vr/minibuffer-regexp-keymap
+ nil vr/query-replace-from-history-variable))
+ ;;(setq vr--regexp-string (format "%s%s" (vr--get-regexp-modifiers-prefix) vr--regexp-string))
+
+ (when (equal mode 'vr--mode-regexp-replace)
+ (setq vr--in-minibuffer 'vr--minibuffer-replace)
+ (setq vr--last-minibuffer-contents "")
+ (setq vr--replace-string
+ (read-from-minibuffer
+ " " ;; prompt will be set in vr--minibuffer-setup
+ nil vr/minibuffer-replace-keymap
+ nil vr/query-replace-to-history-variable)))))
+ ;; Successfully got the args, deactivate mark now. If the command was aborted (C-g), the mark (region) would remain active.
+ (deactivate-mark)
+ (cond ((equal mode 'vr--mode-regexp-replace)
+ (list vr--regexp-string
+ vr--replace-string
+ vr--target-buffer-start
+ vr--target-buffer-end))
+ ((equal mode 'vr--mode-regexp)
+ (list vr--regexp-string
+ vr--target-buffer-start
+ vr--target-buffer-end)))))
+ (progn ;; execute on finish
+ (setq vr--in-minibuffer nil)
+ (setq vr--calling-func nil)
+ (unless (overlayp vr--minibuffer-message-overlay)
+ (delete-overlay vr--minibuffer-message-overlay))
+ (vr--delete-overlay-displays)
+ (vr--delete-overlays))))
+
+(add-hook 'multiple-cursors-mode-enabled-hook
+ ;; run vr/mc-mark once per cursor by default (do not ask the user)
+ (lambda ()
+ (when (boundp 'mc--default-cmds-to-run-once)
+ (add-to-list 'mc--default-cmds-to-run-once 'vr/mc-mark))))
+
+;;;###autoload
+(defun vr/mc-mark (regexp start end)
+ "Convert regexp selection to multiple cursors."
+ (require 'multiple-cursors)
+ (interactive
+ (vr--interactive-get-args 'vr--mode-regexp 'vr--calling-func-mc-mark))
+ (with-current-buffer vr--target-buffer
+ (mc/remove-fake-cursors)
+ (activate-mark)
+ (let ((regexp-string (vr--get-regexp-string))
+ ;; disable deactivating of mark after buffer-editing commands
+ ;; (which happens for example in visual-regexp-steroids/vr--parse-matches
+ ;; during the callback).
+ (deactivate-mark nil)
+ (first-fake-cursor nil))
+ (vr--feedback-function t nil (lambda (i j begin end)
+ (with-current-buffer vr--target-buffer
+ (goto-char end)
+ (push-mark begin)
+ ;; temporarily enable transient mark mode
+ (activate-mark)
+ (let ((fc (mc/create-fake-cursor-at-point)))
+ (unless first-fake-cursor
+ (setq first-fake-cursor fc))))))
+
+ ;; one fake cursor too many, replace first one with
+ ;; the regular cursor.
+ (when first-fake-cursor
+ (mc/pop-state-from-overlay first-fake-cursor)))
+ (mc/maybe-multiple-cursors-mode)))
+
+;;;###autoload
+(defun vr/replace (regexp replace start end)
+ "Regexp-replace with live visual feedback."
+ (interactive
+ (vr--interactive-get-args 'vr--mode-regexp-replace 'vr--calling-func-replace))
+ (unwind-protect
+ (progn
+ (when vr--in-minibuffer (error "visual-regexp already in use."))
+ (setq vr--target-buffer (current-buffer)
+ vr--target-buffer-start start
+ vr--target-buffer-end end
+ vr--regexp-string regexp
+ vr--replace-string replace)
+ ;; do replacement
+ (vr--do-replace))
+ ;; execute on finish
+ (setq vr--in-minibuffer nil)))
+
+;; query-replace-regexp starts here
+
+(defvar vr--query-replacements nil)
+;; we redefine the help text from replace.el to remove the commands we don't support.
+
+(defconst vr--query-replace-help
+ "Type Space or `y' to replace one match, Delete or `n' to skip to next,
+RET or `q' to exit, Period to replace one match and exit,
+Comma to replace but not move point immediately,
+p to preview the replacement (like 'C-c p' during construction of the regexp),
+C-r [not supported in visual-regexp],
+C-w [not supported in visual-regexp],
+C-l to clear the screen, redisplay, and offer same replacement again,
+! to replace all remaining matches with no more questions,
+^ [not supported in visual-regexp],
+E [not supported in visual-regexp]"
+ "Help message while in `vr/query-replace'.")
+
+(defvar vr--query-replace-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map query-replace-map)
+ ;; the following replace.el commands are not supported by visual-regexp.
+ (define-key map "e" nil)
+ (define-key map "E" nil)
+ (define-key map "\C-r" nil)
+ (define-key map "\C-w" nil)
+ (define-key map "^" nil)
+ (define-key map "p" 'toggle-preview)
+ map
+ ))
+
+;;;###autoload
+(defun vr/query-replace (regexp replace start end)
+ "Use vr/query-replace like you would use query-replace-regexp."
+ (interactive
+ (vr--interactive-get-args 'vr--mode-regexp-replace 'vr--calling-func-query-replace))
+ (unwind-protect
+ (progn
+ (when vr--in-minibuffer (error "visual-regexp already in use."))
+ (setq vr--target-buffer (current-buffer)
+ vr--target-buffer-start start
+ vr--target-buffer-end end
+ vr--regexp-string regexp
+ vr--replace-string replace)
+ (let ((replace-string vr--replace-string))
+ (setq vr--query-replacements (nreverse (car (vr--get-replacements nil nil)))))
+ (vr--perform-query-replace regexp nil))
+ ;; execute on finish
+ (setq vr--in-minibuffer nil)))
+
+(defun vr--perform-query-replace (from-string &optional map)
+ ;; This function is a heavily modified version of (perform-replace) from replace.el.
+ ;; The original plan was to use the original perform-replace, but various issues stood in the way.
+ (or map (setq map vr--query-replace-map))
+ (and minibuffer-auto-raise
+ (raise-frame (window-frame (minibuffer-window))))
+ (let* ((next-replacement nil) ;; replacement string for current match
+ (keep-going t)
+ (replace-count 0)
+ ;; a match can be replaced by a longer/shorter replacement. cumulate the difference
+ (cumulative-offset 0)
+ (recenter-last-op nil) ; Start cycling order with initial position.
+ (message
+ (apply 'propertize
+ (substitute-command-keys
+ "Query replacing %s with %s: (\\<vr--query-replace-map>\\[help] for help) ")
+ minibuffer-prompt-properties)))
+
+ ;; show visual feedback for all matches
+ (mapc (lambda (replacement-info)
+ (cl-multiple-value-bind (replacement match-data i) replacement-info
+ (vr--feedback-match-callback i 0 (cl-first match-data) (cl-second match-data))))
+ vr--query-replacements)
+
+ (goto-char vr--target-buffer-start)
+ (push-mark)
+ (undo-boundary)
+ (unwind-protect
+ ;; Loop finding occurrences that perhaps should be replaced.
+ (while (and keep-going vr--query-replacements)
+ ;; Advance replacement list
+ (cl-multiple-value-bind (replacement match-data i) (car vr--query-replacements)
+ (setq match-data (mapcar (lambda (el) (+ cumulative-offset el)) match-data))
+ (let ((begin (cl-first match-data))
+ (end (cl-second match-data)))
+ (setq next-replacement-orig replacement)
+ (setq next-replacement (vr--get-replacement replacement match-data replace-count))
+ (goto-char begin)
+ (setq vr--query-replacements (cdr vr--query-replacements))
+
+ ;; default for new occurrence: no preview
+ (setq vr--replace-preview nil)
+
+ (undo-boundary)
+ (let (done replaced key def)
+ ;; Loop reading commands until one of them sets done,
+ ;; which means it has finished handling this
+ ;; occurrence.
+ (while (not done)
+ ;; show replacement feedback for current occurrence
+ (unless replaced
+ (vr--do-replace-feedback-match-callback next-replacement-orig match-data i))
+ ;; Bind message-log-max so we don't fill up the message log
+ ;; with a bunch of identical messages.
+ (let ((message-log-max nil))
+ (message message from-string next-replacement))
+ (setq key (read-event))
+ (setq key (vector key))
+ (setq def (lookup-key map key))
+
+ ;; can use replace-match afterwards
+ (set-match-data match-data)
+
+ ;; Restore the match data while we process the command.
+ (cond ((eq def 'help)
+ (with-output-to-temp-buffer "*Help*"
+ (princ
+ (concat "Query replacing visual-regexp "
+ from-string " with "
+ next-replacement ".\n\n"
+ (substitute-command-keys
+ vr--query-replace-help)))
+ (with-current-buffer standard-output
+ (help-mode))))
+ ((eq def 'exit)
+ (setq keep-going nil
+ done t))
+ ((eq def 'act)
+ (unless replaced
+ (replace-match next-replacement t t)
+ (setq replace-count (1+ replace-count)))
+ (setq done t
+ replaced t))
+ ((eq def 'act-and-exit)
+ (unless replaced
+ (replace-match next-replacement t t)
+ (setq replace-count (1+ replace-count)))
+ (setq keep-going nil
+ done t
+ replaced t))
+ ((eq def 'act-and-show)
+ (unless replaced
+ (replace-match next-replacement t t)
+ (setq replace-count (1+ replace-count))
+ (setq replaced t)))
+ ((eq def 'toggle-preview)
+ (setq vr--replace-preview (not vr--replace-preview)))
+ ((eq def 'automatic)
+ (setq vr--target-buffer-start (match-beginning 0)
+ vr--target-buffer-end (+ cumulative-offset vr--target-buffer-end))
+ (setq replace-count (+ replace-count (vr--do-replace t)))
+ (setq done t
+ replaced t
+ keep-going nil))
+ ((eq def 'skip)
+ (setq done t))
+ ((eq def 'recenter)
+ ;; `this-command' has the value `query-replace',
+ ;; so we need to bind it to `recenter-top-bottom'
+ ;; to allow it to detect a sequence of `C-l'.
+ (let ((this-command 'recenter-top-bottom)
+ (last-command 'recenter-top-bottom))
+ (recenter-top-bottom)))
+ (t
+ (setq this-command 'mode-exited)
+ (setq keep-going nil)
+ (setq unread-command-events
+ (append (listify-key-sequence key)
+ unread-command-events))
+ (setq done t)))
+ (when replaced
+ (setq cumulative-offset (+ cumulative-offset (- (length next-replacement) (- end begin)))))
+ (unless (eq def 'recenter)
+ ;; Reset recenter cycling order to initial position.
+ (setq recenter-last-op nil))
+ ;; in case of 'act-and-show: delete overlay display or it will still be
+ ;; visible even though the replacement has been made
+ (when replaced (vr--delete-overlay-display (vr--get-overlay i 0)))))
+
+ ;; occurrence has been handled
+ ;; delete feedback overlay
+ (delete-overlay (vr--get-overlay i 0)))))
+
+ ;; unwind
+ (progn
+ (vr--delete-overlay-displays)
+ (vr--delete-overlays)
+ ;; (replace-dehighlight)
+ ))
+ (unless unread-command-events
+ ;; point is set to the end of the last occurrence.
+ (goto-char (match-end 0))
+ (message "Replaced %d occurrence%s"
+ replace-count
+ (if (= replace-count 1) "" "s")))))
+
+(provide 'visual-regexp)
+
+;;; visual-regexp.el ends here
+++ /dev/null
-;;; htmlize.el --- Convert buffer text and decorations to HTML.
-
-;; Copyright (C) 1997-2003,2005,2006,2009,2011,2012 Hrvoje Niksic
-
-;; Author: Hrvoje Niksic <hniksicNOSPAMxemacs.org>
-;; Keywords: hypermedia, extensions
-;; Version: 1.47
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This package converts the buffer text and the associated
-;; decorations to HTML. Mail to <hniksicNOSPAMxemacs.org> to discuss
-;; features and additions. All suggestions are more than welcome.
-
-;; To use it, just switch to the buffer you want HTML-ized and type
-;; `M-x htmlize-buffer'. You will be switched to a new buffer that
-;; contains the resulting HTML code. You can edit and inspect this
-;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file'
-;; will find a file, fontify it, and save the HTML version in
-;; FILE.html, without any additional intervention. `M-x
-;; htmlize-many-files' allows you to htmlize any number of files in
-;; the same manner. `M-x htmlize-many-files-dired' does the same for
-;; files marked in a dired buffer.
-
-;; htmlize supports three types of HTML output, selected by setting
-;; `htmlize-output-type': `css', `inline-css', and `font'. In `css'
-;; mode, htmlize uses cascading style sheets to specify colors; it
-;; generates classes that correspond to Emacs faces and uses <span
-;; class=FACE>...</span> to color parts of text. In this mode, the
-;; produced HTML is valid under the 4.01 strict DTD, as confirmed by
-;; the W3C validator. `inline-css' is like `css', except the CSS is
-;; put directly in the STYLE attribute of the SPAN element, making it
-;; possible to paste the generated HTML into existing HTML documents.
-;; In `font' mode, htmlize uses <font color="...">...</font> to
-;; colorize HTML, which is not standard-compliant, but works better in
-;; older browsers. `css' mode is the default.
-
-;; You can also use htmlize from your Emacs Lisp code. When called
-;; non-interactively, `htmlize-buffer' and `htmlize-region' will
-;; return the resulting HTML buffer, but will not change current
-;; buffer or move the point. htmlize will do its best to work on
-;; non-windowing Emacs sessions but the result will be limited to
-;; colors supported by the terminal.
-
-;; htmlize aims for compatibility with Emacsen version 21 and later.
-;; Please let me know if it doesn't work on the version of XEmacs or
-;; GNU Emacs that you are using. The package relies on the presence
-;; of CL extensions, especially for cross-emacs compatibility; please
-;; don't try to remove that dependency. I see no practical problems
-;; with using the full power of the CL extensions, except that one
-;; might learn to like them too much.
-
-;; The latest version is available as a git repository at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.git>
-;;
-;; The snapshot of the latest release can be obtained at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.cgi>
-;;
-;; You can find a sample of htmlize's output (possibly generated with
-;; an older version) at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.html>
-
-;; Thanks go to the many people who have sent reports and contributed
-;; comments, suggestions, and fixes. They include Ron Gut, Bob
-;; Weiner, Toni Drabik, Peter Breton, Ville Skytta, Thomas Vogels,
-;; Juri Linkov, Maciek Pasternacki, and many others.
-
-;; User quotes: "You sir, are a sick, sick, _sick_ person. :)"
-;; -- Bill Perry, author of Emacs/W3
-
-\f
-;;; Code:
-
-(require 'cl)
-(eval-when-compile
- (defvar unresolved)
- (if (string-match "XEmacs" emacs-version)
- (byte-compiler-options
- (warnings (- unresolved))))
- (defvar font-lock-auto-fontify)
- (defvar font-lock-support-mode)
- (defvar global-font-lock-mode))
-
-(defconst htmlize-version "1.47")
-
-(defgroup htmlize nil
- "Convert buffer text and faces to HTML."
- :group 'hypermedia)
-
-(defcustom htmlize-head-tags ""
- "Additional tags to insert within HEAD of the generated document."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-output-type 'css
- "Output type of generated HTML, one of `css', `inline-css', or `font'.
-When set to `css' (the default), htmlize will generate a style sheet
-with description of faces, and use it in the HTML document, specifying
-the faces in the actual text with <span class=\"FACE\">.
-
-When set to `inline-css', the style will be generated as above, but
-placed directly in the STYLE attribute of the span ELEMENT: <span
-style=\"STYLE\">. This makes it easier to paste the resulting HTML to
-other documents.
-
-When set to `font', the properties will be set using layout tags
-<font>, <b>, <i>, <u>, and <strike>.
-
-`css' output is normally preferred, but `font' is still useful for
-supporting old, pre-CSS browsers, and both `inline-css' and `font' for
-easier embedding of colorized text in foreign HTML documents (no style
-sheet to carry around)."
- :type '(choice (const css) (const inline-css) (const font))
- :group 'htmlize)
-
-(defcustom htmlize-use-images t
- "Whether htmlize generates `img' for images attached to buffer contents."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-force-inline-images nil
- "Non-nil means generate all images inline using data URLs.
-Normally htmlize converts image descriptors with :file properties to
-relative URIs, and those with :data properties to data URIs. With this
-flag set, the images specified as a file name are loaded into memory and
-embedded in the HTML as data URIs."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-max-alt-text 100
- "Maximum size of text to use as ALT text in images.
-
-Normally when htmlize encounters text covered by the `display' property
-that specifies an image, it generates an `alt' attribute containing the
-original text. If the text is larger than `htmlize-max-alt-text' characters,
-this will not be done.")
-
-(defcustom htmlize-transform-image 'htmlize-default-transform-image
- "Function called to modify the image descriptor.
-
-The function is called with the image descriptor found in the buffer and
-the text the image is supposed to replace. It should return a (possibly
-different) image descriptor property list or a replacement string to use
-instead of of the original buffer text.
-
-Returning nil is the same as returning the original text."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-generate-hyperlinks t
- "Non-nil means auto-generate the links from URLs and mail addresses in buffer.
-
-This is on by default; set it to nil if you don't want htmlize to
-autogenerate such links. Note that this option only turns off automatic
-search for contents that looks like URLs and converting them to links.
-It has no effect on whether htmlize respects the `htmlize-link' property."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-hyperlink-style "
- a {
- color: inherit;
- background-color: inherit;
- font: inherit;
- text-decoration: inherit;
- }
- a:hover {
- text-decoration: underline;
- }
-"
- "The CSS style used for hyperlinks when in CSS mode."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-replace-form-feeds t
- "Non-nil means replace form feeds in source code with HTML separators.
-Form feeds are the ^L characters at line beginnings that are sometimes
-used to separate sections of source code. If this variable is set to
-`t', form feed characters are replaced with the <hr> separator. If this
-is a string, it specifies the replacement to use. Note that <pre> is
-temporarily closed before the separator is inserted, so the default
-replacement is effectively \"</pre><hr /><pre>\". If you specify
-another replacement, don't forget to close and reopen the <pre> if you
-want the output to remain valid HTML.
-
-If you need more elaborate processing, set this to nil and use
-htmlize-after-hook."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-html-charset nil
- "The charset declared by the resulting HTML documents.
-When non-nil, causes htmlize to insert the following in the HEAD section
-of the generated HTML:
-
- <meta http-equiv=\"Content-Type\" content=\"text/html; charset=CHARSET\">
-
-where CHARSET is the value you've set for htmlize-html-charset. Valid
-charsets are defined by MIME and include strings like \"iso-8859-1\",
-\"iso-8859-15\", \"utf-8\", etc.
-
-If you are using non-Latin-1 charsets, you might need to set this for
-your documents to render correctly. Also, the W3C validator requires
-submitted HTML documents to declare a charset. So if you care about
-validation, you can use this to prevent the validator from bitching.
-
-Needless to say, if you set this, you should actually make sure that
-the buffer is in the encoding you're claiming it is in. (This is
-normally achieved by using the correct file coding system for the
-buffer.) If you don't understand what that means, you should probably
-leave this option in its default setting."
- :type '(choice (const :tag "Unset" nil)
- string)
- :group 'htmlize)
-
-(defcustom htmlize-convert-nonascii-to-entities t
- "Whether non-ASCII characters should be converted to HTML entities.
-
-When this is non-nil, characters with codes in the 128-255 range will be
-considered Latin 1 and rewritten as \"&#CODE;\". Characters with codes
-above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode
-code point of the character. If the code point cannot be determined,
-the character will be copied unchanged, as would be the case if the
-option were nil.
-
-When the option is nil, the non-ASCII characters are copied to HTML
-without modification. In that case, the web server and/or the browser
-must be set to understand the encoding that was used when saving the
-buffer. (You might also want to specify it by setting
-`htmlize-html-charset'.)
-
-Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point,
-which has nothing to do with the charset the page is in. For example,
-\"©\" *always* refers to the copyright symbol, regardless of charset
-specified by the META tag or the charset sent by the HTTP server. In
-other words, \"©\" is exactly equivalent to \"©\".
-
-For most people htmlize will work fine with this option left at the
-default setting; don't change it unless you know what you're doing."
- :type 'sexp
- :group 'htmlize)
-
-(defcustom htmlize-ignore-face-size 'absolute
- "Whether face size should be ignored when generating HTML.
-If this is nil, face sizes are used. If set to t, sizes are ignored
-If set to `absolute', only absolute size specifications are ignored.
-Please note that font sizes only work with CSS-based output types."
- :type '(choice (const :tag "Don't ignore" nil)
- (const :tag "Ignore all" t)
- (const :tag "Ignore absolute" absolute))
- :group 'htmlize)
-
-(defcustom htmlize-css-name-prefix ""
- "The prefix used for CSS names.
-The CSS names that htmlize generates from face names are often too
-generic for CSS files; for example, `font-lock-type-face' is transformed
-to `type'. Use this variable to add a prefix to the generated names.
-The string \"htmlize-\" is an example of a reasonable prefix."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-use-rgb-txt t
- "Whether `rgb.txt' should be used to convert color names to RGB.
-
-This conversion means determining, for instance, that the color
-\"IndianRed\" corresponds to the (205, 92, 92) RGB triple. `rgb.txt'
-is the X color database that maps hundreds of color names to such RGB
-triples. When this variable is non-nil, `htmlize' uses `rgb.txt' to
-look up color names.
-
-If this variable is nil, htmlize queries Emacs for RGB components of
-colors using `color-instance-rgb-components' and `color-values'.
-This can yield incorrect results on non-true-color displays.
-
-If the `rgb.txt' file is not found (which will be the case if you're
-running Emacs on non-X11 systems), this option is ignored."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-html-major-mode nil
- "The mode the newly created HTML buffer will be put in.
-Set this to nil if you prefer the default (fundamental) mode."
- :type '(radio (const :tag "No mode (fundamental)" nil)
- (function-item html-mode)
- (function :tag "User-defined major mode"))
- :group 'htmlize)
-
-(defvar htmlize-before-hook nil
- "Hook run before htmlizing a buffer.
-The hook functions are run in the source buffer (not the resulting HTML
-buffer).")
-
-(defvar htmlize-after-hook nil
- "Hook run after htmlizing a buffer.
-Unlike `htmlize-before-hook', these functions are run in the generated
-HTML buffer. You may use them to modify the outlook of the final HTML
-output.")
-
-(defvar htmlize-file-hook nil
- "Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
-
-(defvar htmlize-buffer-places)
-\f
-;;; Some cross-Emacs compatibility.
-
-;; I try to conditionalize on features rather than Emacs version, but
-;; in some cases checking against the version *is* necessary.
-(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
-
-;; We need a function that efficiently finds the next change of a
-;; property regardless of whether the change occurred because of a
-;; text property or an extent/overlay.
-(cond
- (htmlize-running-xemacs
- (defun htmlize-next-change (pos prop &optional limit)
- (if prop
- (next-single-char-property-change pos prop nil (or limit (point-max)))
- (next-property-change pos nil (or limit (point-max)))))
- (defun htmlize-next-face-change (pos &optional limit)
- (htmlize-next-change pos 'face limit)))
- (t
- (defun htmlize-next-change (pos prop &optional limit)
- (if prop
- (next-single-char-property-change pos prop nil limit)
- (next-char-property-change pos limit)))
- (defun htmlize-overlay-faces-at (pos)
- (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))
- (defun htmlize-next-face-change (pos &optional limit)
- ;; (htmlize-next-change pos 'face limit) would skip over entire
- ;; overlays that specify the `face' property, even when they
- ;; contain smaller text properties that also specify `face'.
- ;; Emacs display engine merges those faces, and so must we.
- (or limit
- (setq limit (point-max)))
- (let ((next-prop (next-single-property-change pos 'face nil limit))
- (overlay-faces (htmlize-overlay-faces-at pos)))
- (while (progn
- (setq pos (next-overlay-change pos))
- (and (< pos next-prop)
- (equal overlay-faces (htmlize-overlay-faces-at pos)))))
- (setq pos (min pos next-prop))
- ;; Additionally, we include the entire region that specifies the
- ;; `display' property.
- (when (get-char-property pos 'display)
- (setq pos (next-single-char-property-change pos 'display nil limit)))
- pos)))
- (t
- (error "htmlize requires next-single-property-change or \
-next-single-char-property-change")))
-
-(defmacro htmlize-lexlet (&rest letforms)
- (declare (indent 1) (debug let))
- (if (and (boundp 'lexical-binding)
- lexical-binding)
- `(let ,@letforms)
- ;; cl extensions have a macro implementing lexical let
- `(lexical-let ,@letforms)))
-
-;; Simple overlay emulation for XEmacs
-
-(cond
- (htmlize-running-xemacs
- (defalias 'htmlize-make-overlay 'make-extent)
- (defalias 'htmlize-overlay-put 'set-extent-property)
- (defalias 'htmlize-overlay-get 'extent-property)
- (defun htmlize-overlays-in (beg end) (extent-list nil beg end))
- (defalias 'htmlize-delete-overlay 'detach-extent))
- (t
- (defalias 'htmlize-make-overlay 'make-overlay)
- (defalias 'htmlize-overlay-put 'overlay-put)
- (defalias 'htmlize-overlay-get 'overlay-get)
- (defalias 'htmlize-overlays-in 'overlays-in)
- (defalias 'htmlize-delete-overlay 'delete-overlay)))
-
-\f
-;;; Transformation of buffer text: HTML escapes, untabification, etc.
-
-(defvar htmlize-basic-character-table
- ;; Map characters in the 0-127 range to either one-character strings
- ;; or to numeric entities.
- (let ((table (make-vector 128 ?\0)))
- ;; Map characters in the 32-126 range to themselves, others to
- ;; &#CODE entities;
- (dotimes (i 128)
- (setf (aref table i) (if (and (>= i 32) (<= i 126))
- (char-to-string i)
- (format "&#%d;" i))))
- ;; Set exceptions manually.
- (setf
- ;; Don't escape newline, carriage return, and TAB.
- (aref table ?\n) "\n"
- (aref table ?\r) "\r"
- (aref table ?\t) "\t"
- ;; Escape &, <, and >.
- (aref table ?&) "&"
- (aref table ?<) "<"
- (aref table ?>) ">"
- ;; Not escaping '"' buys us a measurable speedup. It's only
- ;; necessary to quote it for strings used in attribute values,
- ;; which htmlize doesn't typically do.
- ;(aref table ?\") """
- )
- table))
-
-;; A cache of HTML representation of non-ASCII characters. Depending
-;; on the setting of `htmlize-convert-nonascii-to-entities', this maps
-;; non-ASCII characters to either "&#<code>;" or "<char>" (mapconcat's
-;; mapper must always return strings). It's only filled as characters
-;; are encountered, so that in a buffer with e.g. French text, it will
-;; only ever contain French accented characters as keys. It's cleared
-;; on each entry to htmlize-buffer-1 to allow modifications of
-;; `htmlize-convert-nonascii-to-entities' to take effect.
-(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
-
-(defun htmlize-protect-string (string)
- "HTML-protect string, escaping HTML metacharacters and I18N chars."
- ;; Only protecting strings that actually contain unsafe or non-ASCII
- ;; chars removes a lot of unnecessary funcalls and consing.
- (if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
- string
- (mapconcat (lambda (char)
- (cond
- ((< char 128)
- ;; ASCII: use htmlize-basic-character-table.
- (aref htmlize-basic-character-table char))
- ((gethash char htmlize-extended-character-cache)
- ;; We've already seen this char; return the cached
- ;; string.
- )
- ((not htmlize-convert-nonascii-to-entities)
- ;; If conversion to entities is not desired, always
- ;; copy the char literally.
- (setf (gethash char htmlize-extended-character-cache)
- (char-to-string char)))
- ((< char 256)
- ;; Latin 1: no need to call encode-char.
- (setf (gethash char htmlize-extended-character-cache)
- (format "&#%d;" char)))
- ((encode-char char 'ucs)
- ;; Must check if encode-char works for CHAR;
- ;; it fails for Arabic and possibly elsewhere.
- (setf (gethash char htmlize-extended-character-cache)
- (format "&#%d;" (encode-char char 'ucs))))
- (t
- ;; encode-char doesn't work for this char. Copy it
- ;; unchanged and hope for the best.
- (setf (gethash char htmlize-extended-character-cache)
- (char-to-string char)))))
- string "")))
-
-(defun htmlize-attr-escape (string)
- ;; Like htmlize-protect-string, but also escapes double-quoted
- ;; strings to make it usable in attribute values.
- (setq string (htmlize-protect-string string))
- (if (not (string-match "\"" string))
- string
- (mapconcat (lambda (char)
- (if (eql char ?\")
- """
- (char-to-string char)))
- string "")))
-
-(defsubst htmlize-concat (list)
- (if (and (consp list) (null (cdr list)))
- ;; Don't create a new string in the common case where the list only
- ;; consists of one element.
- (car list)
- (apply #'concat list)))
-
-(defun htmlize-format-link (linkprops text)
- (let ((uri (if (stringp linkprops)
- linkprops
- (plist-get linkprops :uri)))
- (escaped-text (htmlize-protect-string text)))
- (if uri
- (format "<a href=\"%s\">%s</a>" (htmlize-attr-escape uri) escaped-text)
- escaped-text)))
-
-(defun htmlize-escape-or-link (string)
- ;; Escape STRING and/or add hyperlinks. STRING comes from a
- ;; `display' property.
- (let ((pos 0) (end (length string)) outlist)
- (while (< pos end)
- (let* ((link (get-char-property pos 'htmlize-link string))
- (next-link-change (next-single-property-change
- pos 'htmlize-link string end))
- (chunk (substring string pos next-link-change)))
- (push
- (cond (link
- (htmlize-format-link link chunk))
- ((get-char-property 0 'htmlize-literal chunk)
- chunk)
- (t
- (htmlize-protect-string chunk)))
- outlist)
- (setq pos next-link-change)))
- (htmlize-concat (nreverse outlist))))
-
-(defun htmlize-display-prop-to-html (display text)
- (let (desc)
- (cond ((stringp display)
- ;; Emacs ignores recursive display properties.
- (htmlize-escape-or-link display))
- ((not (eq (car-safe display) 'image))
- (htmlize-protect-string text))
- ((null (setq desc (funcall htmlize-transform-image
- (cdr display) text)))
- (htmlize-escape-or-link text))
- ((stringp desc)
- (htmlize-escape-or-link desc))
- (t
- (htmlize-generate-image desc text)))))
-
-(defun htmlize-string-to-html (string)
- ;; Convert the string to HTML, including images attached as
- ;; `display' property and links as `htmlize-link' property. In a
- ;; string without images or links, this is equivalent to
- ;; `htmlize-protect-string'.
- (let ((pos 0) (end (length string)) outlist)
- (while (< pos end)
- (let* ((display (get-char-property pos 'display string))
- (next-display-change (next-single-property-change
- pos 'display string end))
- (chunk (substring string pos next-display-change)))
- (push
- (if display
- (htmlize-display-prop-to-html display chunk)
- (htmlize-escape-or-link chunk))
- outlist)
- (setq pos next-display-change)))
- (htmlize-concat (nreverse outlist))))
-
-(defun htmlize-default-transform-image (imgprops _text)
- "Default transformation of image descriptor to something usable in HTML.
-
-If `htmlize-use-images' is nil, the function always returns nil, meaning
-use original text. Otherwise, it tries to find the image for images that
-specify a file name. If `htmlize-force-inline-images' is non-nil, it also
-converts the :file attribute to :data and returns the modified property
-list."
- (when htmlize-use-images
- (when (plist-get imgprops :file)
- (let ((location (plist-get (cdr (find-image (list imgprops))) :file)))
- (when location
- (setq imgprops (plist-put (copy-list imgprops) :file location)))))
- (if htmlize-force-inline-images
- (let ((location (plist-get imgprops :file))
- data)
- (when location
- (with-temp-buffer
- (condition-case nil
- (progn
- (insert-file-contents-literally location)
- (setq data (buffer-string)))
- (error nil))))
- ;; if successful, return the new plist, otherwise return
- ;; nil, which will use the original text
- (and data
- (plist-put (plist-put imgprops :file nil)
- :data data)))
- imgprops)))
-
-(defun htmlize-alt-text (_imgprops origtext)
- (and (/= (length origtext) 0)
- (<= (length origtext) htmlize-max-alt-text)
- (not (string-match "[\0-\x1f]" origtext))
- origtext))
-
-(defun htmlize-generate-image (imgprops origtext)
- (let* ((alt-text (htmlize-alt-text imgprops origtext))
- (alt-attr (if alt-text
- (format " alt=\"%s\"" (htmlize-attr-escape alt-text))
- "")))
- (cond ((plist-get imgprops :file)
- ;; Try to find the image in image-load-path
- (let* ((found-props (cdr (find-image (list imgprops))))
- (file (or (plist-get found-props :file)
- (plist-get imgprops :file))))
- (format "<img src=\"%s\"%s />"
- (htmlize-attr-escape (file-relative-name file))
- alt-attr)))
- ((plist-get imgprops :data)
- (format "<img src=\"data:image/%s;base64,%s\"%s />"
- (or (plist-get imgprops :type) "")
- (base64-encode-string (plist-get imgprops :data))
- alt-attr)))))
-
-(defconst htmlize-ellipsis "...")
-(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis)
-
-(defun htmlize-match-inv-spec (inv)
- (member* inv buffer-invisibility-spec
- :key (lambda (i)
- (if (symbolp i) i (car i)))))
-
-(defun htmlize-decode-invisibility-spec (invisible)
- ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted.
-
- (if (not (listp buffer-invisibility-spec))
- ;; If buffer-invisibility-spec is not a list, then all
- ;; characters with non-nil `invisible' property are visible.
- (not invisible)
-
- ;; Otherwise, the value of a non-nil `invisible' property can be:
- ;; 1. a symbol -- make the text invisible if it matches
- ;; buffer-invisibility-spec.
- ;; 2. a list of symbols -- make the text invisible if
- ;; any symbol in the list matches
- ;; buffer-invisibility-spec.
- ;; If the match of buffer-invisibility-spec has a non-nil
- ;; CDR, replace the invisible text with an ellipsis.
- (let ((match (if (symbolp invisible)
- (htmlize-match-inv-spec invisible)
- (some #'htmlize-match-inv-spec invisible))))
- (cond ((null match) t)
- ((cdr-safe (car match)) 'ellipsis)
- (t nil)))))
-
-(defun htmlize-add-before-after-strings (beg end text)
- ;; Find overlays specifying before-string and after-string in [beg,
- ;; pos). If any are found, splice them into TEXT and return the new
- ;; text.
- (let (additions)
- (dolist (overlay (overlays-in beg end))
- (let ((before (overlay-get overlay 'before-string))
- (after (overlay-get overlay 'after-string)))
- (when after
- (push (cons (- (overlay-end overlay) beg)
- after)
- additions))
- (when before
- (push (cons (- (overlay-start overlay) beg)
- before)
- additions))))
- (if additions
- (let ((textlist nil)
- (strpos 0))
- (dolist (add (stable-sort additions #'< :key #'car))
- (let ((addpos (car add))
- (addtext (cdr add)))
- (push (substring text strpos addpos) textlist)
- (push addtext textlist)
- (setq strpos addpos)))
- (push (substring text strpos) textlist)
- (apply #'concat (nreverse textlist)))
- text)))
-
-(defun htmlize-copy-prop (prop beg end string)
- ;; Copy the specified property from the specified region of the
- ;; buffer to the target string. We cannot rely on Emacs to copy the
- ;; property because we want to handle properties coming from both
- ;; text properties and overlays.
- (let ((pos beg))
- (while (< pos end)
- (let ((value (get-char-property pos prop))
- (next-change (htmlize-next-change pos prop end)))
- (when value
- (put-text-property (- pos beg) (- next-change beg)
- prop value string))
- (setq pos next-change)))))
-
-(defun htmlize-get-text-with-display (beg end)
- ;; Like buffer-substring-no-properties, except it copies the
- ;; `display' property from the buffer, if found.
- (let ((text (buffer-substring-no-properties beg end)))
- (htmlize-copy-prop 'display beg end text)
- (htmlize-copy-prop 'htmlize-link beg end text)
- (unless htmlize-running-xemacs
- (setq text (htmlize-add-before-after-strings beg end text)))
- text))
-
-(defun htmlize-buffer-substring-no-invisible (beg end)
- ;; Like buffer-substring-no-properties, but don't copy invisible
- ;; parts of the region. Where buffer-substring-no-properties
- ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted.
- (let ((pos beg)
- visible-list invisible show last-show next-change)
- ;; Iterate over the changes in the `invisible' property and filter
- ;; out the portions where it's non-nil, i.e. where the text is
- ;; invisible.
- (while (< pos end)
- (setq invisible (get-char-property pos 'invisible)
- next-change (htmlize-next-change pos 'invisible end)
- show (htmlize-decode-invisibility-spec invisible))
- (cond ((eq show t)
- (push (htmlize-get-text-with-display pos next-change)
- visible-list))
- ((and (eq show 'ellipsis)
- (not (eq last-show 'ellipsis))
- ;; Conflate successive ellipses.
- (push htmlize-ellipsis visible-list))))
- (setq pos next-change last-show show))
- (htmlize-concat (nreverse visible-list))))
-
-(defun htmlize-trim-ellipsis (text)
- ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it
- ;; starts with it. It checks for the special property of the
- ;; ellipsis so it doesn't work on ordinary text that begins with
- ;; "...".
- (if (get-text-property 0 'htmlize-ellipsis text)
- (substring text (length htmlize-ellipsis))
- text))
-
-(defconst htmlize-tab-spaces
- ;; A table of strings with spaces. (aref htmlize-tab-spaces 5) is
- ;; like (make-string 5 ?\ ), except it doesn't cons.
- (let ((v (make-vector 32 nil)))
- (dotimes (i (length v))
- (setf (aref v i) (make-string i ?\ )))
- v))
-
-(defun htmlize-untabify (text start-column)
- "Untabify TEXT, assuming it starts at START-COLUMN."
- (let ((column start-column)
- (last-match 0)
- (chunk-start 0)
- chunks match-pos tab-size)
- (while (string-match "[\t\n]" text last-match)
- (setq match-pos (match-beginning 0))
- (cond ((eq (aref text match-pos) ?\t)
- ;; Encountered a tab: create a chunk of text followed by
- ;; the expanded tab.
- (push (substring text chunk-start match-pos) chunks)
- ;; Increase COLUMN by the length of the text we've
- ;; skipped since last tab or newline. (Encountering
- ;; newline resets it.)
- (incf column (- match-pos last-match))
- ;; Calculate tab size based on tab-width and COLUMN.
- (setq tab-size (- tab-width (% column tab-width)))
- ;; Expand the tab, carefully recreating the `display'
- ;; property if one was on the TAB.
- (let ((display (get-text-property match-pos 'display text))
- (expanded-tab (aref htmlize-tab-spaces tab-size)))
- (when display
- (put-text-property 0 tab-size 'display display expanded-tab))
- (push expanded-tab chunks))
- (incf column tab-size)
- (setq chunk-start (1+ match-pos)))
- (t
- ;; Reset COLUMN at beginning of line.
- (setq column 0)))
- (setq last-match (1+ match-pos)))
- ;; If no chunks have been allocated, it means there have been no
- ;; tabs to expand. Return TEXT unmodified.
- (if (null chunks)
- text
- (when (< chunk-start (length text))
- ;; Push the remaining chunk.
- (push (substring text chunk-start) chunks))
- ;; Generate the output from the available chunks.
- (htmlize-concat (nreverse chunks)))))
-
-(defun htmlize-extract-text (beg end trailing-ellipsis)
- ;; Extract buffer text, sans the invisible parts. Then
- ;; untabify it and escape the HTML metacharacters.
- (let ((text (htmlize-buffer-substring-no-invisible beg end)))
- (when trailing-ellipsis
- (setq text (htmlize-trim-ellipsis text)))
- ;; If TEXT ends up empty, don't change trailing-ellipsis.
- (when (> (length text) 0)
- (setq trailing-ellipsis
- (get-text-property (1- (length text))
- 'htmlize-ellipsis text)))
- (setq text (htmlize-untabify text (current-column)))
- (setq text (htmlize-string-to-html text))
- (values text trailing-ellipsis)))
-
-(defun htmlize-despam-address (string)
- "Replace every occurrence of '@' in STRING with %40.
-This is used to protect mailto links without modifying their meaning."
- ;; Suggested by Ville Skytta.
- (while (string-match "@" string)
- (setq string (replace-match "%40" nil t string)))
- string)
-
-(defun htmlize-make-tmp-overlay (beg end props)
- (let ((overlay (htmlize-make-overlay beg end)))
- (htmlize-overlay-put overlay 'htmlize-tmp-overlay t)
- (while props
- (htmlize-overlay-put overlay (pop props) (pop props)))
- overlay))
-
-(defun htmlize-delete-tmp-overlays ()
- (dolist (overlay (htmlize-overlays-in (point-min) (point-max)))
- (when (htmlize-overlay-get overlay 'htmlize-tmp-overlay)
- (htmlize-delete-overlay overlay))))
-
-(defun htmlize-make-link-overlay (beg end uri)
- (htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri))))
-
-(defun htmlize-create-auto-links ()
- "Add `htmlize-link' property to all mailto links in the buffer."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward
- "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
- nil t)
- (let* ((address (match-string 3))
- (beg (match-beginning 0)) (end (match-end 0))
- (uri (concat "mailto:" (htmlize-despam-address address))))
- (htmlize-make-link-overlay beg end uri)))
- (goto-char (point-min))
- (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>"
- nil t)
- (htmlize-make-link-overlay
- (match-beginning 0) (match-end 0) (match-string 3)))))
-
-;; Tests for htmlize-create-auto-links:
-
-;; <mailto:hniksicNOSPAMxemacs.org>
-;; <http://fly.srk.fer.hr>
-;; <URL:http://www.xemacs.org>
-;; <http://www.mail-archive.com/bbdb-infoNOSPAMxemacs.org/>
-;; <hniksicNOSPAMxemacs.org>
-;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.comNOSPAMxml.apache.org>
-
-(defun htmlize-shadow-form-feeds ()
- (let ((s "\n<hr />"))
- (put-text-property 0 (length s) 'htmlize-literal t s)
- (let ((disp `(display ,s)))
- (while (re-search-forward "\n\^L" nil t)
- (htmlize-make-tmp-overlay (match-beginning 0) (match-end 0) disp)))))
-
-(defun htmlize-defang-local-variables ()
- ;; Juri Linkov reports that an HTML-ized "Local variables" can lead
- ;; visiting the HTML to fail with "Local variables list is not
- ;; properly terminated". He suggested changing the phrase to
- ;; syntactically equivalent HTML that Emacs doesn't recognize.
- (goto-char (point-min))
- (while (search-forward "Local Variables:" nil t)
- (replace-match "Local Variables:" nil t)))
-
-\f
-;;; Color handling.
-
-(defvar htmlize-x-library-search-path
- `(,data-directory
- "/etc/X11/rgb.txt"
- "/usr/share/X11/rgb.txt"
- ;; the remainder of this list really belongs in a museum
- "/usr/X11R6/lib/X11/"
- "/usr/X11R5/lib/X11/"
- "/usr/lib/X11R6/X11/"
- "/usr/lib/X11R5/X11/"
- "/usr/local/X11R6/lib/X11/"
- "/usr/local/X11R5/lib/X11/"
- "/usr/local/lib/X11R6/X11/"
- "/usr/local/lib/X11R5/X11/"
- "/usr/X11/lib/X11/"
- "/usr/lib/X11/"
- "/usr/local/lib/X11/"
- "/usr/X386/lib/X11/"
- "/usr/x386/lib/X11/"
- "/usr/XFree86/lib/X11/"
- "/usr/unsupported/lib/X11/"
- "/usr/athena/lib/X11/"
- "/usr/local/x11r5/lib/X11/"
- "/usr/lpp/Xamples/lib/X11/"
- "/usr/openwin/lib/X11/"
- "/usr/openwin/share/lib/X11/"))
-
-(defun htmlize-get-color-rgb-hash (&optional rgb-file)
- "Return a hash table mapping X color names to RGB values.
-The keys in the hash table are X11 color names, and the values are the
-#rrggbb RGB specifications, extracted from `rgb.txt'.
-
-If RGB-FILE is nil, the function will try hard to find a suitable file
-in the system directories.
-
-If no rgb.txt file is found, return nil."
- (let ((rgb-file (or rgb-file (locate-file
- "rgb.txt"
- htmlize-x-library-search-path)))
- (hash nil))
- (when rgb-file
- (with-temp-buffer
- (insert-file-contents rgb-file)
- (setq hash (make-hash-table :test 'equal))
- (while (not (eobp))
- (cond ((looking-at "^\\s-*\\([!#]\\|$\\)")
- ;; Skip comments and empty lines.
- )
- ((looking-at
- "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
- (setf (gethash (downcase (match-string 4)) hash)
- (format "#%02x%02x%02x"
- (string-to-number (match-string 1))
- (string-to-number (match-string 2))
- (string-to-number (match-string 3)))))
- (t
- (error
- "Unrecognized line in %s: %s"
- rgb-file
- (buffer-substring (point) (progn (end-of-line) (point))))))
- (forward-line 1))))
- hash))
-
-;; Compile the RGB map when loaded. On systems where rgb.txt is
-;; missing, the value of the variable will be nil, and rgb.txt will
-;; not be used.
-(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))
-\f
-;;; Face handling.
-
-(defun htmlize-face-specifies-property (face prop)
- ;; Return t if face specifies PROP, as opposed to it being inherited
- ;; from the default face. The problem with e.g.
- ;; `face-foreground-instance' is that it returns an instance for
- ;; EVERY face because every face inherits from the default face.
- ;; However, we'd like htmlize-face-{fore,back}ground to return nil
- ;; when called with a face that doesn't specify its own foreground
- ;; or background.
- (or (eq face 'default)
- (assq 'global (specifier-spec-list (face-property face prop)))))
-
-(defun htmlize-face-color-internal (face fg)
- ;; Used only under GNU Emacs. Return the color of FACE, but don't
- ;; return "unspecified-fg" or "unspecified-bg". If the face is
- ;; `default' and the color is unspecified, look up the color in
- ;; frame parameters.
- (let* ((function (if fg #'face-foreground #'face-background))
- (color (funcall function face nil t)))
- (when (and (eq face 'default) (null color))
- (setq color (cdr (assq (if fg 'foreground-color 'background-color)
- (frame-parameters)))))
- (when (or (eq color 'unspecified)
- (equal color "unspecified-fg")
- (equal color "unspecified-bg"))
- (setq color nil))
- (when (and (eq face 'default)
- (null color))
- ;; Assuming black on white doesn't seem right, but I can't think
- ;; of anything better to do.
- (setq color (if fg "black" "white")))
- color))
-
-(defun htmlize-face-foreground (face)
- ;; Return the name of the foreground color of FACE. If FACE does
- ;; not specify a foreground color, return nil.
- (cond (htmlize-running-xemacs
- ;; XEmacs.
- (and (htmlize-face-specifies-property face 'foreground)
- (color-instance-name (face-foreground-instance face))))
- (t
- ;; GNU Emacs.
- (htmlize-face-color-internal face t))))
-
-(defun htmlize-face-background (face)
- ;; Return the name of the background color of FACE. If FACE does
- ;; not specify a background color, return nil.
- (cond (htmlize-running-xemacs
- ;; XEmacs.
- (and (htmlize-face-specifies-property face 'background)
- (color-instance-name (face-background-instance face))))
- (t
- ;; GNU Emacs.
- (htmlize-face-color-internal face nil))))
-
-;; Convert COLOR to the #RRGGBB string. If COLOR is already in that
-;; format, it's left unchanged.
-
-(defun htmlize-color-to-rgb (color)
- (let ((rgb-string nil))
- (cond ((null color)
- ;; Ignore nil COLOR because it means that the face is not
- ;; specifying any color. Hence (htmlize-color-to-rgb nil)
- ;; returns nil.
- )
- ((string-match "\\`#" color)
- ;; The color is already in #rrggbb format.
- (setq rgb-string color))
- ((and htmlize-use-rgb-txt
- htmlize-color-rgb-hash)
- ;; Use of rgb.txt is requested, and it's available on the
- ;; system. Use it.
- (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash)))
- (t
- ;; We're getting the RGB components from Emacs.
- (let ((rgb
- (if (fboundp 'color-instance-rgb-components)
- (mapcar (lambda (arg)
- (/ arg 256))
- (color-instance-rgb-components
- (make-color-instance color)))
- (mapcar (lambda (arg)
- (/ arg 256))
- (color-values color)))))
- (when rgb
- (setq rgb-string (apply #'format "#%02x%02x%02x" rgb))))))
- ;; If RGB-STRING is still nil, it means the color cannot be found,
- ;; for whatever reason. In that case just punt and return COLOR.
- ;; Most browsers support a decent set of color names anyway.
- (or rgb-string color)))
-
-;; We store the face properties we care about into an
-;; `htmlize-fstruct' type. That way we only have to analyze face
-;; properties, which can be time consuming, once per each face. The
-;; mapping between Emacs faces and htmlize-fstructs is established by
-;; htmlize-make-face-map. The name "fstruct" refers to variables of
-;; type `htmlize-fstruct', while the term "face" is reserved for Emacs
-;; faces.
-
-(defstruct htmlize-fstruct
- foreground ; foreground color, #rrggbb
- background ; background color, #rrggbb
- size ; size
- boldp ; whether face is bold
- italicp ; whether face is italic
- underlinep ; whether face is underlined
- overlinep ; whether face is overlined
- strikep ; whether face is struck through
- css-name ; CSS name of face
- )
-
-(defun htmlize-face-set-from-keyword-attr (fstruct attr value)
- ;; For ATTR and VALUE, set the equivalent value in FSTRUCT.
- (case attr
- (:foreground
- (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value)))
- (:background
- (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value)))
- (:height
- (setf (htmlize-fstruct-size fstruct) value))
- (:weight
- (when (string-match (symbol-name value) "bold")
- (setf (htmlize-fstruct-boldp fstruct) t)))
- (:slant
- (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic)
- (eq value 'oblique))))
- (:bold
- (setf (htmlize-fstruct-boldp fstruct) value))
- (:italic
- (setf (htmlize-fstruct-italicp fstruct) value))
- (:underline
- (setf (htmlize-fstruct-underlinep fstruct) value))
- (:overline
- (setf (htmlize-fstruct-overlinep fstruct) value))
- (:strike-through
- (setf (htmlize-fstruct-strikep fstruct) value))))
-
-(defun htmlize-face-size (face)
- ;; The size (height) of FACE, taking inheritance into account.
- ;; Only works in Emacs 21 and later.
- (let* ((face-list (list face))
- (head face-list)
- (tail face-list))
- (while head
- (let ((inherit (face-attribute (car head) :inherit)))
- (cond ((listp inherit)
- (setcdr tail (copy-list inherit))
- (setq tail (last tail)))
- ((eq inherit 'unspecified))
- (t
- (setcdr tail (list inherit))
- (setq tail (cdr tail)))))
- (pop head))
- (let ((size-list
- (loop
- for f in face-list
- for h = (face-attribute f :height)
- collect (if (eq h 'unspecified) nil h))))
- (reduce 'htmlize-merge-size (cons nil size-list)))))
-
-(defun htmlize-face-css-name (face)
- ;; Generate the css-name property for the given face. Emacs places
- ;; no restrictions on the names of symbols that represent faces --
- ;; any characters may be in the name, even control chars. We try
- ;; hard to beat the face name into shape, both esthetically and
- ;; according to CSS1 specs.
- (let ((name (downcase (symbol-name face))))
- (when (string-match "\\`font-lock-" name)
- ;; font-lock-FOO-face -> FOO.
- (setq name (replace-match "" t t name)))
- (when (string-match "-face\\'" name)
- ;; Drop the redundant "-face" suffix.
- (setq name (replace-match "" t t name)))
- (while (string-match "[^-a-zA-Z0-9]" name)
- ;; Drop the non-alphanumerics.
- (setq name (replace-match "X" t t name)))
- (when (string-match "\\`[-0-9]" name)
- ;; CSS identifiers may not start with a digit.
- (setq name (concat "X" name)))
- ;; After these transformations, the face could come out empty.
- (when (equal name "")
- (setq name "face"))
- ;; Apply the prefix.
- (concat htmlize-css-name-prefix name)))
-
-(defun htmlize-face-to-fstruct (face)
- "Convert Emacs face FACE to fstruct."
- (let ((fstruct (make-htmlize-fstruct
- :foreground (htmlize-color-to-rgb
- (htmlize-face-foreground face))
- :background (htmlize-color-to-rgb
- (htmlize-face-background face)))))
- (if htmlize-running-xemacs
- ;; XEmacs doesn't provide a way to detect whether a face is
- ;; bold or italic, so we need to examine the font instance.
- (let* ((font-instance (face-font-instance face))
- (props (font-instance-properties font-instance)))
- (when (equalp (cdr (assq 'WEIGHT_NAME props)) "bold")
- (setf (htmlize-fstruct-boldp fstruct) t))
- (when (or (equalp (cdr (assq 'SLANT props)) "i")
- (equalp (cdr (assq 'SLANT props)) "o"))
- (setf (htmlize-fstruct-italicp fstruct) t))
- (setf (htmlize-fstruct-strikep fstruct)
- (face-strikethru-p face))
- (setf (htmlize-fstruct-underlinep fstruct)
- (face-underline-p face)))
- ;; GNU Emacs
- (dolist (attr '(:weight :slant :underline :overline :strike-through))
- (let ((value (face-attribute face attr nil t)))
- (when (and value (not (eq value 'unspecified)))
- (htmlize-face-set-from-keyword-attr fstruct attr value))))
- (let ((size (htmlize-face-size face)))
- (unless (eql size 1.0) ; ignore non-spec
- (setf (htmlize-fstruct-size fstruct) size))))
- (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face))
- fstruct))
-
-(defmacro htmlize-copy-attr-if-set (attr-list dest source)
- ;; Generate code with the following pattern:
- ;; (progn
- ;; (when (htmlize-fstruct-ATTR source)
- ;; (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
- ;; ...)
- ;; for the given list of boolean attributes.
- (cons 'progn
- (loop for attr in attr-list
- for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
- collect `(when (,attr-sym ,source)
- (setf (,attr-sym ,dest) (,attr-sym ,source))))))
-
-(defun htmlize-merge-size (merged next)
- ;; Calculate the size of the merge of MERGED and NEXT.
- (cond ((null merged) next)
- ((integerp next) next)
- ((null next) merged)
- ((floatp merged) (* merged next))
- ((integerp merged) (round (* merged next)))))
-
-(defun htmlize-merge-two-faces (merged next)
- (htmlize-copy-attr-if-set
- (foreground background boldp italicp underlinep overlinep strikep)
- merged next)
- (setf (htmlize-fstruct-size merged)
- (htmlize-merge-size (htmlize-fstruct-size merged)
- (htmlize-fstruct-size next)))
- merged)
-
-(defun htmlize-merge-faces (fstruct-list)
- (cond ((null fstruct-list)
- ;; Nothing to do, return a dummy face.
- (make-htmlize-fstruct))
- ((null (cdr fstruct-list))
- ;; Optimize for the common case of a single face, simply
- ;; return it.
- (car fstruct-list))
- (t
- (reduce #'htmlize-merge-two-faces
- (cons (make-htmlize-fstruct) fstruct-list)))))
-
-;; GNU Emacs 20+ supports attribute lists in `face' properties. For
-;; example, you can use `(:foreground "red" :weight bold)' as an
-;; overlay's "face", or you can even use a list of such lists, etc.
-;; We call those "attrlists".
-;;
-;; htmlize supports attrlist by converting them to fstructs, the same
-;; as with regular faces.
-
-(defun htmlize-attrlist-to-fstruct (attrlist)
- ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
- (let ((fstruct (make-htmlize-fstruct)))
- (cond ((eq (car attrlist) 'foreground-color)
- ;; ATTRLIST is (foreground-color . COLOR)
- (setf (htmlize-fstruct-foreground fstruct)
- (htmlize-color-to-rgb (cdr attrlist))))
- ((eq (car attrlist) 'background-color)
- ;; ATTRLIST is (background-color . COLOR)
- (setf (htmlize-fstruct-background fstruct)
- (htmlize-color-to-rgb (cdr attrlist))))
- (t
- ;; ATTRLIST is a plist.
- (while attrlist
- (let ((attr (pop attrlist))
- (value (pop attrlist)))
- (when (and value (not (eq value 'unspecified)))
- (htmlize-face-set-from-keyword-attr fstruct attr value))))))
- (setf (htmlize-fstruct-css-name fstruct) "ATTRLIST")
- fstruct))
-
-(defun htmlize-decode-face-prop (prop)
- "Turn face property PROP into a list of face-like objects."
- ;; PROP can be a symbol naming a face, a string naming such a
- ;; symbol, a cons (foreground-color . COLOR) or (background-color
- ;; COLOR), a property list (:attr1 val1 :attr2 val2 ...), or a list
- ;; of any of those.
- ;;
- ;; (htmlize-decode-face-prop 'face) -> (face)
- ;; (htmlize-decode-face-prop '(face1 face2)) -> (face1 face2)
- ;; (htmlize-decode-face-prop '(:attr "val")) -> ((:attr "val"))
- ;; (htmlize-decode-face-prop '((:attr "val") face (foreground-color "red")))
- ;; -> ((:attr "val") face (foreground-color "red"))
- ;;
- ;; Unrecognized atoms or non-face symbols/strings are silently
- ;; stripped away.
- (cond ((null prop)
- nil)
- ((symbolp prop)
- (and (facep prop)
- (list prop)))
- ((stringp prop)
- (and (facep (intern-soft prop))
- (list prop)))
- ((atom prop)
- nil)
- ((and (symbolp (car prop))
- (eq ?: (aref (symbol-name (car prop)) 0)))
- (list prop))
- ((or (eq (car prop) 'foreground-color)
- (eq (car prop) 'background-color))
- (list prop))
- (t
- (apply #'nconc (mapcar #'htmlize-decode-face-prop prop)))))
-
-(defun htmlize-make-face-map (faces)
- ;; Return a hash table mapping Emacs faces to htmlize's fstructs.
- ;; The keys are either face symbols or attrlists, so the test
- ;; function must be `equal'.
- (let ((face-map (make-hash-table :test 'equal))
- css-names)
- (dolist (face faces)
- (unless (gethash face face-map)
- ;; Haven't seen FACE yet; convert it to an fstruct and cache
- ;; it.
- (let ((fstruct (if (symbolp face)
- (htmlize-face-to-fstruct face)
- (htmlize-attrlist-to-fstruct face))))
- (setf (gethash face face-map) fstruct)
- (let* ((css-name (htmlize-fstruct-css-name fstruct))
- (new-name css-name)
- (i 0))
- ;; Uniquify the face's css-name by using NAME-1, NAME-2,
- ;; etc.
- (while (member new-name css-names)
- (setq new-name (format "%s-%s" css-name (incf i))))
- (unless (equal new-name css-name)
- (setf (htmlize-fstruct-css-name fstruct) new-name))
- (push new-name css-names)))))
- face-map))
-
-(defun htmlize-unstringify-face (face)
- "If FACE is a string, return it interned, otherwise return it unchanged."
- (if (stringp face)
- (intern face)
- face))
-
-(defun htmlize-faces-in-buffer ()
- "Return a list of faces used in the current buffer.
-Under XEmacs, this returns the set of faces specified by the extents
-with the `face' property. (This covers text properties as well.) Under
-GNU Emacs, it returns the set of faces specified by the `face' text
-property and by buffer overlays that specify `face'."
- (let (faces)
- ;; Testing for (fboundp 'map-extents) doesn't work because W3
- ;; defines `map-extents' under FSF.
- (if htmlize-running-xemacs
- (let (face-prop)
- (map-extents (lambda (extent ignored)
- (setq face-prop (extent-face extent)
- ;; FACE-PROP can be a face or a list of
- ;; faces.
- faces (if (listp face-prop)
- (union face-prop faces)
- (adjoin face-prop faces)))
- nil)
- nil
- ;; Specify endpoints explicitly to respect
- ;; narrowing.
- (point-min) (point-max) nil nil 'face))
- ;; FSF Emacs code.
- ;; Faces used by text properties.
- (let ((pos (point-min)) face-prop next)
- (while (< pos (point-max))
- (setq face-prop (get-text-property pos 'face)
- next (or (next-single-property-change pos 'face) (point-max)))
- (setq faces (nunion (htmlize-decode-face-prop face-prop)
- faces :test 'equal))
- (setq pos next)))
- ;; Faces used by overlays.
- (dolist (overlay (overlays-in (point-min) (point-max)))
- (let ((face-prop (overlay-get overlay 'face)))
- (setq faces (nunion (htmlize-decode-face-prop face-prop)
- faces :test 'equal)))))
- faces))
-
-;; htmlize-faces-at-point returns the faces in use at point. The
-;; faces are sorted by increasing priority, i.e. the last face takes
-;; precedence.
-;;
-;; Under XEmacs, this returns all the faces in all the extents at
-;; point. Under GNU Emacs, this returns all the faces in the `face'
-;; property and all the faces in the overlays at point.
-
-(cond (htmlize-running-xemacs
- (defun htmlize-faces-at-point ()
- (let (extent extent-list face-list face-prop)
- (while (setq extent (extent-at (point) nil 'face extent))
- (push extent extent-list))
- ;; extent-list is in reverse display order, meaning that
- ;; smallest ones come last. That is the order we want,
- ;; except it can be overridden by the `priority' property.
- (setq extent-list (stable-sort extent-list #'<
- :key #'extent-priority))
- (dolist (extent extent-list)
- (setq face-prop (extent-face extent))
- ;; extent's face-list is in reverse order from what we
- ;; want, but the `nreverse' below will take care of it.
- (setq face-list (if (listp face-prop)
- (append face-prop face-list)
- (cons face-prop face-list))))
- (nreverse face-list))))
- (t
- (defun htmlize-faces-at-point ()
- (let (all-faces)
- ;; Faces from text properties.
- (let ((face-prop (get-text-property (point) 'face)))
- ;; we need to reverse the `face' prop because we want
- ;; more specific faces to come later
- (setq all-faces (nreverse (htmlize-decode-face-prop face-prop))))
- ;; Faces from overlays.
- (let ((overlays
- ;; Collect overlays at point that specify `face'.
- (delete-if-not (lambda (o)
- (overlay-get o 'face))
- (overlays-at (point))))
- list face-prop)
- ;; Sort the overlays so the smaller (more specific) ones
- ;; come later. The number of overlays at each one
- ;; position should be very small, so the sort shouldn't
- ;; slow things down.
- (setq overlays (sort* overlays
- ;; Sort by ascending...
- #'<
- ;; ...overlay size.
- :key (lambda (o)
- (- (overlay-end o)
- (overlay-start o)))))
- ;; Overlay priorities, if present, override the above
- ;; established order. Larger overlay priority takes
- ;; precedence and therefore comes later in the list.
- (setq overlays (stable-sort
- overlays
- ;; Reorder (stably) by acending...
- #'<
- ;; ...overlay priority.
- :key (lambda (o)
- (or (overlay-get o 'priority) 0))))
- (dolist (overlay overlays)
- (setq face-prop (overlay-get overlay 'face)
- list (nconc (htmlize-decode-face-prop face-prop) list)))
- ;; Under "Merging Faces" the manual explicitly states
- ;; that faces specified by overlays take precedence over
- ;; faces specified by text properties.
- (setq all-faces (nconc all-faces list)))
- all-faces))))
-\f
-;; htmlize supports generating HTML in several flavors, some of which
-;; use CSS, and others the <font> element. We take an OO approach and
-;; define "methods" that indirect to the functions that depend on
-;; `htmlize-output-type'. The currently used methods are `doctype',
-;; `insert-head', `body-tag', and `text-markup'. Not all output types
-;; define all methods.
-;;
-;; Methods are called either with (htmlize-method METHOD ARGS...)
-;; special form, or by accessing the function with
-;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
-;; The latter form is useful in tight loops because `htmlize-method'
-;; conses.
-
-(defmacro htmlize-method (method &rest args)
- ;; Expand to (htmlize-TYPE-METHOD ...ARGS...). TYPE is the value of
- ;; `htmlize-output-type' at run time.
- `(funcall (htmlize-method-function ',method) ,@args))
-
-(defun htmlize-method-function (method)
- ;; Return METHOD's function definition for the current output type.
- ;; The returned object can be safely funcalled.
- (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
- (indirect-function (if (fboundp sym)
- sym
- (let ((default (intern (concat "htmlize-default-"
- (symbol-name method)))))
- (if (fboundp default)
- default
- 'ignore))))))
-
-(defvar htmlize-memoization-table (make-hash-table :test 'equal))
-
-(defmacro htmlize-memoize (key generator)
- "Return the value of GENERATOR, memoized as KEY.
-That means that GENERATOR will be evaluated and returned the first time
-it's called with the same value of KEY. All other times, the cached
-\(memoized) value will be returned."
- (let ((value (gensym)))
- `(let ((,value (gethash ,key htmlize-memoization-table)))
- (unless ,value
- (setq ,value ,generator)
- (setf (gethash ,key htmlize-memoization-table) ,value))
- ,value)))
-\f
-;;; Default methods.
-
-(defun htmlize-default-doctype ()
- nil ; no doc-string
- ;; Note that the `font' output is technically invalid under this DTD
- ;; because the DTD doesn't allow embedding <font> in <pre>.
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">"
- )
-
-(defun htmlize-default-body-tag (face-map)
- nil ; no doc-string
- face-map ; shut up the byte-compiler
- "<body>")
-\f
-;;; CSS based output support.
-
-;; Internal function; not a method.
-(defun htmlize-css-specs (fstruct)
- (let (result)
- (when (htmlize-fstruct-foreground fstruct)
- (push (format "color: %s;" (htmlize-fstruct-foreground fstruct))
- result))
- (when (htmlize-fstruct-background fstruct)
- (push (format "background-color: %s;"
- (htmlize-fstruct-background fstruct))
- result))
- (let ((size (htmlize-fstruct-size fstruct)))
- (when (and size (not (eq htmlize-ignore-face-size t)))
- (cond ((floatp size)
- (push (format "font-size: %d%%;" (* 100 size)) result))
- ((not (eq htmlize-ignore-face-size 'absolute))
- (push (format "font-size: %spt;" (/ size 10.0)) result)))))
- (when (htmlize-fstruct-boldp fstruct)
- (push "font-weight: bold;" result))
- (when (htmlize-fstruct-italicp fstruct)
- (push "font-style: italic;" result))
- (when (htmlize-fstruct-underlinep fstruct)
- (push "text-decoration: underline;" result))
- (when (htmlize-fstruct-overlinep fstruct)
- (push "text-decoration: overline;" result))
- (when (htmlize-fstruct-strikep fstruct)
- (push "text-decoration: line-through;" result))
- (nreverse result)))
-
-(defun htmlize-css-insert-head (buffer-faces face-map)
- (insert " <style type=\"text/css\">\n <!--\n")
- (insert " body {\n "
- (mapconcat #'identity
- (htmlize-css-specs (gethash 'default face-map))
- "\n ")
- "\n }\n")
- (dolist (face (sort* (copy-list buffer-faces) #'string-lessp
- :key (lambda (f)
- (htmlize-fstruct-css-name (gethash f face-map)))))
- (let* ((fstruct (gethash face face-map))
- (cleaned-up-face-name
- (let ((s
- ;; Use `prin1-to-string' rather than `symbol-name'
- ;; to get the face name because the "face" can also
- ;; be an attrlist, which is not a symbol.
- (prin1-to-string face)))
- ;; If the name contains `--' or `*/', remove them.
- (while (string-match "--" s)
- (setq s (replace-match "-" t t s)))
- (while (string-match "\\*/" s)
- (setq s (replace-match "XX" t t s)))
- s))
- (specs (htmlize-css-specs fstruct)))
- (insert " ." (htmlize-fstruct-css-name fstruct))
- (if (null specs)
- (insert " {")
- (insert " {\n /* " cleaned-up-face-name " */\n "
- (mapconcat #'identity specs "\n ")))
- (insert "\n }\n")))
- (insert htmlize-hyperlink-style
- " -->\n </style>\n"))
-
-(defun htmlize-css-text-markup (fstruct-list buffer)
- ;; Open the markup needed to insert text colored with FACES into
- ;; BUFFER. Return the function that closes the markup.
-
- ;; In CSS mode, this is easy: just nest the text in one <span
- ;; class=...> tag for each face in FSTRUCT-LIST.
- (dolist (fstruct fstruct-list)
- (princ "<span class=\"" buffer)
- (princ (htmlize-fstruct-css-name fstruct) buffer)
- (princ "\">" buffer))
- (htmlize-lexlet ((fstruct-list fstruct-list) (buffer buffer))
- (lambda ()
- (dolist (fstruct fstruct-list)
- (ignore fstruct) ; shut up the byte-compiler
- (princ "</span>" buffer)))))
-\f
-;; `inline-css' output support.
-
-(defun htmlize-inline-css-body-tag (face-map)
- (format "<body style=\"%s\">"
- (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
- " ")))
-
-(defun htmlize-inline-css-text-markup (fstruct-list buffer)
- (let* ((merged (htmlize-merge-faces fstruct-list))
- (style (htmlize-memoize
- merged
- (let ((specs (htmlize-css-specs merged)))
- (and specs
- (mapconcat #'identity (htmlize-css-specs merged) " "))))))
- (when style
- (princ "<span style=\"" buffer)
- (princ style buffer)
- (princ "\">" buffer))
- (htmlize-lexlet ((style style) (buffer buffer))
- (lambda ()
- (when style
- (princ "</span>" buffer))))))
-\f
-;;; `font' tag based output support.
-
-(defun htmlize-font-body-tag (face-map)
- (let ((fstruct (gethash 'default face-map)))
- (format "<body text=\"%s\" bgcolor=\"%s\">"
- (htmlize-fstruct-foreground fstruct)
- (htmlize-fstruct-background fstruct))))
-
-(defun htmlize-font-text-markup (fstruct-list buffer)
- ;; In `font' mode, we use the traditional HTML means of altering
- ;; presentation: <font> tag for colors, <b> for bold, <u> for
- ;; underline, and <strike> for strike-through.
- (let* ((merged (htmlize-merge-faces fstruct-list))
- (markup (htmlize-memoize
- merged
- (cons (concat
- (and (htmlize-fstruct-foreground merged)
- (format "<font color=\"%s\">" (htmlize-fstruct-foreground merged)))
- (and (htmlize-fstruct-boldp merged) "<b>")
- (and (htmlize-fstruct-italicp merged) "<i>")
- (and (htmlize-fstruct-underlinep merged) "<u>")
- (and (htmlize-fstruct-strikep merged) "<strike>"))
- (concat
- (and (htmlize-fstruct-strikep merged) "</strike>")
- (and (htmlize-fstruct-underlinep merged) "</u>")
- (and (htmlize-fstruct-italicp merged) "</i>")
- (and (htmlize-fstruct-boldp merged) "</b>")
- (and (htmlize-fstruct-foreground merged) "</font>"))))))
- (princ (car markup) buffer)
- (htmlize-lexlet ((markup markup) (buffer buffer))
- (lambda ()
- (princ (cdr markup) buffer)))))
-\f
-(defun htmlize-buffer-1 ()
- ;; Internal function; don't call it from outside this file. Htmlize
- ;; current buffer, writing the resulting HTML to a new buffer, and
- ;; return it. Unlike htmlize-buffer, this doesn't change current
- ;; buffer or use switch-to-buffer.
- (save-excursion
- ;; Protect against the hook changing the current buffer.
- (save-excursion
- (run-hooks 'htmlize-before-hook))
- ;; Convince font-lock support modes to fontify the entire buffer
- ;; in advance.
- (htmlize-ensure-fontified)
- (clrhash htmlize-extended-character-cache)
- (clrhash htmlize-memoization-table)
- ;; It's important that the new buffer inherits default-directory
- ;; from the current buffer.
- (let ((htmlbuf (generate-new-buffer (if (buffer-file-name)
- (htmlize-make-file-name
- (file-name-nondirectory
- (buffer-file-name)))
- "*html*")))
- (completed nil))
- (unwind-protect
- (let* ((buffer-faces (htmlize-faces-in-buffer))
- (face-map (htmlize-make-face-map (adjoin 'default buffer-faces)))
- (places (gensym))
- (title (if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
- (buffer-name))))
- (when htmlize-generate-hyperlinks
- (htmlize-create-auto-links))
- (when htmlize-replace-form-feeds
- (htmlize-shadow-form-feeds))
-
- ;; Initialize HTMLBUF and insert the HTML prolog.
- (with-current-buffer htmlbuf
- (buffer-disable-undo)
- (insert (htmlize-method doctype) ?\n
- (format "<!-- Created by htmlize-%s in %s mode. -->\n"
- htmlize-version htmlize-output-type)
- "<html>\n ")
- (put places 'head-start (point-marker))
- (insert "<head>\n"
- " <title>" (htmlize-protect-string title) "</title>\n"
- (if htmlize-html-charset
- (format (concat " <meta http-equiv=\"Content-Type\" "
- "content=\"text/html; charset=%s\">\n")
- htmlize-html-charset)
- "")
- htmlize-head-tags)
- (htmlize-method insert-head buffer-faces face-map)
- (insert " </head>")
- (put places 'head-end (point-marker))
- (insert "\n ")
- (put places 'body-start (point-marker))
- (insert (htmlize-method body-tag face-map)
- "\n ")
- (put places 'content-start (point-marker))
- (insert "<pre>\n"))
- (let ((text-markup
- ;; Get the inserter method, so we can funcall it inside
- ;; the loop. Not calling `htmlize-method' in the loop
- ;; body yields a measurable speed increase.
- (htmlize-method-function 'text-markup))
- ;; Declare variables used in loop body outside the loop
- ;; because it's faster to establish `let' bindings only
- ;; once.
- next-change text face-list trailing-ellipsis
- fstruct-list last-fstruct-list
- (close-markup (lambda ())))
- ;; This loop traverses and reads the source buffer, appending
- ;; the resulting HTML to HTMLBUF. This method is fast
- ;; because: 1) it doesn't require examining the text
- ;; properties char by char (htmlize-next-face-change is used
- ;; to move between runs with the same face), and 2) it doesn't
- ;; require frequent buffer switches, which are slow because
- ;; they rebind all buffer-local vars.
- (goto-char (point-min))
- (while (not (eobp))
- (setq next-change (htmlize-next-face-change (point)))
- ;; Get faces in use between (point) and NEXT-CHANGE, and
- ;; convert them to fstructs.
- (setq face-list (htmlize-faces-at-point)
- fstruct-list (delq nil (mapcar (lambda (f)
- (gethash f face-map))
- face-list)))
- (multiple-value-setq (text trailing-ellipsis)
- (htmlize-extract-text (point) next-change trailing-ellipsis))
- ;; Don't bother writing anything if there's no text (this
- ;; happens in invisible regions).
- (when (> (length text) 0)
- ;; Open the new markup if necessary and insert the text.
- (when (not (equalp fstruct-list last-fstruct-list))
- (funcall close-markup)
- (setq last-fstruct-list fstruct-list
- close-markup (funcall text-markup fstruct-list htmlbuf)))
- (princ text htmlbuf))
- (goto-char next-change))
-
- ;; We've gone through the buffer; close the markup from
- ;; the last run, if any.
- (funcall close-markup))
-
- ;; Insert the epilog and post-process the buffer.
- (with-current-buffer htmlbuf
- (insert "</pre>")
- (put places 'content-end (point-marker))
- (insert "\n </body>")
- (put places 'body-end (point-marker))
- (insert "\n</html>\n")
- (htmlize-defang-local-variables)
- (goto-char (point-min))
- (when htmlize-html-major-mode
- ;; What sucks about this is that the minor modes, most notably
- ;; font-lock-mode, won't be initialized. Oh well.
- (funcall htmlize-html-major-mode))
- (set (make-local-variable 'htmlize-buffer-places)
- (symbol-plist places))
- (run-hooks 'htmlize-after-hook)
- (buffer-enable-undo))
- (setq completed t)
- htmlbuf)
-
- (when (not completed)
- (kill-buffer htmlbuf))
- (htmlize-delete-tmp-overlays)))))
-
-;; Utility functions.
-
-(defmacro htmlize-with-fontify-message (&rest body)
- ;; When forcing fontification of large buffers in
- ;; htmlize-ensure-fontified, inform the user that he is waiting for
- ;; font-lock, not for htmlize to finish.
- `(progn
- (if (> (buffer-size) 65536)
- (message "Forcing fontification of %s..."
- (buffer-name (current-buffer))))
- ,@body
- (if (> (buffer-size) 65536)
- (message "Forcing fontification of %s...done"
- (buffer-name (current-buffer))))))
-
-(defun htmlize-ensure-fontified ()
- ;; If font-lock is being used, ensure that the "support" modes
- ;; actually fontify the buffer. If font-lock is not in use, we
- ;; don't care because, except in htmlize-file, we don't force
- ;; font-lock on the user.
- (when (and (boundp 'font-lock-mode)
- font-lock-mode)
- ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21.
- (cond
- ((and (boundp 'jit-lock-mode)
- (symbol-value 'jit-lock-mode))
- (htmlize-with-fontify-message
- (jit-lock-fontify-now (point-min) (point-max))))
- ((and (boundp 'lazy-lock-mode)
- (symbol-value 'lazy-lock-mode))
- (htmlize-with-fontify-message
- (lazy-lock-fontify-region (point-min) (point-max))))
- ((and (boundp 'lazy-shot-mode)
- (symbol-value 'lazy-shot-mode))
- (htmlize-with-fontify-message
- ;; lazy-shot is amazing in that it must *refontify* the region,
- ;; even if the whole buffer has already been fontified. <sigh>
- (lazy-shot-fontify-region (point-min) (point-max))))
- ;; There's also fast-lock, but we don't need to handle specially,
- ;; I think. fast-lock doesn't really defer fontification, it
- ;; just saves it to an external cache so it's not done twice.
- )))
-
-\f
-;;;###autoload
-(defun htmlize-buffer (&optional buffer)
- "Convert BUFFER to HTML, preserving colors and decorations.
-
-The generated HTML is available in a new buffer, which is returned.
-When invoked interactively, the new buffer is selected in the current
-window. The title of the generated document will be set to the buffer's
-file name or, if that's not available, to the buffer's name.
-
-Note that htmlize doesn't fontify your buffers, it only uses the
-decorations that are already present. If you don't set up font-lock or
-something else to fontify your buffers, the resulting HTML will be
-plain. Likewise, if you don't like the choice of colors, fix the mode
-that created them, or simply alter the faces it uses."
- (interactive)
- (let ((htmlbuf (with-current-buffer (or buffer (current-buffer))
- (htmlize-buffer-1))))
- (when (interactive-p)
- (switch-to-buffer htmlbuf))
- htmlbuf))
-
-;;;###autoload
-(defun htmlize-region (beg end)
- "Convert the region to HTML, preserving colors and decorations.
-See `htmlize-buffer' for details."
- (interactive "r")
- ;; Don't let zmacs region highlighting end up in HTML.
- (when (fboundp 'zmacs-deactivate-region)
- (zmacs-deactivate-region))
- (let ((htmlbuf (save-restriction
- (narrow-to-region beg end)
- (htmlize-buffer-1))))
- (when (interactive-p)
- (switch-to-buffer htmlbuf))
- htmlbuf))
-
-(defun htmlize-region-for-paste (beg end)
- "Htmlize the region and return just the HTML as a string.
-This forces the `inline-css' style and only returns the HTML body,
-but without the BODY tag. This should make it useful for inserting
-the text to another HTML buffer."
- (let* ((htmlize-output-type 'inline-css)
- (htmlbuf (htmlize-region beg end)))
- (unwind-protect
- (with-current-buffer htmlbuf
- (buffer-substring (plist-get htmlize-buffer-places 'content-start)
- (plist-get htmlize-buffer-places 'content-end)))
- (kill-buffer htmlbuf))))
-
-(defun htmlize-make-file-name (file)
- "Make an HTML file name from FILE.
-
-In its default implementation, this simply appends `.html' to FILE.
-This function is called by htmlize to create the buffer file name, and
-by `htmlize-file' to create the target file name.
-
-More elaborate transformations are conceivable, such as changing FILE's
-extension to `.html' (\"file.c\" -> \"file.html\"). If you want them,
-overload this function to do it and htmlize will comply."
- (concat file ".html"))
-
-;; Older implementation of htmlize-make-file-name that changes FILE's
-;; extension to ".html".
-;(defun htmlize-make-file-name (file)
-; (let ((extension (file-name-extension file))
-; (sans-extension (file-name-sans-extension file)))
-; (if (or (equal extension "html")
-; (equal extension "htm")
-; (equal sans-extension ""))
-; (concat file ".html")
-; (concat sans-extension ".html"))))
-
-;;;###autoload
-(defun htmlize-file (file &optional target)
- "Load FILE, fontify it, convert it to HTML, and save the result.
-
-Contents of FILE are inserted into a temporary buffer, whose major mode
-is set with `normal-mode' as appropriate for the file type. The buffer
-is subsequently fontified with `font-lock' and converted to HTML. Note
-that, unlike `htmlize-buffer', this function explicitly turns on
-font-lock. If a form of highlighting other than font-lock is desired,
-please use `htmlize-buffer' directly on buffers so highlighted.
-
-Buffers currently visiting FILE are unaffected by this function. The
-function does not change current buffer or move the point.
-
-If TARGET is specified and names a directory, the resulting file will be
-saved there instead of to FILE's directory. If TARGET is specified and
-does not name a directory, it will be used as output file name."
- (interactive (list (read-file-name
- "HTML-ize file: "
- nil nil nil (and (buffer-file-name)
- (file-name-nondirectory
- (buffer-file-name))))))
- (let ((output-file (if (and target (not (file-directory-p target)))
- target
- (expand-file-name
- (htmlize-make-file-name (file-name-nondirectory file))
- (or target (file-name-directory file)))))
- ;; Try to prevent `find-file-noselect' from triggering
- ;; font-lock because we'll fontify explicitly below.
- (font-lock-mode nil)
- (font-lock-auto-fontify nil)
- (global-font-lock-mode nil)
- ;; Ignore the size limit for the purposes of htmlization.
- (font-lock-maximum-size nil)
- ;; Disable font-lock support modes. This will only work in
- ;; more recent Emacs versions, so htmlize-buffer-1 still needs
- ;; to call htmlize-ensure-fontified.
- (font-lock-support-mode nil))
- (with-temp-buffer
- ;; Insert FILE into the temporary buffer.
- (insert-file-contents file)
- ;; Set the file name so normal-mode and htmlize-buffer-1 pick it
- ;; up. Restore it afterwards so with-temp-buffer's kill-buffer
- ;; doesn't complain about killing a modified buffer.
- (let ((buffer-file-name file))
- ;; Set the major mode for the sake of font-lock.
- (normal-mode)
- (font-lock-mode 1)
- (unless font-lock-mode
- ;; In GNU Emacs (font-lock-mode 1) doesn't force font-lock,
- ;; contrary to the documentation. This seems to work.
- (font-lock-fontify-buffer))
- ;; htmlize the buffer and save the HTML.
- (with-current-buffer (htmlize-buffer-1)
- (unwind-protect
- (progn
- (run-hooks 'htmlize-file-hook)
- (write-region (point-min) (point-max) output-file))
- (kill-buffer (current-buffer)))))))
- ;; I haven't decided on a useful return value yet, so just return
- ;; nil.
- nil)
-
-;;;###autoload
-(defun htmlize-many-files (files &optional target-directory)
- "Convert FILES to HTML and save the corresponding HTML versions.
-
-FILES should be a list of file names to convert. This function calls
-`htmlize-file' on each file; see that function for details. When
-invoked interactively, you are prompted for a list of files to convert,
-terminated with RET.
-
-If TARGET-DIRECTORY is specified, the HTML files will be saved to that
-directory. Normally, each HTML file is saved to the directory of the
-corresponding source file."
- (interactive
- (list
- (let (list file)
- ;; Use empty string as DEFAULT because setting DEFAULT to nil
- ;; defaults to the directory name, which is not what we want.
- (while (not (equal (setq file (read-file-name
- "HTML-ize file (RET to finish): "
- (and list (file-name-directory
- (car list)))
- "" t))
- ""))
- (push file list))
- (nreverse list))))
- ;; Verify that TARGET-DIRECTORY is indeed a directory. If it's a
- ;; file, htmlize-file will use it as target, and that doesn't make
- ;; sense.
- (and target-directory
- (not (file-directory-p target-directory))
- (error "target-directory must name a directory: %s" target-directory))
- (dolist (file files)
- (htmlize-file file target-directory)))
-
-;;;###autoload
-(defun htmlize-many-files-dired (arg &optional target-directory)
- "HTMLize dired-marked files."
- (interactive "P")
- (htmlize-many-files (dired-get-marked-files nil arg) target-directory))
-
-(provide 'htmlize)
-
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions lexical unresolved obsolete)
-;; lexical-binding: t
-;; End:
-
-;;; htmlize.el ends here
+++ /dev/null
-;;; ido-vertical-mode.el --- Makes ido-mode display vertically.
-
-;; Copyright (C) 2013 Steven Degutis
-
-;; Author: Steven Degutis
-;; Maintainer: Daniel Gempesaw <gempesawNOSPAMgmail.com>
-;; Version: 0.1.1
-;; Keywords: convenience
-;; URL: https://github.com/gempesaw/ido-vertical-mode.el
-
-;; 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:
-
-;; Makes ido-mode display prospects vertically
-
-;;; Code:
-
-(require 'ido)
-
-(defvar ido-vertical-decorations
- '("\n-> " ; left bracket around prospect list
- "" ; right bracket around prospect list
- "\n " ; separator between prospects, depends on `ido-separator`
- "\n ..." ; inserted at the end of a truncated list of prospects
- "[" ; left bracket around common match string
- "]" ; right bracket around common match string
- " [No match]"
- " [Matched]"
- " [Not readable]"
- " [Too big]"
- " [Confirm]"
- "\n-> " ; left bracket around the sole remaining completion
- "" ; right bracket around the sole remaining completion
- )
-
- "Changing the decorations does most of the work for ido-vertical
-
-This sets up newlines and arrows before, between, and after the
-prospects. For additional information, see `ido-decorations'.")
-
-(defvar ido-vertical-old-decorations nil
- "The original `ido-decorations' variable
-
-We need to keep track of the original value so we can restore it
-when turning `ido-vertical-mode' off")
-
-(defvar ido-vertical-old-completions nil
- "The original `ido-completions' function
-
-We need to keep track of the original value of `ido-completions'
-so we can restore it when turning `ido-vertical-mode' off")
-
-(defgroup ido-vertical-mode nil
- "Make ido behave vertically."
- :group 'ido-mode)
-
-(defcustom ido-vertical-define-keys 'C-n-and-C-p-only
- "Defines which keys that ido-vertical-mode redefines."
- :type '(choice
- (const :tag "Keep default ido keys." nil)
- (const :tag "C-p and C-n are up & down in match" 'C-n-and-C-p-only)
- (const :tag "C-p/up and C-n/down are up and down in match." 'C-n-C-p-up-and-down)
- (const :tag "C-p/up, C-n/down are up/down in match. left or right cycle history or directory." 'C-n-C-p-up-down-left-right))
- :group 'ido-vertical-mode)
-
-;; borrowed from ido.el and modified to work better when vertical
-(defun ido-vertical-completions (name)
- ;; Return the string that is displayed after the user's text.
- ;; Modified from `icomplete-completions'.
-
- (let* ((comps ido-matches)
- (ind (and (consp (car comps)) (> (length (cdr (car comps))) 1)
- ido-merged-indicator))
- first)
-
- (if (and ind ido-use-faces)
- (put-text-property 0 1 'face 'ido-indicator ind))
-
- (if (and ido-use-faces comps)
- (let* ((fn (ido-name (car comps)))
- (ln (length fn)))
- (setq first (format "%s" fn))
- (put-text-property 0 ln 'face
- (if (= (length comps) 1)
- (if ido-incomplete-regexp
- 'ido-incomplete-regexp
- 'ido-only-match)
- 'ido-first-match)
- first)
- (if ind (setq first (concat first ind)))
- (setq comps (cons first (cdr comps)))))
-
- (cond ((null comps)
- (cond
- (ido-show-confirm-message
- (or (nth 10 ido-decorations) " [Confirm]"))
- (ido-directory-nonreadable
- (or (nth 8 ido-decorations) " [Not readable]"))
- (ido-directory-too-big
- (or (nth 9 ido-decorations) " [Too big]"))
- (ido-report-no-match
- (nth 6 ido-decorations)) ;; [No match]
- (t "")))
- (ido-incomplete-regexp
- (concat " " (car comps)))
- ((null (cdr comps)) ;one match
- (concat (concat (nth 11 ido-decorations) ;; [ ... ]
- (ido-name (car comps))
- (nth 12 ido-decorations))
- (if (not ido-use-faces) (nth 7 ido-decorations)))) ;; [Matched]
- (t ;multiple matches
- (let* ((items (if (> ido-max-prospects 0) (1+ ido-max-prospects) 999))
- (alternatives
- (apply
- #'concat
- (cdr (apply
- #'nconc
- (mapcar
- (lambda (com)
- (setq com (ido-name com))
- (setq items (1- items))
- (cond
- ((< items 0) ())
- ((= items 0) (list (nth 3 ido-decorations))) ; " | ..."
- (t
- (list (or ido-separator (nth 2 ido-decorations)) ; " | "
- (let ((str (substring com 0)))
- (if (and ido-use-faces
- (not (string= str first))
- (ido-final-slash str))
- (put-text-property 0 (length str) 'face 'ido-subdir str))
- str)))))
- comps))))))
-
- (concat
- ;; put in common completion item -- what you get by pressing tab
- (if (and (stringp ido-common-match-string)
- (> (length ido-common-match-string) (length name)))
- (concat (nth 4 ido-decorations) ;; [ ... ]
- (substring ido-common-match-string (length name))
- (nth 5 ido-decorations)))
- ;; list all alternatives
- (nth 0 ido-decorations) ;; { ... }
- alternatives
- (nth 1 ido-decorations)))))))
-
-(defun ido-vertical-disable-line-truncation ()
- "Prevent the newlines in the minibuffer from being truncated"
- (set (make-local-variable 'truncate-lines) nil))
-
-(defun turn-on-ido-vertical ()
- (if (and (eq nil ido-vertical-old-decorations)
- (eq nil ido-vertical-old-completions))
- (progn
- (setq ido-vertical-old-decorations ido-decorations)
- (setq ido-vertical-old-completions (symbol-function 'ido-completions))))
-
- (setq ido-decorations ido-vertical-decorations)
- (fset 'ido-completions 'ido-vertical-completions)
-
- (add-hook 'ido-minibuffer-setup-hook 'ido-vertical-disable-line-truncation)
- (add-hook 'ido-setup-hook 'ido-vertical-define-keys))
-
-(defun turn-off-ido-vertical ()
- (setq ido-decorations ido-vertical-old-decorations)
- (fset 'ido-completions ido-vertical-old-completions)
-
- (remove-hook 'ido-minibuffer-setup-hook 'ido-vertical-disable-line-truncation)
- (remove-hook 'ido-setup-hbook 'ido-vertical-define-keys))
-
-(defun ido-vertical-next-match ()
- "Call the correct next-match function for right key.
-
-This is based on:
-- Different functions for completing directories and prior history.
-"
- (interactive)
- (cond
- ((and (boundp 'item) item (eq item 'file))
- (ido-next-match-dir))
- (t
- (next-history-element 1))))
-
-(defun ido-vertical-prev-match ()
- "Call the correct prev-match function for left key.
-
-This is based on:
-- Different functions for completing directories and prior history.
-"
- (interactive)
- (cond
- ((and (boundp 'item) item (eq item 'file))
- (ido-prev-match-dir))
- (t
- (previous-history-element 1))))
-
-(defun ido-vertical-define-keys () ;; C-n/p is more intuitive in vertical layout
- (when ido-vertical-define-keys
- (define-key ido-completion-map (kbd "C-n") 'ido-next-match)
- (define-key ido-completion-map (kbd "C-p") 'ido-prev-match)
- (define-key ido-completion-map (kbd "M-p") 'ido-toggle-prefix))
- (when (memq ido-vertical-define-keys '(C-n-C-p-up-and-down C-n-C-p-up-down-left-right))
- (define-key ido-completion-map (kbd "<up>") 'ido-prev-match)
- (define-key ido-completion-map (kbd "<down>") 'ido-next-match))
- (when (eq ido-vertical-define-keys 'C-n-C-p-up-down-left-right)
- (define-key ido-completion-map (kbd "<left>") 'ido-vertical-prev-match)
- (define-key ido-completion-map (kbd "<right>") 'ido-vertical-next-match)))
-
-;;;###autoload
-(define-minor-mode ido-vertical-mode
- "Makes ido-mode display vertically."
- :global t
- (if ido-vertical-mode
- (turn-on-ido-vertical)
- (turn-off-ido-vertical))
- (message "ido-vertical-mode has been %s"
- (if ido-vertical-mode "enabled" "disabled")))
-
-(provide 'ido-vertical-mode)
-;;; ido-vertical-mode.el ends here
+++ /dev/null
-;; ipcalc.el --- IP subnet calculator
-
-;; Filename: ipcalc.el
-;; Description: IP calculator
-;; Author: "Aleksandar Simic" <asimicNOSPAMgmail.com>
-;; License: BSD
-;; Created: 2012-03-11 17:10
-;; Version: 0.2.1
-;; URL: http://github.org/dotemacs/ipcalc.el
-;; Keywords: networking
-
-;;; Commentary:
-;;
-;; Usage: evaluate (ipcalc "192.168.0.23/21")
-
-;;; This file is NOT part of GNU Emacs
-;;
-;; Copyright (c) 2012, Aleksandar Simic
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-;; 1. Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;; 2. Redistributions in binary form must reproduce the above
-;; copyright notice, this list of conditions and the following
-;; disclaimer in the documentation and/or other materials provided
-;; with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-;; OF THE POSSIBILITY OF SUCH DAMAGE.
-
-;;; Code
-
-(defconst cidr-default 32 "CIDR value")
-
-(defun int-to-bin-string (n &optional length)
- ;; 08 Jun 1997 Jamie Zawinski <jwzNOSPAMnetscape.com> comp.emacs
- "Convert integer N to bit string (LENGTH, default 8)."
- (let* ((i 0)
- (len (or length 8))
- (s (make-string len ?0)))
- (while (< i len)
- (if (not (zerop (logand n (ash 1 i))))
- (aset s (- len (1+ i)) ?1))
- (setq i (1+ i))
- )
- s))
-
-(defun octets-as-binary (list-of-octets)
- "return LST of octets as a single binary string"
- (let ((binary ""))
- (while list-of-octets
- (setq binary
- (concat binary
- (int-to-bin-string
- (string-to-int (car list-of-octets)))))
- (setq list-of-octets (cdr list-of-octets)))
- binary))
-
-(defun ip-to-octets (ip)
- "split IP address and return the octets"
- (let ((octets (split-string ip "\\.")))
- (if (= 4 (length octets))
- octets
- (message "not correct IP format"))))
-
-(defun ones-and-pad (num)
- "return 1's equal to NUM and pad the rest up to 32"
- (unless (and (<= num cidr-default) (> num 0))
- (error "wrong value provided"))
- (concat (make-string num ?1)
- (make-string (- cidr-default num) ?0)))
-
-(defun invert-binary (num)
- "Invert 1s to 0s and vice versa
-
- (credit: the simpler version below re-writen by pjb from #emacs
- on freenode)"
- (map 'string
- (lambda (ch) (aref "10" (position ch "01")))
- (remove-if-not (lambda (ch) (position ch "01")) num)))
-
-(defun network (ip cidr)
- "Takes IP & CIDR and produces network"
- (let ((cidr-as-int (string-to-int cidr)))
- (concat
- (substring (octets-as-binary
- (ip-to-octets ip)) 0 cidr-as-int)
- (make-string (- cidr-default cidr-as-int) ?0))))
-
-(defun host+1 (binary-ip)
- "increment the given BINARY-IP by 1"
- (let ((tmp binary-ip))
- (aset tmp (- cidr-default 1) ?1)
- tmp))
-
-(defun host-max (ip cidr)
- (let ((count (string-to-int cidr))
- (max (- cidr-default 1)))
- (while (< count max)
- (aset ip count ?1)
- (setq count(incf count)))
- ip))
-
-(defun hosts/net (num)
- "Calculate Hosts/Net for the NUM given"
- (- (expt 2 (- cidr-default num)) 2))
-
-(defmacro list-to-string (lst)
- "convert LST to string"
- `(mapconcat
- '(lambda (val)
- (identity (if (integerp val)
- (int-to-string val)
- val)))
- ,lst ""))
-
-(defun insert-values (lst)
- "insert given LST"
- (insert
- (list-to-string lst)))
-
-(defun bin-to-int (bin)
- "Convert binary to integer"
- (int-to-string (read (concat "#b" bin))))
-
-(defun binary-to-ip (binary)
- "convert binary to IP address"
- (let* (full-ip
- (count 0)
- (1st-octet (substring binary 0 8))
- (2nd-octet (substring binary 8 16))
- (3rd-octet (substring binary 16 24))
- (4th-octet (substring binary 24 32))
- (octets (mapcar
- 'bin-to-int
- `(,1st-octet ,2nd-octet ,3rd-octet ,4th-octet))))
- (while (< count 3)
- (setq full-ip (concat full-ip (nth count octets) "."))
- (setq count (incf count)))
- (concat full-ip (car (last octets)))))
-
-(defun ipcalc (ip/cidr)
- "IP calculator"
- (let* ((ip (car (split-string ip/cidr "/")))
- (ip-in-binary (octets-as-binary (ip-to-octets ip)))
- (cidr (car (cdr (split-string ip/cidr "/"))))
- (cidr-int (string-to-int cidr))
- (cidr-binary (ones-and-pad cidr-int))
- (wildcard-binary (invert-binary (ones-and-pad cidr-int)))
- (wildcard-ip (binary-to-ip wildcard-binary))
- (netmask (binary-to-ip (invert-binary wildcard-binary)))
- (net-binary (network ip cidr))
- (net-ip (binary-to-ip net-binary))
- (host-max-binary (host-max (network ip cidr) cidr))
- (host-max-ip (binary-to-ip host-max-binary))
- (host-min-binary (host+1 (network ip cidr)))
- (host-min-ip (binary-to-ip host-min-binary))
- (broadcast-binary (host+1 (host-max net-binary cidr)))
- (broadcast-ip (binary-to-ip broadcast-binary))
- (buffer "*ipcalc*"))
- (if (get-buffer buffer)
- (kill-buffer buffer))
- (pop-to-buffer buffer)
- (insert
- (format "Address:%15s%41s\n" ip ip-in-binary)
- (format "Netmask:%16s = %2s %34s\n" netmask cidr cidr-binary)
- (format "Wildcard:%11s%44s\n" wildcard-ip wildcard-binary)
- (format "=>\nNetwork:%14s%42s\n" net-ip (network ip cidr))
- (format "HostMin:%14s%42s\n" host-min-ip host-min-binary)
- (format "HostMax:%16s%40s\n" host-max-ip host-max-binary)
- (format "Broadcast:%14s%40s\n" broadcast-ip broadcast-binary)
- (format "Hosts/Net: %d\n" (hosts/net cidr-int)))))
-
-(provide 'ipcalc)
-
-;;; ipcalc.el ends here
--- /dev/null
+;;; cfengine-code-style.el --- C code style for CFEngine project.
+
+;; Author: Mikhail Gusarov <mikhail.gusarovNOSPAMcfengine.com>
+;; URL: https://github.com/cfengine/core
+
+;;; Commentary:
+
+;; Usage:
+;;
+;; To enable coding style for the current buffer:
+;;
+;; M-x c-set-style cfengine
+;;
+;; To enable coding style permanently, create file .dir-locals.el with the
+;; following contents in the directory with the source code:
+;;
+;; ((c-mode . ((c-file-style . "cfengine"))))
+;;
+
+;;
+;; TODO: special rule for C99 (Foo) { 1, 2, 3 } initializers.
+;; TODO: special rule for whitespace between if/while/for and paren.
+;;
+
+;;; Code:
+
+(defconst cfengine-c-style
+ '(;; 4 spaces
+ (c-basic-offset . 4)
+ ;; Braces on new lines
+ (c-hanging-braces-alist . ((substatement-open before after)
+ (statement-cont)
+ (brace-list-open)
+ (brace-list-close)
+ (brace-list-intro)
+ (brace-entry-open)))
+ ;; Newline after 'case' label
+ (c-hanging-colons-alist . ((case-label after)))
+ ;; Don't place comma on a separate line after array/aggregate
+ (c-cleanup-list . (list-close-comma))
+ ;; Indentation
+ (c-offsets-alist . ((defun-open . 0)
+ (defun-block-intro . +)
+ (substatement-open . 0)
+ (statement-cont . +))))
+ "CFEngine Code Style")
+
+(c-add-style "CFEngine" cfengine-c-style)
+
+;;
+;; CFEngine uses CapitalizedWords for function names
+;;
+
+(defun cfengine-c-mode-hook ()
+ (if (eq c-file-style "CFEngine")
+ (progn
+ (setq indent-tabs-mode nil)
+ (setq c-tab-always-indent t)
+ (setq tab-width 4)
+ (subword-mode 1))))
+
+(add-hook 'c-mode-hook 'cfengine-c-mode-hook)
+
+(provide 'cfengine-code-style)
+
+;;; cfengine-code-style.el ends here
--- /dev/null
+;;; cfengine.el --- mode for editing Cfengine files
+
+;; Copyright (C) 2001-2014 Free Software Foundation, Inc.
+
+;; Author: Dave Love <fxNOSPAMgnu.org>
+;; Maintainer: Ted Zlatanov <tzzNOSPAMlifelogs.com>
+;; Keywords: languages
+;; Version: 1.3
+
+;; This file is part of GNU Emacs, but has trivial compatibility
+;; modifications for Emacs versions before 24. Emacs 24 and newer
+;; includes this code and you should use that version. The following
+;; is the copyright notice from Emacs, which still applies to this
+;; code and all derivations thereof.
+
+;; 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:
+
+;; Provides support for editing GNU Cfengine files, including
+;; font-locking, Imenu and indentation, but with no special keybindings.
+
+;; By default, CFEngine 3.x syntax is used.
+
+;; You can set it up so either `cfengine2-mode' (2.x and earlier) or
+;; `cfengine3-mode' (3.x) will be picked, depending on the buffer
+;; contents:
+
+;; (add-to-list 'auto-mode-alist '("\\.cf\\'" . cfengine-auto-mode))
+
+;; OR you can choose to always use a specific version, if you prefer
+;; it:
+
+;; (add-to-list 'auto-mode-alist '("\\.cf\\'" . cfengine3-mode))
+;; (add-to-list 'auto-mode-alist '("^cf\\." . cfengine2-mode))
+;; (add-to-list 'auto-mode-alist '("^cfagent.conf\\'" . cfengine2-mode))
+
+;; It's *highly* recommended that you enable the eldoc minor mode:
+
+;; (add-hook 'cfengine3-mode-hook 'eldoc-mode)
+
+;; It's *highly* recommended that you use this mode with the latest
+;; Emacs, or at least 24.1.
+
+;; This is not the same as the mode written by Rolf Ebert
+;; <ebertNOSPAMwaporo.muc.de>, distributed with cfengine-2.0.5. It does
+;; better fontification and indentation, inter alia.
+
+;;; Code:
+
+;; Set up compatibility with Emacsen where prog-mode doesn't exist.
+(defalias 'cfengine-prog-mode (if (fboundp 'prog-mode)
+ 'prog-mode
+ 'fundamental-mode))
+
+;; `setq-local' was introduced in 24.3
+(eval-when-compile
+ (or (fboundp 'setq-local)
+ (defmacro setq-local (var val)
+ `(set (make-local-variable ',var) ,val))))
+
+(autoload 'json-read "json")
+(autoload 'regexp-opt "regexp-opt")
+
+(defgroup cfengine ()
+ "Editing CFEngine files."
+ :group 'languages)
+
+(defcustom cfengine-indent 2
+ "Size of a CFEngine indentation step in columns."
+ :group 'cfengine
+ :type 'integer)
+
+(defcustom cfengine-cf-promises
+ (or (executable-find "cf-promises")
+ (executable-find "/var/cfengine/bin/cf-promises")
+ (executable-find "/usr/bin/cf-promises")
+ (executable-find "/usr/sbin/cf-promises")
+ (executable-find "/usr/local/bin/cf-promises")
+ (executable-find "/usr/local/sbin/cf-promises")
+ (executable-find "~/bin/cf-promises")
+ (executable-find "~/sbin/cf-promises"))
+ "The location of the cf-promises executable.
+Used for syntax discovery and checking. Set to nil to disable
+the `compile-command' override. In that case, the ElDoc support
+will use a fallback syntax definition."
+ :version "24.4"
+ :group 'cfengine
+ :type '(choice file (const nil)))
+
+(defcustom cfengine-parameters-indent '(promise pname 0)
+ "Indentation of CFEngine3 promise parameters (hanging indent).
+
+For example, say you have this code:
+
+bundle x y
+{
+ section:
+ class::
+ promise ...
+ promiseparameter => ...
+}
+
+You can choose to indent promiseparameter from the beginning of
+the line (absolutely) or from the word \"promise\" (relatively).
+
+You can also choose to indent the start of the word
+\"promiseparameter\" or the arrow that follows it.
+
+Finally, you can choose the amount of the indent.
+
+The default is to anchor at promise, indent parameter name, and offset 0:
+
+bundle agent rcfiles
+{
+ files:
+ any::
+ \"/tmp/netrc\"
+ comment => \"my netrc\",
+ perms => mog(\"600\", \"tzz\", \"tzz\");
+}
+
+Here we anchor at beginning of line, indent arrow, and offset 10:
+
+bundle agent rcfiles
+{
+ files:
+ any::
+ \"/tmp/netrc\"
+ comment => \"my netrc\",
+ perms => mog(\"600\", \"tzz\", \"tzz\");
+}
+
+Some, including cfengine_stdlib.cf, like to anchor at promise, indent
+arrow, and offset 16 or so:
+
+bundle agent rcfiles
+{
+ files:
+ any::
+ \"/tmp/netrc\"
+ comment => \"my netrc\",
+ perms => mog(\"600\", \"tzz\", \"tzz\");
+}
+"
+ :version "24.4"
+ :group 'cfengine
+ :type '(list
+ (choice (const :tag "Anchor at beginning of promise" promise)
+ (const :tag "Anchor at beginning of line" bol))
+ (choice (const :tag "Indent parameter name" pname)
+ (const :tag "Indent arrow" arrow))
+ (integer :tag "Indentation amount from anchor")))
+
+(defvar cfengine-mode-debug nil
+ "Whether `cfengine-mode' should print debugging info.")
+
+(defvar cfengine-mode-syntax-cache nil
+ "Cache for `cfengine-mode' syntax trees obtained from 'cf-promises -s json'.")
+
+; Be sure to keep these two in sync with libpromises/cf3.defs.h
+(defconst cfengine3-uint-range "0,2147483647")
+(defconst cfengine3-sint-range "-2147483648,2147483647")
+
+(defconst cfengine3-fallback-syntax
+ '((functions
+ (userexists
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (usemodule
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (unique
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (translatepath
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (sum
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "real") (status . "normal"))
+ (sublist
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "head,tail") (type . "option"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (strftime
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "gmtime,localtime") (type . "option"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (strcmp
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (splitstring
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (splayclass
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "daily,hourly") (type . "option"))])
+ (returnType . "context") (status . "normal"))
+ (sort
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "lex") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (some
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (shuffle
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (selectservers
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (reverse
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (rrange
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "-9.99999E100,9.99999E100") (type . "real"))
+ ((range . "-9.99999E100,9.99999E100") (type . "real"))])
+ (returnType . "rrange") (status . "normal"))
+ (returnszero
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "useshell,noshell,powershell") (type . "option"))])
+ (returnType . "context") (status . "normal"))
+ (remoteclassesmatching
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "true,false,yes,no,on,off") (type . "option"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (remotescalar
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "true,false,yes,no,on,off") (type . "option"))])
+ (returnType . "string") (status . "normal"))
+ (regldap
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "subtree,onelevel,base") (type . "option"))
+ ((range . ".*") (type . "string"))
+ ((range . "none,ssl,sasl") (type . "option"))])
+ (returnType . "context") (status . "normal"))
+ (reglist
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (regline
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (registryvalue
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (regextract
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (regcmp
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (regarray
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (readtcp
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (readstringlist
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (readstringarrayidx
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (readstringarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (readreallist
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "rlist") (status . "normal"))
+ (readrealarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (readintlist
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "ilist") (status . "normal"))
+ (readintarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (readfile
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (randomint
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . cfengine3-sint-range) (type . "int"))
+ ((range . cfengine3-sint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (product
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "real") (status . "normal"))
+ (peerleaders
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (peerleader
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (peers
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (parsestringarrayidx
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (parsestringarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (parserealarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (parseintarray
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (or
+ (category . "data") (variadic . t)
+ (parameters . [])
+ (returnType . "string") (status . "normal"))
+ (on
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "1970,3000") (type . "int"))
+ ((range . "1,12") (type . "int"))
+ ((range . "1,31") (type . "int"))
+ ((range . "0,23") (type . "int"))
+ ((range . "0,59") (type . "int"))
+ ((range . "0,59") (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (nth
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (now
+ (category . "system") (variadic . :json-false)
+ (parameters . [])
+ (returnType . "int") (status . "normal"))
+ (not
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (none
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (maplist
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (maparray
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (lsdir
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . ".+") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "true,false,yes,no,on,off") (type . "option"))])
+ (returnType . "slist") (status . "normal"))
+ (length
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (ldapvalue
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "subtree,onelevel,base") (type . "option"))
+ ((range . "none,ssl,sasl") (type . "option"))])
+ (returnType . "string") (status . "normal"))
+ (ldaplist
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "subtree,onelevel,base") (type . "option"))
+ ((range . "none,ssl,sasl") (type . "option"))])
+ (returnType . "slist") (status . "normal"))
+ (ldaparray
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . "subtree,onelevel,base") (type . "option"))
+ ((range . "none,ssl,sasl") (type . "option"))])
+ (returnType . "context") (status . "normal"))
+ (laterthan
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,40000") (type . "int"))])
+ (returnType . "context") (status . "normal"))
+ (lastnode
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (join
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (isvariable
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (isplain
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (isnewerthan
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (islink
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (islessthan
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (isgreaterthan
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (isexecutable
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (isdir
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (irange
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . cfengine3-sint-range) (type . "int"))
+ ((range . cfengine3-sint-range) (type . "int"))])
+ (returnType . "irange") (status . "normal"))
+ (iprange
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (intersection
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (ifelse
+ (category . "data") (variadic . t)
+ (parameters . [])
+ (returnType . "string") (status . "normal"))
+ (hubknowledge
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (hostswithclass
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_]+") (type . "string"))
+ ((range . "name,address") (type . "option"))])
+ (returnType . "slist") (status . "normal"))
+ (hostsseen
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . cfengine3-uint-range) (type . "int"))
+ ((range . "lastseen,notseen") (type . "option"))
+ ((range . "name,address") (type . "option"))])
+ (returnType . "slist") (status . "normal"))
+ (hostrange
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (hostinnetgroup
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (ip2host
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (host2ip
+ (category . "communication") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (hashmatch
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "md5,sha1,crypt,cf_sha224,cf_sha256,cf_sha384,cf_sha512") (type . "option"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (hash
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "md5,sha1,sha256,sha512,sha384,crypt") (type . "option"))])
+ (returnType . "string") (status . "normal"))
+ (groupexists
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (grep
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (getvalues
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (getusers
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (getuid
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (getindices
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (getgid
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (getfields
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))
+ ((range . ".*") (type . "string"))
+ ((range . ".*") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (getenv
+ (category . "system") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "string") (status . "normal"))
+ (format
+ (category . "data") (variadic . t)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (filter
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "true,false,yes,no,on,off") (type . "option"))
+ ((range . "true,false,yes,no,on,off") (type . "option"))
+ ((range . cfengine3-uint-range) (type . "int"))])
+ (returnType . "slist") (status . "normal"))
+ (filestat
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "size,gid,uid,ino,nlink,ctime,atime,mtime,mode,modeoct,permstr,permoct,type,devno,dev_minor,dev_major,basename,dirname") (type . "option"))])
+ (returnType . "string") (status . "normal"))
+ (filesize
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (filesexist
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "@[(][a-zA-Z0-9]+[)]") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (fileexists
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (execresult
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".+") (type . "string"))
+ ((range . "useshell,noshell,powershell") (type . "option"))])
+ (returnType . "string") (status . "normal"))
+ (every
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (escape
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (diskfree
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (dirname
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (difference
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+ ((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (countlinesmatching
+ (category . "io") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (countclassesmatching
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "int") (status . "normal"))
+ (classesmatching
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "slist") (status . "normal"))
+ (classmatch
+ (category . "utils") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (classify
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (changedbefore
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))
+ (concat
+ (category . "data") (variadic . t)
+ (parameters . [])
+ (returnType . "string") (status . "normal"))
+ (canonify
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . ".*") (type . "string"))])
+ (returnType . "string") (status . "normal"))
+ (and
+ (category . "data") (variadic . t)
+ (parameters . [])
+ (returnType . "string") (status . "normal"))
+ (ago
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,40000") (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (accumulated
+ (category . "data") (variadic . :json-false)
+ (parameters . [((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,1000") (type . "int"))
+ ((range . "0,40000") (type . "int"))])
+ (returnType . "int") (status . "normal"))
+ (accessedbefore
+ (category . "files") (variadic . :json-false)
+ (parameters . [((range . "\"?(/.*)") (type . "string"))
+ ((range . "\"?(/.*)") (type . "string"))])
+ (returnType . "context") (status . "normal"))))
+ "Fallback CFEngine syntax, containing just function definitions.")
+
+(defvar cfengine-mode-syntax-functions-regex
+ (regexp-opt (mapcar (lambda (def)
+ (format "%s" (car def)))
+ (cdr (assq 'functions cfengine3-fallback-syntax)))
+ 'symbols))
+
+(defcustom cfengine-mode-abbrevs nil
+ "Abbrevs for CFEngine2 mode."
+ :group 'cfengine
+ :type '(repeat (list (string :tag "Name")
+ (string :tag "Expansion")
+ (choice :tag "Hook" (const nil) function))))
+
+(make-obsolete-variable 'cfengine-mode-abbrevs 'edit-abbrevs "24.1")
+
+;; Taken from the doc for pre-release 2.1.
+(eval-and-compile
+ (defconst cfengine2-actions
+ '("acl" "alerts" "binservers" "broadcast" "control" "classes" "copy"
+ "defaultroute" "disks" "directories" "disable" "editfiles" "files"
+ "filters" "groups" "homeservers" "ignore" "import" "interfaces"
+ "links" "mailserver" "methods" "miscmounts" "mountables"
+ "processes" "packages" "rename" "required" "resolve"
+ "shellcommands" "tidy" "unmount"
+ ;; Keywords for cfservd.
+ "admit" "grant" "deny")
+ "List of the action keywords supported by Cfengine.
+This includes those for cfservd as well as cfagent.")
+
+ (defconst cfengine3-defuns '("bundle" "body")
+ "List of the CFEngine 3.x defun headings.")
+
+ (defconst cfengine3-defuns-regex (regexp-opt cfengine3-defuns t)
+ "Regex to match the CFEngine 3.x defuns.")
+
+ (defconst cfengine3-defun-full-re (concat "^\\s-*" cfengine3-defuns-regex
+ "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;type
+ "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;id
+ )
+ "Regexp matching full defun declaration (excluding argument list).")
+
+ (defconst cfengine3-class-selector-regex "\\([[:alnum:]_().&|!:]+\\)::")
+
+ (defconst cfengine3-category-regex "\\([[:alnum:]_]+\\):")
+
+ (defconst cfengine3-vartypes '("string" "int" "real" "slist" "ilist" "rlist"
+ "irange" "rrange" "counter" "data")
+ "List of the CFEngine 3.x variable types."))
+
+(defconst cfengine-font-lock-syntactic-keywords
+ ;; In the main syntax-table, backslash is marked as a punctuation, because
+ ;; of its use in DOS-style directory separators. Here we try to recognize
+ ;; the cases where backslash is used as an escape inside strings.
+ '(("\\(\\(?:\\\\\\)+\\)\"" 1 "\\")))
+
+(defvar cfengine2-font-lock-keywords
+ `(;; Actions.
+ ;; List the allowed actions explicitly, so that errors are more obvious.
+ (,(concat "^[ \t]*" (eval-when-compile
+ (regexp-opt cfengine2-actions t))
+ ":")
+ 1 font-lock-keyword-face)
+ ;; Classes.
+ ("^[ \t]*\\([[:alnum:]_().|!]+\\)::" 1 font-lock-function-name-face)
+ ;; Variables.
+ ("$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face)
+ ("${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face)
+ ;; Variable definitions.
+ ("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
+ ;; File, acl &c in group: { token ... }
+ ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face)))
+
+(defvar cfengine3-font-lock-keywords
+ `(
+ ;; Defuns. This happens early so they don't get caught by looser
+ ;; patterns.
+ (,(concat "\\_<" cfengine3-defuns-regex "\\_>"
+ "[ \t]+\\_<\\([[:alnum:]_.:]+\\)\\_>"
+ "[ \t]+\\_<\\([[:alnum:]_.:]+\\)"
+ ;; Optional parentheses with variable names inside.
+ "\\(?:(\\([^)]*\\))\\)?")
+ (1 font-lock-builtin-face)
+ (2 font-lock-constant-face)
+ (3 font-lock-function-name-face)
+ (4 font-lock-variable-name-face nil t))
+
+ ;; Class selectors.
+ (,(concat "^[ \t]*" cfengine3-class-selector-regex)
+ 1 font-lock-keyword-face)
+
+ ;; Categories.
+ (,(concat "^[ \t]*" cfengine3-category-regex)
+ 1 font-lock-builtin-face)
+
+ ;; Variables, including scope, e.g. module.var
+ ("[@$](\\([[:alnum:]_.:]+\\))" 1 font-lock-variable-name-face)
+ ("[@$]{\\([[:alnum:]_.:]+\\)}" 1 font-lock-variable-name-face)
+
+ ;; Variable definitions.
+ ("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
+
+ ;; Variable types.
+ (,(concat "\\_<" (eval-when-compile (regexp-opt cfengine3-vartypes t)) "\\_>")
+ 1 font-lock-type-face)))
+
+(defvar cfengine2-imenu-expression
+ `((nil ,(concat "^[ \t]*" (eval-when-compile
+ (regexp-opt cfengine2-actions t))
+ ":[^:]")
+ 1)
+ ("Variables/classes" "\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1)
+ ("Variables/classes" "\\_<define=\\([[:alnum:]_]+\\)" 1)
+ ("Variables/classes" "\\_<DefineClass\\>[ \t]+\\([[:alnum:]_]+\\)" 1))
+ "`imenu-generic-expression' for CFEngine mode.")
+
+(defun cfengine2-outline-level ()
+ "`outline-level' function for CFEngine mode."
+ (if (looking-at "[^:]+\\(?:[:]+\\)$")
+ (length (match-string 1))))
+
+(defun cfengine2-beginning-of-defun ()
+ "`beginning-of-defun' function for CFEngine mode.
+Treats actions as defuns."
+ (unless (<= (current-column) (current-indentation))
+ (end-of-line))
+ (if (re-search-backward "^[[:alpha:]]+: *$" nil t)
+ (beginning-of-line)
+ (goto-char (point-min)))
+ t)
+
+(defun cfengine2-end-of-defun ()
+ "`end-of-defun' function for CFEngine mode.
+Treats actions as defuns."
+ (end-of-line)
+ (if (re-search-forward "^[[:alpha:]]+: *$" nil t)
+ (beginning-of-line)
+ (goto-char (point-max)))
+ t)
+
+;; Fixme: Should get an extra indent step in editfiles BeginGroup...s.
+
+(defun cfengine2-indent-line ()
+ "Indent a line in Cfengine mode.
+Intended as the value of `indent-line-function'."
+ (let ((pos (- (point-max) (point))))
+ (save-restriction
+ (narrow-to-defun)
+ (back-to-indentation)
+ (cond
+ ;; Action selectors aren't indented; class selectors are
+ ;; indented one step.
+ ((looking-at "[[:alnum:]_().|!]+:\\(:\\)?")
+ (if (match-string 1)
+ (indent-line-to cfengine-indent)
+ (indent-line-to 0)))
+ ;; Outdent leading close brackets one step.
+ ((or (eq ?\} (char-after))
+ (eq ?\) (char-after)))
+ (condition-case ()
+ (indent-line-to (save-excursion
+ (forward-char)
+ (backward-sexp)
+ (current-column)))
+ (error nil)))
+ ;; Inside brackets/parens: indent to start column of non-comment
+ ;; token on line following open bracket or by one step from open
+ ;; bracket's column.
+ ((condition-case ()
+ (progn (indent-line-to (save-excursion
+ (backward-up-list)
+ (forward-char)
+ (skip-chars-forward " \t")
+ (if (looking-at "[^\n#]")
+ (current-column)
+ (skip-chars-backward " \t")
+ (+ (current-column) -1
+ cfengine-indent))))
+ t)
+ (error nil)))
+ ;; Indent by two steps after a class selector.
+ ((save-excursion
+ (re-search-backward "^[ \t]*[[:alnum:]_().|!]+::" nil t))
+ (indent-line-to (* 2 cfengine-indent)))
+ ;; Indent by one step if we're after an action header.
+ ((save-excursion
+ (goto-char (point-min))
+ (looking-at "[[:alpha:]]+:[ \t]*$"))
+ (indent-line-to cfengine-indent))
+ ;; Else don't indent.
+ (t
+ (indent-line-to 0))))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))))
+
+;; This doesn't work too well in Emacs 21.2. See 22.1 development
+;; code.
+(defun cfengine-fill-paragraph (&optional justify)
+ "Fill `paragraphs' in Cfengine code."
+ (interactive "P")
+ (or (if (fboundp 'fill-comment-paragraph)
+ (fill-comment-paragraph justify) ; post Emacs 21.3
+ ;; else do nothing in a comment
+ (nth 4 (parse-partial-sexp (save-excursion
+ (beginning-of-defun)
+ (point))
+ (point))))
+ (let ((paragraph-start
+ ;; Include start of parenthesized block.
+ "\f\\|[ \t]*$\\|.*\(")
+ (paragraph-separate
+ ;; Include action and class lines, start and end of
+ ;; bracketed blocks and end of parenthesized blocks to
+ ;; avoid including these in fill. This isn't ideal.
+ "[ \t\f]*$\\|.*#\\|.*[\){}]\\|\\s-*[[:alpha:]_().|!]+:")
+ fill-paragraph-function)
+ (fill-paragraph justify))
+ t))
+
+(defun cfengine3-beginning-of-defun ()
+ "`beginning-of-defun' function for Cfengine 3 mode.
+Treats body/bundle blocks as defuns."
+ (unless (<= (current-column) (current-indentation))
+ (end-of-line))
+ (if (re-search-backward (concat "^[ \t]*" cfengine3-defuns-regex "\\_>") nil t)
+ (beginning-of-line)
+ (goto-char (point-min)))
+ t)
+
+(defun cfengine3-end-of-defun ()
+ "`end-of-defun' function for Cfengine 3 mode.
+Treats body/bundle blocks as defuns."
+ (end-of-line)
+ (if (re-search-forward (concat "^[ \t]*" cfengine3-defuns-regex "\\_>") nil t)
+ (beginning-of-line)
+ (goto-char (point-max)))
+ t)
+
+(defun cfengine3-indent-line ()
+ "Indent a line in Cfengine 3 mode.
+Intended as the value of `indent-line-function'."
+ (let ((pos (- (point-max) (point)))
+ parse)
+ (save-restriction
+ (narrow-to-defun)
+ (back-to-indentation)
+ (setq parse (parse-partial-sexp (point-min) (point)))
+ (when cfengine-mode-debug
+ (message "%S" parse))
+
+ (cond
+ ;; Body/bundle blocks start at 0.
+ ((looking-at (concat cfengine3-defuns-regex "\\_>"))
+ (indent-line-to 0))
+ ;; Categories are indented one step.
+ ((looking-at (concat cfengine3-category-regex "[ \t]*\\(#.*\\)*$"))
+ (indent-line-to cfengine-indent))
+ ;; Class selectors are indented two steps.
+ ((looking-at (concat cfengine3-class-selector-regex "[ \t]*\\(#.*\\)*$"))
+ (indent-line-to (* 2 cfengine-indent)))
+ ;; Outdent leading close brackets one step.
+ ((or (eq ?\} (char-after))
+ (eq ?\) (char-after)))
+ (condition-case ()
+ (indent-line-to (save-excursion
+ (forward-char)
+ (backward-sexp)
+ (move-beginning-of-line nil)
+ (skip-chars-forward " \t")
+ (current-column)))
+ (error nil)))
+ ;; Inside a string and it starts before this line: do nothing.
+ ((and (nth 3 parse)
+ (< (nth 8 parse) (save-excursion (beginning-of-line) (point))))
+ )
+
+ ;; Inside a defun, but not a nested list (depth is 1). This is
+ ;; a promise, usually.
+
+ ;; Indent to cfengine-indent times the nested depth
+ ;; plus 2. That way, promises indent deeper than class
+ ;; selectors, which in turn are one deeper than categories.
+ ((= 1 (nth 0 parse))
+ (let ((p-anchor (nth 0 cfengine-parameters-indent))
+ (p-what (nth 1 cfengine-parameters-indent))
+ (p-indent (nth 2 cfengine-parameters-indent)))
+ ;; Do we have the parameter anchor and location and indent
+ ;; defined, and are we looking at a promise parameter?
+ (if (and p-anchor p-what p-indent
+ (looking-at "\\([[:alnum:]_]+[ \t]*\\)=>"))
+ (let* ((arrow-offset (* -1 (length (match-string 1))))
+ (extra-offset (if (eq p-what 'arrow) arrow-offset 0))
+ (base-offset (if (eq p-anchor 'promise)
+ (* (+ 2 (nth 0 parse)) cfengine-indent)
+ 0)))
+ (indent-line-to (max 0 (+ p-indent base-offset extra-offset))))
+ ;; Else, indent to cfengine-indent times the nested depth
+ ;; plus 2. That way, promises indent deeper than class
+ ;; selectors, which in turn are one deeper than categories.
+ (indent-line-to (* (+ 2 (nth 0 parse)) cfengine-indent)))))
+ ;; Inside brackets/parens: indent to start column of non-comment
+ ;; token on line following open bracket or by one step from open
+ ;; bracket's column.
+ ((condition-case ()
+ (progn (indent-line-to (save-excursion
+ (backward-up-list)
+ (forward-char)
+ (skip-chars-forward " \t")
+ (cond
+ ((looking-at "[^\n#]")
+ (current-column))
+ ((looking-at "[^\n#]")
+ (current-column))
+ (t
+ (skip-chars-backward " \t")
+ (+ (current-column) -1
+ cfengine-indent)))))
+ t)
+ (error nil)))
+ ;; Else don't indent.
+ (t (indent-line-to 0))))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))))
+
+;; CFEngine 3.x grammar
+
+;; specification: blocks
+;; blocks: block | blocks block;
+;; block: bundle typeid blockid bundlebody
+;; | bundle typeid blockid usearglist bundlebody
+;; | body typeid blockid bodybody
+;; | body typeid blockid usearglist bodybody;
+
+;; typeid: id
+;; blockid: id
+;; usearglist: '(' aitems ')';
+;; aitems: aitem | aitem ',' aitems |;
+;; aitem: id
+
+;; bundlebody: '{' statements '}'
+;; statements: statement | statements statement;
+;; statement: category | classpromises;
+
+;; bodybody: '{' bodyattribs '}'
+;; bodyattribs: bodyattrib | bodyattribs bodyattrib;
+;; bodyattrib: class | selections;
+;; selections: selection | selections selection;
+;; selection: id ASSIGN rval ';' ;
+
+;; classpromises: classpromise | classpromises classpromise;
+;; classpromise: class | promises;
+;; promises: promise | promises promise;
+;; category: CATEGORY
+;; promise: promiser ARROW rval constraints ';' | promiser constraints ';';
+;; constraints: constraint | constraints ',' constraint |;
+;; constraint: id ASSIGN rval;
+;; class: CLASS
+;; id: ID
+;; rval: ID | QSTRING | NAKEDVAR | list | usefunction
+;; list: '{' litems '}' ;
+;; litems: litem | litem ',' litems |;
+;; litem: ID | QSTRING | NAKEDVAR | list | usefunction
+
+;; functionid: ID | NAKEDVAR
+;; promiser: QSTRING
+;; usefunction: functionid givearglist
+;; givearglist: '(' gaitems ')'
+;; gaitems: gaitem | gaitems ',' gaitem |;
+;; gaitem: ID | QSTRING | NAKEDVAR | list | usefunction
+
+;; # from lexer:
+
+;; bundle: "bundle"
+;; body: "body"
+;; COMMENT #[^\n]*
+;; NAKEDVAR [$@][(][a-zA-Z0-9_\200-\377.]+[)]|[$@][{][a-zA-Z0-9_\200-\377.]+[}]
+;; ID: [a-zA-Z0-9_\200-\377]+
+;; ASSIGN: "=>"
+;; ARROW: "->"
+;; QSTRING: \"((\\\")|[^"])*\"|\'((\\\')|[^'])*\'|`[^`]*`
+;; CLASS: [.|&!()a-zA-Z0-9_\200-\377]+::
+;; CATEGORY: [a-zA-Z_]+:
+
+(defun cfengine3--current-function ()
+ "Look up current CFEngine 3 function"
+ (let* ((syntax (cfengine3-make-syntax-cache))
+ (flist (assq 'functions syntax)))
+ (when flist
+ (let ((w (save-excursion
+ (skip-syntax-forward "w_")
+ (when (search-backward-regexp
+ cfengine-mode-syntax-functions-regex
+ (point-at-bol)
+ t)
+ (match-string 1)))))
+ (and w (assq (intern w) flist))))))
+
+;; format from "cf-promises -s json", e.g. "sort" function:
+;; ((category . "data")
+;; (variadic . :json-false)
+;; (parameters . [((range . "[a-zA-Z0-9_$(){}\\[\\].:]+") (type . "string"))
+;; ((range . "lex,int,real,IP,ip,MAC,mac") (type . "option"))])
+;; (returnType . "slist")
+;; (status . "normal"))
+
+(defun cfengine3-format-function-docstring (fdef)
+ (let* ((f (format "%s" (car-safe fdef)))
+ (def (cdr fdef))
+ (rtype (cdr (assq 'returnType def)))
+ (plist (cdr (assq 'parameters def)))
+ (has-some-parameters (> (length plist) 0))
+ (variadic (eq t (cdr (assq 'variadic def)))))
+
+ ;; (format "[%S]%s %s(%s%s)" def
+ (format "%s %s(%s%s)"
+ (if rtype
+ (propertize rtype 'face 'font-lock-variable-name-face)
+ "???")
+ (propertize f 'face 'font-lock-function-name-face)
+ (mapconcat (lambda (p)
+ (let ((type (cdr (assq 'type p)))
+ (range (cdr (assq 'range p))))
+ (cond
+ ((not (stringp type)) "???type???")
+ ((not (stringp range)) "???range???")
+ ;; options are lists of possible keywords
+ ((equal type "option")
+ (propertize (concat "[" range "]")
+ 'face
+ 'font-lock-keyword-face))
+ ;; anything else is a type name as a variable
+ (t (propertize type
+ 'face
+ 'font-lock-variable-name-face)))))
+ plist
+ ", ")
+ (if variadic
+ (if has-some-parameters ", ..." "...")
+ ""))))
+
+(defun cfengine3-clear-syntax-cache ()
+ "Clear the internal syntax cache.
+Should not be necessary unless you reinstall CFEngine."
+ (interactive)
+ (setq cfengine-mode-syntax-functions-regex nil)
+ (setq cfengine-mode-syntax-cache nil))
+
+(defun cfengine3-make-syntax-cache ()
+ "Build the CFEngine 3 syntax cache and return the syntax.
+Calls `cfengine-cf-promises' with \"-s json\"."
+ (or (cdr (assoc cfengine-cf-promises cfengine-mode-syntax-cache))
+ (let ((syntax (or (when cfengine-cf-promises
+ (with-demoted-errors "cfengine3-make-syntax-cache: %S"
+ (with-temp-buffer
+ (or (zerop (process-file cfengine-cf-promises
+ nil ; no input
+ t ; output
+ nil ; no redisplay
+ "-s" "json"))
+ (error "%s" (buffer-substring
+ (point-min)
+ (progn (goto-char (point-min))
+ (line-end-position)))))
+ (goto-char (point-min))
+ (json-read))))
+ cfengine3-fallback-syntax)))
+ (push (cons cfengine-cf-promises syntax)
+ cfengine-mode-syntax-cache)
+ (setq cfengine-mode-syntax-functions-regex
+ (regexp-opt (mapcar (lambda (def)
+ (format "%s" (car def)))
+ (cdr (assq 'functions syntax)))
+ 'symbols))
+ syntax)))
+
+(defun cfengine3-documentation-function ()
+ "Document CFengine 3 functions around point.
+Intended as the value of `eldoc-documentation-function', which see.
+Use it by enabling `eldoc-mode'."
+ (let ((fdef (cfengine3--current-function)))
+ (when fdef
+ (cfengine3-format-function-docstring fdef))))
+
+(defun cfengine3-completion-function ()
+ "Return completions for function name around or before point."
+ (let* ((bounds (save-excursion
+ (let ((p (point)))
+ (skip-syntax-backward "w_" (point-at-bol))
+ (list (point) p))))
+ (syntax (cfengine3-make-syntax-cache))
+ (flist (assq 'functions syntax)))
+ (when bounds
+ (append bounds (list (cdr flist))))))
+
+(defun cfengine-common-settings ()
+ (if (fboundp 'syntax-propertize-rules)
+ (set (make-local-variable 'syntax-propertize-function)
+ ;; In the main syntax-table, \ is marked as a punctuation, because
+ ;; of its use in DOS-style directory separators. Here we try to
+ ;; recognize the cases where \ is used as an escape inside strings.
+ (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\"))))
+
+ ;; Backwards compatibility without `syntax-propertize-function'.
+ (setq font-lock-defaults
+ '(cfengine2-font-lock-keywords
+ nil nil nil beginning-of-line
+ (font-lock-syntactic-keywords
+ . cfengine-font-lock-syntactic-keywords))))
+
+ (set (make-local-variable 'parens-require-spaces) nil)
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
+ ;; Like Lisp mode. Without this, we lose with, say,
+ ;; `backward-up-list' when there's an unbalanced quote in a
+ ;; preceding comment.
+ (set (make-local-variable 'parse-sexp-ignore-comments) t))
+
+(defun cfengine-common-syntax (table)
+ ;; The syntax defaults seem OK to give reasonable word movement.
+ (modify-syntax-entry ?# "<" table)
+ (modify-syntax-entry ?\n ">#" table)
+ (modify-syntax-entry ?\" "\"" table) ; "string"
+ (modify-syntax-entry ?\' "\"" table) ; 'string'
+ ;; Variable substitution.
+ (modify-syntax-entry ?$ "." table)
+ ;; Doze path separators.
+ (modify-syntax-entry ?\\ "." table))
+
+(defconst cfengine3--prettify-symbols-alist
+ '(("->" . ?→)
+ ("=>" . ?⇒)
+ ("::" . ?∷)))
+
+(defun cfengine3-create-imenu-index ()
+ "A function for `imenu-create-index-function'.
+Note: defun name is separated by space such as `body
+package_method opencsw' and imenu will replace spaces according
+to `imenu-space-replacement' (which see)."
+ (goto-char (point-min))
+ (let ((defuns ()))
+ (while (re-search-forward cfengine3-defun-full-re nil t)
+ (push (cons (mapconcat #'match-string '(1 2 3) " ")
+ (copy-marker (match-beginning 3)))
+ defuns))
+ (nreverse defuns)))
+
+(defun cfengine3-current-defun ()
+ "A function for `add-log-current-defun-function'."
+ (end-of-line)
+ (beginning-of-defun)
+ (and (looking-at cfengine3-defun-full-re)
+ (mapconcat #'match-string '(1 2 3) " ")))
+
+;;;###autoload
+(define-derived-mode cfengine3-mode cfengine-prog-mode "CFE3"
+ "Major mode for editing CFEngine3 input.
+There are no special keybindings by default.
+
+Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
+to the action header."
+ (cfengine-common-settings)
+ (cfengine-common-syntax cfengine3-mode-syntax-table)
+
+ (set (make-local-variable 'indent-line-function) #'cfengine3-indent-line)
+
+ (setq font-lock-defaults
+ '(cfengine3-font-lock-keywords
+ nil nil nil beginning-of-defun))
+ (setq-local prettify-symbols-alist cfengine3--prettify-symbols-alist)
+
+ ;; `compile-command' is almost never a `make' call with CFEngine so
+ ;; we override it
+ (when cfengine-cf-promises
+ (set (make-local-variable 'compile-command)
+ (concat cfengine-cf-promises
+ " -f "
+ (when buffer-file-name
+ (shell-quote-argument buffer-file-name)))))
+
+ (setq-local flycheck-cfengine-executable cfengine-cf-promises)
+
+ (setq-local eldoc-documentation-function #'cfengine3-documentation-function)
+
+ (add-hook 'completion-at-point-functions
+ #'cfengine3-completion-function nil t)
+
+ ;; Use defuns as the essential syntax block.
+ (setq-local beginning-of-defun-function #'cfengine3-beginning-of-defun)
+ (setq-local end-of-defun-function #'cfengine3-end-of-defun)
+
+ (setq-local imenu-create-index-function #'cfengine3-create-imenu-index)
+ (setq-local add-log-current-defun-function #'cfengine3-current-defun))
+
+;;;###autoload
+(define-derived-mode cfengine2-mode cfengine-prog-mode "CFE2"
+ "Major mode for editing CFEngine2 input.
+There are no special keybindings by default.
+
+Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
+to the action header."
+ (cfengine-common-settings)
+ (cfengine-common-syntax cfengine2-mode-syntax-table)
+
+ ;; Shell commands can be quoted by single, double or back quotes.
+ ;; It's debatable whether we should define string syntax, but it
+ ;; should avoid potential confusion in some cases.
+ (modify-syntax-entry ?\` "\"" cfengine2-mode-syntax-table)
+
+ (set (make-local-variable 'indent-line-function) #'cfengine2-indent-line)
+ (set (make-local-variable 'outline-regexp) "[ \t]*\\(\\sw\\|\\s_\\)+:+")
+ (set (make-local-variable 'outline-level) #'cfengine2-outline-level)
+ (set (make-local-variable 'fill-paragraph-function)
+ #'cfengine-fill-paragraph)
+ (define-abbrev-table 'cfengine-mode-abbrev-table cfengine2-mode-abbrevs)
+ (setq font-lock-defaults
+ '(cfengine2-font-lock-keywords nil nil nil beginning-of-line))
+ ;; Fixme: set the args of functions in evaluated classes to string
+ ;; syntax, and then obey syntax properties.
+ (setq imenu-generic-expression cfengine2-imenu-expression)
+ (set (make-local-variable 'beginning-of-defun-function)
+ #'cfengine2-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function) #'cfengine2-end-of-defun))
+
+;;;###autoload
+(defun cfengine-auto-mode ()
+ "Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents."
+ (interactive)
+ (if (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ (or (eobp)
+ (re-search-forward
+ (concat "^\\s-*" cfengine3-defuns-regex "\\_>") nil t))))
+ (cfengine3-mode)
+ (cfengine2-mode)))
+
+(defalias 'cfengine-mode 'cfengine3-mode)
+
+(provide 'cfengine3)
+(provide 'cfengine)
+
+;;; cfengine.el ends here
--- /dev/null
+;; ipcalc.el --- IP subnet calculator
+
+;; Filename: ipcalc.el
+;; Description: IP calculator
+;; Author: "Aleksandar Simic" <asimicNOSPAMgmail.com>
+;; License: BSD
+;; Created: 2012-03-11 17:10
+;; Version: 0.2.1
+;; URL: http://github.org/dotemacs/ipcalc.el
+;; Keywords: networking
+
+;;; Commentary:
+;;
+;; Usage: evaluate (ipcalc "192.168.0.23/21")
+
+;;; This file is NOT part of GNU Emacs
+;;
+;; Copyright (c) 2012, Aleksandar Simic
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above
+;; copyright notice, this list of conditions and the following
+;; disclaimer in the documentation and/or other materials provided
+;; with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+;; OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Code
+
+(defconst cidr-default 32 "CIDR value")
+
+(defun int-to-bin-string (n &optional length)
+ ;; 08 Jun 1997 Jamie Zawinski <jwzNOSPAMnetscape.com> comp.emacs
+ "Convert integer N to bit string (LENGTH, default 8)."
+ (let* ((i 0)
+ (len (or length 8))
+ (s (make-string len ?0)))
+ (while (< i len)
+ (if (not (zerop (logand n (ash 1 i))))
+ (aset s (- len (1+ i)) ?1))
+ (setq i (1+ i))
+ )
+ s))
+
+(defun octets-as-binary (list-of-octets)
+ "return LST of octets as a single binary string"
+ (let ((binary ""))
+ (while list-of-octets
+ (setq binary
+ (concat binary
+ (int-to-bin-string
+ (string-to-int (car list-of-octets)))))
+ (setq list-of-octets (cdr list-of-octets)))
+ binary))
+
+(defun ip-to-octets (ip)
+ "split IP address and return the octets"
+ (let ((octets (split-string ip "\\.")))
+ (if (= 4 (length octets))
+ octets
+ (message "not correct IP format"))))
+
+(defun ones-and-pad (num)
+ "return 1's equal to NUM and pad the rest up to 32"
+ (unless (and (<= num cidr-default) (> num 0))
+ (error "wrong value provided"))
+ (concat (make-string num ?1)
+ (make-string (- cidr-default num) ?0)))
+
+(defun invert-binary (num)
+ "Invert 1s to 0s and vice versa
+
+ (credit: the simpler version below re-writen by pjb from #emacs
+ on freenode)"
+ (map 'string
+ (lambda (ch) (aref "10" (position ch "01")))
+ (remove-if-not (lambda (ch) (position ch "01")) num)))
+
+(defun network (ip cidr)
+ "Takes IP & CIDR and produces network"
+ (let ((cidr-as-int (string-to-int cidr)))
+ (concat
+ (substring (octets-as-binary
+ (ip-to-octets ip)) 0 cidr-as-int)
+ (make-string (- cidr-default cidr-as-int) ?0))))
+
+(defun host+1 (binary-ip)
+ "increment the given BINARY-IP by 1"
+ (let ((tmp binary-ip))
+ (aset tmp (- cidr-default 1) ?1)
+ tmp))
+
+(defun host-max (ip cidr)
+ (let ((count (string-to-int cidr))
+ (max (- cidr-default 1)))
+ (while (< count max)
+ (aset ip count ?1)
+ (setq count(incf count)))
+ ip))
+
+(defun hosts/net (num)
+ "Calculate Hosts/Net for the NUM given"
+ (- (expt 2 (- cidr-default num)) 2))
+
+(defmacro list-to-string (lst)
+ "convert LST to string"
+ `(mapconcat
+ '(lambda (val)
+ (identity (if (integerp val)
+ (int-to-string val)
+ val)))
+ ,lst ""))
+
+(defun insert-values (lst)
+ "insert given LST"
+ (insert
+ (list-to-string lst)))
+
+(defun bin-to-int (bin)
+ "Convert binary to integer"
+ (int-to-string (read (concat "#b" bin))))
+
+(defun binary-to-ip (binary)
+ "convert binary to IP address"
+ (let* (full-ip
+ (count 0)
+ (1st-octet (substring binary 0 8))
+ (2nd-octet (substring binary 8 16))
+ (3rd-octet (substring binary 16 24))
+ (4th-octet (substring binary 24 32))
+ (octets (mapcar
+ 'bin-to-int
+ `(,1st-octet ,2nd-octet ,3rd-octet ,4th-octet))))
+ (while (< count 3)
+ (setq full-ip (concat full-ip (nth count octets) "."))
+ (setq count (incf count)))
+ (concat full-ip (car (last octets)))))
+
+(defun ipcalc (ip/cidr)
+ "IP calculator"
+ (let* ((ip (car (split-string ip/cidr "/")))
+ (ip-in-binary (octets-as-binary (ip-to-octets ip)))
+ (cidr (car (cdr (split-string ip/cidr "/"))))
+ (cidr-int (string-to-int cidr))
+ (cidr-binary (ones-and-pad cidr-int))
+ (wildcard-binary (invert-binary (ones-and-pad cidr-int)))
+ (wildcard-ip (binary-to-ip wildcard-binary))
+ (netmask (binary-to-ip (invert-binary wildcard-binary)))
+ (net-binary (network ip cidr))
+ (net-ip (binary-to-ip net-binary))
+ (host-max-binary (host-max (network ip cidr) cidr))
+ (host-max-ip (binary-to-ip host-max-binary))
+ (host-min-binary (host+1 (network ip cidr)))
+ (host-min-ip (binary-to-ip host-min-binary))
+ (broadcast-binary (host+1 (host-max net-binary cidr)))
+ (broadcast-ip (binary-to-ip broadcast-binary))
+ (buffer "*ipcalc*"))
+ (if (get-buffer buffer)
+ (kill-buffer buffer))
+ (pop-to-buffer buffer)
+ (insert
+ (format "Address:%15s%41s\n" ip ip-in-binary)
+ (format "Netmask:%16s = %2s %34s\n" netmask cidr cidr-binary)
+ (format "Wildcard:%11s%44s\n" wildcard-ip wildcard-binary)
+ (format "=>\nNetwork:%14s%42s\n" net-ip (network ip cidr))
+ (format "HostMin:%14s%42s\n" host-min-ip host-min-binary)
+ (format "HostMax:%16s%40s\n" host-max-ip host-max-binary)
+ (format "Broadcast:%14s%40s\n" broadcast-ip broadcast-binary)
+ (format "Hosts/Net: %d\n" (hosts/net cidr-int)))))
+
+(provide 'ipcalc)
+
+;;; ipcalc.el ends here
--- /dev/null
+; malyon.el --- mode to execute z code files version 3, 5, 8
+
+;; Maintainer: Peter Ilberg <peter.ilbergNOSPAMgmail.com>
+;; (I am unable to continue supporting malyon.el. Please send me an
+;; email if you are interested in taking over the project. Thanks.)
+
+;; Copyright (C) 1999-2011 Peter Ilberg
+
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;;; Credits:
+
+;; The author would like to thank the following people for reporting
+;; bugs, testing, suggesting and/or contributing improvements:
+;; Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko
+
+;;; Commentary:
+
+;; This package provides a basic interpreter for version 3, 5, 8 z code
+;; story files as generated by Inform (C) Graham Nelson and Infocom.
+
+;; If you encounter a bug please send a report to Peter Ilberg at
+;; peter.ilbergNOSPAMgmail.com. Thank you!
+
+;; To play a story file simple type M-x malyon and enter the path to the
+;; story file. If anything goes wrong and you want to manually clean
+;; up type M-x malyon-quit. In addition, you can switch back to a game in
+;; progress by typing M-x malyon-restore.
+
+;; A note on the format of saved game states:
+
+;; As of version 1.0, Malyon supports the quetzal file format for saved
+;; games. Support for this format required changes to several internal
+;; data structures (stack frames and catch-throw) that are incompatible
+;; with the old implementation. Unfortunately, the old file format for
+;; saved games cannot be converted into quetzal.
+
+;; For backwards compatibility, however, Malyon still supports the old
+;; file format. And you can continue to play your old game states.
+
+;; Because of the incompatibility of the two file formats, Malyon now
+;; runs, as follows, in either of two modes: quetzal and compatibility.
+
+;; - in quetzal mode, game states are saved in quetzal format
+;; - in compatibility mode, games states are saved in the old format
+;; - loading a game state in quetzal format switches to quetzal mode
+;; - loading an old game state switches to compatibility mode
+;; - quetzal mode is the default setting
+
+;; In other words, Malyon will only use the old file format if you've
+;; restored a game state saved in the old file format.
+
+;; Enjoy!
+
+;;; Code:
+
+;; global variables - moved here to appease the byte-code compiler
+
+;; story file information
+
+(defvar malyon-story-file-name nil
+ "The name of the story file being executed.")
+
+(defvar malyon-story-file nil
+ "The story file which is currently being run.")
+
+(defvar malyon-story-version nil
+ "The story file version.")
+
+(defvar malyon-supported-versions '(3 5 8)
+ "A list of supported story file versions.")
+
+;; status and transcript buffers
+
+(defvar malyon-transcript-buffer nil
+ "The main transcript buffer of the story file execution.")
+
+(defvar malyon-transcript-buffer-buffered nil
+ "Is output in the transcript buffer buffered?")
+
+(defvar malyon-status-buffer nil
+ "The status bar buffer of the story file execution.")
+
+(defvar malyon-status-buffer-lines nil
+ "The number of lines in the status bar buffer.")
+
+(defvar malyon-status-buffer-delayed-split nil
+ "If the number of lines in the status buffer is reduced,
+the window configuration is not changed immediately. It
+is changed after the next turn (read or read_char).")
+
+(defvar malyon-status-buffer-point nil
+ "The point location in the status bar buffer.")
+
+(defvar malyon-max-column 72
+ "Maximum column for text display.")
+
+;; window management
+
+(defvar malyon-window-configuration nil
+ "The current window configuration of the malyon interpreter.")
+
+(defvar malyon-current-window nil
+ "The currently active window for text output.")
+
+;; z machine registers
+
+(defvar malyon-stack nil
+ "The stack of the z machine.")
+
+(defvar malyon-stack-pointer nil
+ "The stack pointer of the z machine.")
+
+(defvar malyon-frame-pointer nil
+ "The frame pointer of the z machine.")
+
+(defvar malyon-instruction-pointer nil
+ "The instruction pointer of the z machine.")
+
+;; game file related global variables
+
+(defvar malyon-score-game nil
+ "A flag indicating whether this story uses score or time.")
+
+(defvar malyon-packed-multiplier nil
+ "The amount by which packed addresses are multiplied to get byte
+addresses.")
+
+(defvar malyon-global-variables nil
+ "A pointer to the global variable section in the story file.")
+
+(defvar malyon-abbreviations nil
+ "A pointer to the abbreviations in the story file.")
+
+(defvar malyon-alphabet nil
+ "The z machine's text alphabet.")
+
+(defvar malyon-whitespace nil
+ "A string of whitespace characters recognized by the interpreter.")
+
+;; object tables
+
+(defvar malyon-object-table nil
+ "A pointer to the object table in the story file.")
+
+(defvar malyon-object-table-entry-size nil
+ "The size of one entry in the object table.")
+
+(defvar malyon-object-properties nil
+ "The number of properties per object minus one.")
+
+(defvar malyon-object-property-offset nil
+ "The byte offset of the properties table in the object.")
+
+;; dictionaries
+
+(defvar malyon-dictionary nil
+ "A pointer to the dictionary of the story file.")
+
+(defvar malyon-dictionary-entry-length nil
+ "The length of a dictionary entry.")
+
+(defvar malyon-dictionary-num-entries nil
+ "The number of dictionary entries.")
+
+(defvar malyon-dictionary-entries nil
+ "A pointer to the first dictionary entry.")
+
+(defvar malyon-dictionary-word-length nil
+ "The length of a dictionary word.")
+
+;; game state information
+
+(defvar malyon-game-state-restart nil
+ "The machine state for implementing restart.")
+
+(defvar malyon-game-state-undo nil
+ "The machine state for implementing undo.")
+
+(defvar malyon-game-state-quetzal t
+ "Store game state information for quetzal.")
+
+;; various
+
+(defvar malyon-current-face nil
+ "The current face in which to display text.")
+
+(defvar malyon-last-cursor-position-after-input nil
+ "The last cursor position after reading input from the keyboard.")
+
+;; interactive functions
+
+(defun malyon (file-name)
+ "Major mode for playing z3/5/8 story files.
+This mode allows execution of version 3, 5, 8 z code story files."
+ (interactive "fStory file name: ")
+ (if malyon-story-file
+ (message "You are already playing a game.")
+ (if (not (string-match ".*\.z[358]$" file-name))
+ (message "%s is not a version 3, 5, or 8 story file." file-name)
+ (condition-case nil
+ (malyon-load-story-file file-name)
+ (error
+ (malyon-fatal-error "loading of story file failed.")))
+ (setq malyon-story-version (aref malyon-story-file 0))
+ (cond ((memq malyon-story-version malyon-supported-versions)
+ (condition-case nil
+ (malyon-initialize)
+ (error
+ (malyon-fatal-error "initialization of interpreter failed.")))
+ (malyon-interpreter))
+ (t
+ (message "%s is not a version 3, 5, or 8 story file." file-name)
+ (malyon-cleanup))))))
+
+(defun malyon-restore ()
+ "Restore the save window configuration for the interpreter."
+ (interactive)
+ (condition-case nil
+ (progn
+ (malyon-restore-window-configuration)
+ (malyon-adjust-transcript))
+ (error
+ (malyon-fatal-error "restoring window configuration failed."))))
+
+(defun malyon-quit ()
+ "Exit the malyon interpreter."
+ (interactive)
+ (if malyon-story-file
+ (progn
+ (malyon-restore)
+ (if (malyon-yes-or-no-p-minibuf "Do you really want to quit? ")
+ (malyon-cleanup)))))
+
+(defun malyon-mode ()
+ "This mode provides a basic interpreter for version 3, 5, 8 z code
+story files as generated by Inform (C) Graham Nelson and Infocom.
+
+Note that this package is by no means complete and bug free.
+If you encounter a bug please send a report to Peter Ilberg at
+peter.ilbergNOSPAMnatinst.com. Thank you!
+
+To play a story file simple type M-x malyon and enter the path to the
+story file. If anything goes wrong and you want to manually clean
+up type M-x malyon-quit. In addition, you can switch back to a game in
+progress by typing M-x malyon-restore.
+
+The author would like to thank the following people for reporting
+bugs, testing, suggesting and/or contributing improvements:
+ Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko"
+ (message "Use M-x malyon if you want to play a zcode game."))
+
+;; compatibility functions for GNU emacs
+
+(if (fboundp 'cadr)
+ (defalias 'malyon-cadr 'cadr)
+ (defun malyon-cadr (list)
+ "Take the cadr of the list."
+ (car (cdr list))))
+
+(if (fboundp 'caddr)
+ (defalias 'malyon-caddr 'caddr)
+ (defun malyon-caddr (list)
+ "Take the caddr of the list."
+ (car (cdr (cdr list)))))
+
+(if (fboundp 'cdddr)
+ (defalias 'malyon-cdddr 'cdddr)
+ (defun malyon-cdddr (list)
+ "Take the cdddr of the list."
+ (cdr (cdr (cdr list)))))
+
+(if (fboundp 'char-before)
+ (defalias 'malyon-char-before 'char-before)
+ (defun malyon-char-before ()
+ "Return the character before the point."
+ (char-after (- (point) 1))))
+
+(if (fboundp 'char-to-int)
+ (defalias 'malyon-char-to-int 'char-to-int)
+ (defun malyon-char-to-int (c)
+ "Convert a character into an integer."
+ c))
+
+(if (fboundp 'characterp)
+ (defalias 'malyon-characterp 'characterp)
+ (defun malyon-characterp (x)
+ "Test for a character."
+ (and (numberp x) (<= 0 x) (< x 256))))
+
+(defun malyon-disable-multibyte ()
+ "Disable multibyte support in the current buffer."
+ (condition-case nil (set-buffer-multibyte nil) (error)))
+
+(defun malyon-erase-buffer (&optional buffer)
+ "Erase the given buffer."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (and buffer (eq buffer malyon-transcript-buffer))
+ (malyon-begin-section)
+ (erase-buffer))))
+
+(if (fboundp 'int-to-char)
+ (defalias 'malyon-int-to-char 'int-to-char)
+ (defun malyon-int-to-char (i)
+ "Convert an integer into a character."
+ i))
+
+(if (fboundp 'mapc)
+ (defalias 'malyon-mapc 'mapc)
+ (defun malyon-mapc (function list)
+ "Apply fun to every element of args ignoring the results."
+ (if (null list)
+ '()
+ (funcall function (car list))
+ (malyon-mapc function (cdr list)))))
+
+(if (fboundp 'mapcan)
+ (defalias 'malyon-mapcan 'mapcan)
+ (defun malyon-mapcan (function list)
+ "Apply fun to every element of args nconc'ing the result."
+ (if (null list)
+ '()
+ (nconc (funcall function (car list))
+ (malyon-mapcan function (cdr list))))))
+
+; Do not use the built-in conversion via 'multibyte-char-to-unibyte.
+(defun malyon-multibyte-char-to-unibyte (char)
+ "Convert a multibyte character to unibyte."
+ char)
+
+(defun malyon-point-max (&optional buffer)
+ "Get the point-max of the given buffer."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (point-max)))
+
+(if (fboundp 'redisplay-frame)
+ (defalias 'malyon-redisplay-frame 'redisplay-frame)
+ (defun malyon-redisplay-frame (frame &rest ignore)
+ "Redisplay the given frame."))
+
+(if (fboundp 'remove)
+ (defalias 'malyon-remove 'remove)
+ (defun malyon-remove (element list)
+ "Remove the element from the list."
+ (cond ((null list)
+ '())
+ ((eq element (car list))
+ (malyon-remove element (cdr list)))
+ ((equal element (car list))
+ (malyon-remove element (cdr list)))
+ (t
+ (cons (car list)
+ (malyon-remove element (cdr list)))))))
+
+(if (fboundp 'set-keymap-name)
+ (defalias 'malyon-set-keymap-name 'set-keymap-name)
+ (defun malyon-set-keymap-name (keymap name)
+ "Set the name of the keymap."))
+
+(if (fboundp 'string-to-list)
+ (defalias 'malyon-string-to-list 'string-to-list)
+ (defun malyon-string-to-list (s)
+ "Convert a string into a list of characters."
+ (let ((i (- (length s) 1)) (l '()))
+ (while (<= 0 i)
+ (setq l (cons (aref s i) l)
+ i (- i 1)))
+ l)))
+
+(if (fboundp 'string-to-vector)
+ (defalias 'malyon-string-to-vector 'string-to-vector)
+ (defun malyon-string-to-vector (s)
+ "Convert a string into a vector of characters."
+ (let* ((i 0) (l (length s)) (v (make-vector l 0)))
+ (while (< i l)
+ (aset v i (aref s i))
+ (setq i (+ 1 i)))
+ v)))
+
+; Do not use the built-in conversion via 'unibyte-char-to-multibyte.
+(defun malyon-unibyte-char-to-multibyte (char)
+ "Convert a unibyte character to multibyte."
+ char)
+
+(defun malyon-vector-to-list (v begin end)
+ "Return a list of elements in v in the range [begin, end)."
+ (let ((result '()))
+ (while (< begin end)
+ (setq result (cons (aref v begin) result))
+ (setq begin (+ 1 begin)))
+ (reverse result)))
+
+(if (fboundp 'window-displayed-height)
+ (defalias 'malyon-window-displayed-height 'window-displayed-height)
+ (defun malyon-window-displayed-height (&optional window)
+ "Get the height of the window's displayed region."
+ (- (window-height) 1)))
+
+(if (fboundp 'yes-or-no-p-minibuf)
+ (defalias 'malyon-yes-or-no-p-minibuf 'yes-or-no-p-minibuf)
+ (defun malyon-yes-or-no-p-minibuf (prompt)
+ "Ask a yes or no question."
+ (yes-or-no-p prompt)))
+
+;; global variables for the malyon mode
+
+(defvar malyon-syntax-table nil
+ "Syntax table used while in malyon mode (same as in text-mode).")
+
+(if malyon-syntax-table
+ '()
+ (setq malyon-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\" ". " malyon-syntax-table)
+ (modify-syntax-entry ?\\ ". " malyon-syntax-table)
+ (modify-syntax-entry ?' "w " malyon-syntax-table))
+
+(defvar malyon-keymap-read nil
+ "Keymap for malyon mode for reading input into a buffer.")
+
+(defvar malyon-history-saved-up nil
+ "The saved binding for the up arrow key.")
+
+(defvar malyon-history-saved-down nil
+ "The saved binding for the down arrow key.")
+
+(if malyon-keymap-read
+ '()
+ (setq malyon-keymap-read (make-sparse-keymap))
+ (malyon-set-keymap-name malyon-keymap-read 'malyon-keymap-read)
+ (setq malyon-history-saved-up (global-key-binding [up]))
+ (setq malyon-history-saved-down (global-key-binding [down]))
+ (define-key malyon-keymap-read "\r" 'malyon-end-input)
+ (define-key malyon-keymap-read [up] 'malyon-history-previous-char)
+ (define-key malyon-keymap-read [down] 'malyon-history-next-char)
+ (define-key malyon-keymap-read "\M-p" 'malyon-history-previous-char)
+ (define-key malyon-keymap-read "\M-n" 'malyon-history-next-char)
+ (define-key malyon-keymap-read "\C-a" 'malyon-beginning-of-line)
+ (define-key malyon-keymap-read "\C-w" 'malyon-kill-region)
+ (define-key malyon-keymap-read "\C-k" 'malyon-kill-line)
+ (define-key malyon-keymap-read "\M-d" 'malyon-kill-word)
+ (define-key malyon-keymap-read "\C-y" 'malyon-yank)
+ (define-key malyon-keymap-read "\M-y" 'malyon-yank-pop)
+ (define-key malyon-keymap-read "\C-d" 'malyon-delete-char)
+ (define-key malyon-keymap-read "\d" 'malyon-backward-delete-char)
+ (define-key malyon-keymap-read [del] 'malyon-delete-char)
+ (define-key malyon-keymap-read [backspace] 'malyon-backward-delete-char)
+ (substitute-key-definition (lookup-key (current-global-map) "a")
+ 'malyon-self-insert-command
+ malyon-keymap-read (current-global-map)))
+
+(defvar malyon-keymap-readchar nil
+ "Keymap for malyon mode for waiting for input.")
+
+(if malyon-keymap-readchar
+ '()
+ (setq malyon-keymap-readchar (make-sparse-keymap))
+ (malyon-set-keymap-name malyon-keymap-readchar 'malyon-keymap-readchar)
+ (define-key malyon-keymap-readchar "\r" 'malyon-wait-char)
+ (substitute-key-definition (lookup-key (current-global-map) "a")
+ 'malyon-wait-char
+ malyon-keymap-readchar (current-global-map)))
+
+(defvar malyon-keymap-more nil
+ "Keymap for malyon mode for browsing through text.")
+
+(if malyon-keymap-more
+ '()
+ (setq malyon-keymap-more (make-sparse-keymap))
+ (malyon-set-keymap-name malyon-keymap-more 'malyon-keymap-more)
+ (define-key malyon-keymap-more "\r" 'malyon-more-char)
+ (substitute-key-definition (lookup-key (current-global-map) "a")
+ 'malyon-more-char
+ malyon-keymap-more (current-global-map)))
+
+(defvar malyon-keymap-more-status nil
+ "Keymap for malyon mode for browsing through the status buffer.")
+
+(if malyon-keymap-more-status
+ '()
+ (setq malyon-keymap-more-status (make-sparse-keymap))
+ (malyon-set-keymap-name malyon-keymap-more-status 'malyon-keymap-more-status)
+ (define-key malyon-keymap-more-status "\r" 'malyon-more-char-status)
+ (substitute-key-definition (lookup-key (current-global-map) "a")
+ 'malyon-more-char-status
+ malyon-keymap-more-status (current-global-map)))
+
+(defvar malyon-faces nil
+ "An association list of text faces used by the malyon mode.")
+
+(defun malyon-initialize-faces ()
+ (copy-face 'default 'malyon-face-plain)
+ (copy-face 'bold 'malyon-face-reverse)
+ (copy-face 'bold 'malyon-face-bold)
+ (copy-face 'italic 'malyon-face-italic)
+ (copy-face 'default 'malyon-face-error)
+ (set-face-foreground 'malyon-face-error "red")
+ (setq malyon-faces '((0 . malyon-face-plain)
+ (1 . malyon-face-reverse)
+ (2 . malyon-face-bold)
+ (4 . malyon-face-italic)
+ (8 . malyon-face-plain))))
+
+(defvar malyon-print-separator nil
+ "A flag indicating whether to print the * * * separator.")
+
+(defun malyon-begin-section ()
+ "Print a section divider and begin a new section."
+ (if malyon-print-separator
+ (progn
+ (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n ?* ? ?* ? ?*))
+ (center-line)
+ (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n))
+ (setq malyon-print-separator nil)))
+ (narrow-to-region (point-max) (point-max)))
+
+(if malyon-whitespace
+ '()
+ (setq malyon-whitespace (list (malyon-char-to-int ? )
+ (malyon-char-to-int ?\t)
+ (malyon-char-to-int ?\n)
+ (malyon-char-to-int ?\r))))
+
+;; memory utilities
+
+(defsubst malyon-read-byte (address)
+ "Read a byte at address in the story file."
+ (if (<= 0 address)
+ (aref malyon-story-file address)
+ (aref malyon-story-file (+ 65536 address))))
+
+(defsubst malyon-store-byte (address value)
+ "Store a byte at address in the story file."
+ (if (<= 0 address)
+ (aset malyon-story-file address (logand 255 value))
+ (aset malyon-story-file (+ 65536 address) (logand 255 value))))
+
+(defsubst malyon-read-word (address)
+ "Read a word at address in the story file."
+ (if (<= 0 address)
+ (logior (lsh (aref malyon-story-file address) 8)
+ (aref malyon-story-file (+ 1 address)))
+ (logior (lsh (aref malyon-story-file (+ 65536 address)) 8)
+ (aref malyon-story-file (+ 65537 address)))))
+
+(defsubst malyon-store-word (address value)
+ "Store a word at address in the story file."
+ (if (<= 0 address)
+ (progn
+ (aset malyon-story-file address (logand 255 (lsh value -8)))
+ (aset malyon-story-file (+ 1 address) (logand 255 value)))
+ (aset malyon-story-file (+ 65536 address) (logand 255 (lsh value -8)))
+ (aset malyon-story-file (+ 65537 address) (logand 255 value))))
+
+(defsubst malyon-read-code-byte ()
+ "Read the next byte at the program counter location."
+ (setq malyon-instruction-pointer (+ malyon-instruction-pointer 1))
+ (malyon-read-byte (- malyon-instruction-pointer 1)))
+
+(defsubst malyon-read-code-word ()
+ "Read the next word at the program counter location."
+ (setq malyon-instruction-pointer (+ malyon-instruction-pointer 2))
+ (malyon-read-word (- malyon-instruction-pointer 2)))
+
+(defsubst malyon-pop-stack ()
+ "Pop a value off the stack."
+ (if (> 0 malyon-stack-pointer)
+ (malyon-fatal-error "stack underflow."))
+ (setq malyon-stack-pointer (- malyon-stack-pointer 1))
+ (aref malyon-stack (+ malyon-stack-pointer 1)))
+
+(defsubst malyon-read-local-variable (variable)
+ "Read a local variable."
+ (aref malyon-stack (+ variable malyon-frame-pointer)))
+
+(defsubst malyon-read-global-variable (variable)
+ "Read a global variable."
+ (malyon-read-word (+ malyon-global-variables (* 2 variable))))
+
+(defsubst malyon-read-variable (variable)
+ "Read a variable."
+ (cond ((= variable 0) (malyon-pop-stack))
+ ((< variable 16) (malyon-read-local-variable variable))
+ (t (malyon-read-global-variable (- variable 16)))))
+
+(defsubst malyon-push-stack (value)
+ "Push a value onto the stack."
+ (setq malyon-stack-pointer (+ malyon-stack-pointer 1))
+ (aset malyon-stack malyon-stack-pointer value))
+
+(defsubst malyon-store-local-variable (variable value)
+ "Store a value in a local variable."
+ (aset malyon-stack (+ variable malyon-frame-pointer) value))
+
+(defsubst malyon-store-global-variable (variable value)
+ "Store a value in a global variable."
+ (malyon-store-word (+ malyon-global-variables (* 2 variable)) value))
+
+(defsubst malyon-store-variable (var value)
+ "Store the value in a variable."
+ (setq value (logand 65535 value))
+ (cond ((= var 0) (malyon-push-stack value))
+ ((< var 16) (malyon-store-local-variable var value))
+ (t (malyon-store-global-variable (- var 16) value))))
+
+;; list of opcodes
+
+(defvar malyon-opcodes
+ [malyon-opcode-nop
+ malyon-opcode-je malyon-opcode-jl
+ malyon-opcode-jg malyon-opcode-dec-chk
+ malyon-opcode-inc-chk malyon-opcode-jin
+ malyon-opcode-test malyon-opcode-or
+ malyon-opcode-and malyon-opcode-test-attr
+ malyon-opcode-set-attr malyon-opcode-clear-attr
+ malyon-opcode-store malyon-opcode-insert-obj
+ malyon-opcode-loadw malyon-opcode-loadb
+ malyon-opcode-get-prop malyon-opcode-get-prop-addr
+ malyon-opcode-get-next-prop malyon-opcode-add
+ malyon-opcode-sub malyon-opcode-mul
+ malyon-opcode-div malyon-opcode-mod
+ malyon-opcode-calls malyon-opcode-calln
+ malyon-opcode-set-color malyon-opcode-throw
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-je malyon-opcode-jl
+ malyon-opcode-jg malyon-opcode-dec-chk
+ malyon-opcode-inc-chk malyon-opcode-jin
+ malyon-opcode-test malyon-opcode-or
+ malyon-opcode-and malyon-opcode-test-attr
+ malyon-opcode-set-attr malyon-opcode-clear-attr
+ malyon-opcode-store malyon-opcode-insert-obj
+ malyon-opcode-loadw malyon-opcode-loadb
+ malyon-opcode-get-prop malyon-opcode-get-prop-addr
+ malyon-opcode-get-next-prop malyon-opcode-add
+ malyon-opcode-sub malyon-opcode-mul
+ malyon-opcode-div malyon-opcode-mod
+ malyon-opcode-calls malyon-opcode-calln
+ malyon-opcode-set-color malyon-opcode-throw
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-je malyon-opcode-jl
+ malyon-opcode-jg malyon-opcode-dec-chk
+ malyon-opcode-inc-chk malyon-opcode-jin
+ malyon-opcode-test malyon-opcode-or
+ malyon-opcode-and malyon-opcode-test-attr
+ malyon-opcode-set-attr malyon-opcode-clear-attr
+ malyon-opcode-store malyon-opcode-insert-obj
+ malyon-opcode-loadw malyon-opcode-loadb
+ malyon-opcode-get-prop malyon-opcode-get-prop-addr
+ malyon-opcode-get-next-prop malyon-opcode-add
+ malyon-opcode-sub malyon-opcode-mul
+ malyon-opcode-div malyon-opcode-mod
+ malyon-opcode-calls malyon-opcode-calln
+ malyon-opcode-set-color malyon-opcode-throw
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-je malyon-opcode-jl
+ malyon-opcode-jg malyon-opcode-dec-chk
+ malyon-opcode-inc-chk malyon-opcode-jin
+ malyon-opcode-test malyon-opcode-or
+ malyon-opcode-and malyon-opcode-test-attr
+ malyon-opcode-set-attr malyon-opcode-clear-attr
+ malyon-opcode-store malyon-opcode-insert-obj
+ malyon-opcode-loadw malyon-opcode-loadb
+ malyon-opcode-get-prop malyon-opcode-get-prop-addr
+ malyon-opcode-get-next-prop malyon-opcode-add
+ malyon-opcode-sub malyon-opcode-mul
+ malyon-opcode-div malyon-opcode-mod
+ malyon-opcode-calls malyon-opcode-calln
+ malyon-opcode-set-color malyon-opcode-throw
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop malyon-opcode-jz
+ malyon-opcode-get-sibling malyon-opcode-get-child
+ malyon-opcode-get-parent malyon-opcode-get-prop-len
+ malyon-opcode-inc malyon-opcode-dec
+ malyon-opcode-print-addr malyon-opcode-calls
+ malyon-opcode-remove-obj malyon-opcode-print-obj
+ malyon-opcode-ret malyon-opcode-jump
+ malyon-opcode-print-paddr malyon-opcode-load
+ malyon-opcode-calln malyon-opcode-jz
+ malyon-opcode-get-sibling malyon-opcode-get-child
+ malyon-opcode-get-parent malyon-opcode-get-prop-len
+ malyon-opcode-inc malyon-opcode-dec
+ malyon-opcode-print-addr malyon-opcode-calls
+ malyon-opcode-remove-obj malyon-opcode-print-obj
+ malyon-opcode-ret malyon-opcode-jump
+ malyon-opcode-print-paddr malyon-opcode-load
+ malyon-opcode-calln malyon-opcode-jz
+ malyon-opcode-get-sibling malyon-opcode-get-child
+ malyon-opcode-get-parent malyon-opcode-get-prop-len
+ malyon-opcode-inc malyon-opcode-dec
+ malyon-opcode-print-addr malyon-opcode-calls
+ malyon-opcode-remove-obj malyon-opcode-print-obj
+ malyon-opcode-ret malyon-opcode-jump
+ malyon-opcode-print-paddr malyon-opcode-load
+ malyon-opcode-calln malyon-opcode-rtrue
+ malyon-opcode-rfalse malyon-opcode-print
+ malyon-opcode-print-ret malyon-opcode-nop
+ malyon-opcode-illegal malyon-opcode-illegal
+ malyon-opcode-restart malyon-opcode-ret-popped
+ malyon-opcode-catch malyon-opcode-quit
+ malyon-opcode-new-line malyon-opcode-illegal
+ malyon-opcode-verify malyon-opcode-illegal
+ malyon-opcode-piracy malyon-opcode-nop
+ malyon-opcode-je malyon-opcode-jl
+ malyon-opcode-jg malyon-opcode-dec-chk
+ malyon-opcode-inc-chk malyon-opcode-jin
+ malyon-opcode-test malyon-opcode-or
+ malyon-opcode-and malyon-opcode-test-attr
+ malyon-opcode-set-attr malyon-opcode-clear-attr
+ malyon-opcode-store malyon-opcode-insert-obj
+ malyon-opcode-loadw malyon-opcode-loadb
+ malyon-opcode-get-prop malyon-opcode-get-prop-addr
+ malyon-opcode-get-next-prop malyon-opcode-add
+ malyon-opcode-sub malyon-opcode-mul
+ malyon-opcode-div malyon-opcode-mod
+ malyon-opcode-calls malyon-opcode-calln
+ malyon-opcode-set-color malyon-opcode-throw
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop malyon-opcode-calls
+ malyon-opcode-storew malyon-opcode-storeb
+ malyon-opcode-put-prop malyon-opcode-aread
+ malyon-opcode-print-char malyon-opcode-print-num
+ malyon-opcode-random malyon-opcode-push
+ malyon-opcode-pull malyon-opcode-split-window
+ malyon-opcode-set-window malyon-opcode-calls
+ malyon-opcode-erase-window malyon-opcode-erase-line
+ malyon-opcode-set-cursor malyon-opcode-get-cursor
+ malyon-opcode-set-text-style malyon-opcode-buffer-mode
+ malyon-opcode-output-stream malyon-opcode-input-stream
+ malyon-opcode-nop malyon-opcode-read-char
+ malyon-opcode-scan-table malyon-opcode-not
+ malyon-opcode-calln malyon-opcode-calln
+ malyon-opcode-tokenise malyon-opcode-encode-text
+ malyon-opcode-copy-table malyon-opcode-print-table
+ malyon-opcode-check-arg-count malyon-opcode-save
+ malyon-opcode-restore malyon-opcode-log-shift
+ malyon-opcode-art-shift malyon-opcode-set-font
+ malyon-opcode-illegal malyon-opcode-illegal
+ malyon-opcode-illegal malyon-opcode-illegal
+ malyon-opcode-save-undo malyon-opcode-restore-undo
+ malyon-opcode-print-unicode malyon-opcode-check-unicode
+ malyon-opcode-nop malyon-opcode-nop
+ malyon-opcode-nop]
+ "A vector of all known legal z code opcodes.")
+
+;; initialization
+
+(defun malyon-load-story-file (file-name)
+ "Load a z code story file into an internal vector."
+ (save-excursion
+ (set-buffer (create-file-buffer file-name))
+ (malyon-disable-multibyte)
+ (malyon-erase-buffer)
+ (let ((coding-system-for-read 'binary))
+ (insert-file-contents file-name))
+ (setq malyon-story-file-name file-name)
+ (setq malyon-story-file (buffer-substring-no-properties (point-min)
+ (point-max)))
+ (setq malyon-story-file (malyon-string-to-vector malyon-story-file))
+ (if (not (eq ?\^A 1))
+ (let ((i 0))
+ (while (< i (length malyon-story-file))
+ (aset malyon-story-file
+ i
+ (malyon-char-to-int (aref malyon-story-file i)))
+ (setq i (+ 1 i)))))
+ (kill-buffer nil)))
+
+(defun malyon-initialize ()
+ "Initialize the z code interpreter."
+; (malyon-trace-file)
+ (setq malyon-game-state-quetzal t)
+ (malyon-initialize-faces)
+ (malyon-initialize-status)
+ (malyon-initialize-transcript)
+ (malyon-initialize-windows)
+ (malyon-initialize-story-header)
+ (malyon-initialize-registers)
+ (malyon-initialize-opcodes)
+ (malyon-history-clear)
+ (setq malyon-game-state-restart (malyon-current-game-state))
+ (malyon-print-header))
+
+(defun malyon-initialize-status ()
+ "Initialize the status buffer."
+ (setq malyon-status-buffer (get-buffer-create "Malyon Status"))
+ (switch-to-buffer malyon-status-buffer)
+ (malyon-erase-buffer)
+ (kill-all-local-variables)
+ (setq malyon-status-buffer-point (point))
+ (setq malyon-status-buffer-lines 0)
+ (setq malyon-status-buffer-delayed-split nil)
+ (use-local-map malyon-keymap-read)
+ (set-syntax-table malyon-syntax-table)
+ (setq mode-name "Malyon")
+ (setq major-mode 'malyon-mode)
+ (run-hooks 'malyon-mode-hook))
+
+(defun malyon-initialize-transcript ()
+ "Initialize the transcript buffer."
+ (setq malyon-transcript-buffer (get-buffer-create "Malyon Transcript"))
+ (switch-to-buffer malyon-transcript-buffer)
+ (malyon-erase-buffer)
+ (kill-all-local-variables)
+ (setq malyon-last-cursor-position-after-input
+ (malyon-point-max malyon-transcript-buffer))
+ (use-local-map malyon-keymap-read)
+ (set-syntax-table malyon-syntax-table)
+ (setq fill-column malyon-max-column)
+ (auto-fill-mode 1)
+ (setq mode-name "Malyon")
+ (setq major-mode 'malyon-mode)
+ (run-hooks 'malyon-mode-hook))
+
+(defun malyon-initialize-windows ()
+ "Initialize the window configuration for the z machine."
+ (setq window-min-height 3)
+ (setq malyon-transcript-buffer-buffered t)
+ (malyon-set-window-configuration 0)
+ (malyon-opcode-set-window 0))
+
+(defun malyon-initialize-story-header ()
+ "Initializes the header section of the story file."
+ (malyon-store-byte 1
+ (if (>= malyon-story-version 5)
+ 28
+ (logior 48 (malyon-read-byte 1))))
+ (malyon-store-byte 16 (logand 440 (malyon-read-byte 16)))
+ (malyon-store-byte 30 1)
+ (malyon-store-byte 31 65)
+ (malyon-store-byte 32 255)
+ (malyon-store-byte 33 (- malyon-max-column 1))
+ (malyon-store-word 34 (- malyon-max-column 1))
+ (malyon-store-word 36 255)
+ (malyon-store-word 38 1)
+ (malyon-store-word 39 1)
+ (malyon-store-byte 44 0)
+ (malyon-store-byte 45 0)
+ (malyon-store-byte 50 1)
+ (malyon-store-byte 51 0))
+
+(defun malyon-initialize-registers ()
+ "Initialize the interpreter's internal registers."
+ (setq malyon-stack (make-vector 1024 0))
+ (setq malyon-stack-pointer -1)
+ (malyon-push-initial-frame)
+ (setq malyon-frame-pointer malyon-stack-pointer)
+ (setq malyon-instruction-pointer (malyon-read-word 6))
+ (setq malyon-global-variables (malyon-read-word 12))
+ (setq malyon-object-table (malyon-read-word 10))
+ (cond ((< malyon-story-version 5)
+ (setq malyon-object-table-entry-size 9)
+ (setq malyon-object-properties 31)
+ (setq malyon-object-property-offset 7))
+ (t
+ (setq malyon-object-table-entry-size 14)
+ (setq malyon-object-properties 63)
+ (setq malyon-object-property-offset 12)))
+ (setq malyon-abbreviations (malyon-read-word 24))
+ (if (< malyon-story-version 5)
+ (setq malyon-score-game (zerop (logand 2 (malyon-read-byte 1)))))
+ (setq malyon-packed-multiplier
+ (malyon-cadr (assq malyon-story-version '((3 2) (5 4) (8 8)))))
+ (if (or (< malyon-story-version 5) (zerop (malyon-read-word 52)))
+ (setq malyon-alphabet (concat "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ " \n0123456789.,!?_#'\"/\\-:()"))
+ (setq malyon-alphabet (make-string 78 ? ))
+ (let ((i 0))
+ (while (< i 78)
+ (aset malyon-alphabet i
+ (malyon-read-byte (+ i (malyon-read-word 52))))
+ (setq i (+ 1 i)))))
+ (malyon-initialize-unicode-table)
+ (setq malyon-dictionary (malyon-read-word 8))
+ (setq malyon-dictionary-entry-length
+ (malyon-read-byte
+ (+ 1 malyon-dictionary (malyon-read-byte malyon-dictionary))))
+ (setq malyon-dictionary-num-entries
+ (malyon-read-word
+ (+ 2 malyon-dictionary (malyon-read-byte malyon-dictionary))))
+ (setq malyon-dictionary-entries
+ (+ 4 malyon-dictionary (malyon-read-byte malyon-dictionary)))
+ (setq malyon-dictionary-word-length (if (< malyon-story-version 5) 3 5))
+ (setq malyon-current-face 'malyon-face-plain)
+ (setq malyon-print-separator nil)
+ (malyon-initialize-output-streams))
+
+(defun malyon-initialize-opcodes ()
+ "Initialize the opcode table used by the story file."
+ (cond ((< malyon-story-version 5)
+ (aset malyon-opcodes 143 'malyon-opcode-not)
+ (aset malyon-opcodes 181 'malyon-opcode-save)
+ (aset malyon-opcodes 182 'malyon-opcode-restore)
+ (aset malyon-opcodes 185 'malyon-opcode-pop)
+ (aset malyon-opcodes 188 'malyon-opcode-show-status))
+ (t
+ (aset malyon-opcodes 143 'malyon-opcode-calln)
+ (aset malyon-opcodes 181 'malyon-opcode-illegal)
+ (aset malyon-opcodes 182 'malyon-opcode-illegal)
+ (aset malyon-opcodes 185 'malyon-opcode-catch)
+ (aset malyon-opcodes 188 'malyon-opcode-illegal))))
+
+(defun malyon-print-header ()
+ "Print malyon mode header information."
+ (malyon-opcode-set-text-style 2)
+ (malyon-print "Malyon V 1.0.3")
+ (malyon-opcode-set-text-style 0)
+ (malyon-newline)
+ (malyon-print "A z-code interpreter for version 3, 5, and 8 games.")
+ (malyon-newline)
+ (malyon-print "(c) 1999-2011 by Peter Ilberg <peter.ilbergNOSPAMgmail.com>")
+ (malyon-newline)
+ (malyon-newline))
+
+;; cleanup
+
+(defun malyon-cleanup ()
+ "Clean up the z code interpreter."
+ (condition-case nil
+ (progn
+ (setq malyon-story-file nil)
+ (setq malyon-window-configuration nil)
+ (setq malyon-game-state-restart nil)
+ (setq malyon-game-state-undo nil)
+ (if (get-buffer "Malyon Status")
+ (kill-buffer (get-buffer "Malyon Status")))
+ (if (get-buffer "Malyon Transcript")
+ (progn
+ (switch-to-buffer (get-buffer "Malyon Transcript"))
+ (malyon-redisplay-frame (selected-frame) t)
+ (delete-other-windows (get-buffer-window (current-buffer)))
+ (widen)
+ (text-mode)))
+ (setq malyon-status-buffer nil)
+ (setq malyon-transcript-buffer nil))
+ (error
+ (malyon-fatal-error "cleanup failed."))))
+
+;; error handling
+
+(defun malyon-fatal-error (message)
+ "Print error message and abort."
+ (setq message (concat "Malyon fatal error: " message))
+ (unwind-protect
+ (save-excursion
+ (set-buffer malyon-transcript-buffer)
+ (goto-char (point-max))
+ (newline)
+ (newline)
+ (put-text-property 0
+ (length message)
+ 'face
+ 'malyon-face-error
+ message)
+ (insert message)
+ (newline))
+ (malyon-cleanup)
+ (malyon-redisplay-frame (selected-frame) t)
+ (error message)))
+
+;; conversion of zscii to ascii
+
+(defvar malyon-unicode-table nil
+ "An array mapping zscii characters to latin-1 ones.")
+
+(defvar malyon-default-unicode-table nil
+ "The default array mapping zscii characters to latin-1 ones.")
+
+(if malyon-default-unicode-table
+ '()
+ (setq malyon-default-unicode-table
+ [32
+ 0 0 0 0 0 0 0 ; 1 - 7
+ 8 0 0 0 0 10 0 0 ; 8 - 15
+ 0 0 0 0 0 0 0 0 ; 16 - 23
+ 0 0 0 39 0 0 0 0 ; 24 - 31
+ 32 33 34 35 36 37 38 39 ; 32 - 39
+ 40 41 42 43 44 45 46 47 ; 40 - 47
+ 48 49 50 51 52 53 54 55 ; 48 - 55
+ 56 57 58 59 60 61 62 63 ; 56 - 63
+ 64 65 66 67 68 69 70 71 ; 64 - 71
+ 72 73 74 75 76 77 78 79 ; 72 - 79
+ 80 81 82 83 84 85 86 87 ; 80 - 87
+ 88 89 90 91 92 93 94 95 ; 88 - 95
+ 96 97 98 99 100 101 102 103 ; 96 - 103
+ 104 105 106 107 108 109 110 111 ; 104 - 111
+ 112 113 114 115 116 117 118 119 ; 112 - 119
+ 120 121 122 123 124 125 126 0 ; 120 - 127
+ 0 0 0 0 0 0 0 0 ; 128 - 135
+ 0 0 0 0 0 0 0 0 ; 136 - 143
+ 0 48 49 50 51 52 53 54 ; 144 - 151
+ 55 56 57 228 246 252 196 214 ; 152 - 159
+ 220 223 187 171 235 239 255 203 ; 160 - 167
+ 207 225 233 237 243 250 253 193 ; 168 - 175
+ 201 205 211 218 221 224 232 236 ; 176 - 183
+ 242 249 192 200 204 210 217 226 ; 184 - 191
+ 234 238 244 251 194 202 206 212 ; 192 - 199
+ 219 229 197 248 216 227 241 245 ; 200 - 207
+ 195 209 213 230 198 231 199 254 ; 208 - 215
+ 240 222 208 163 63 63 161 191 ; 216 - 223
+ 0 0 0 0 0 0 0 0 ; 224 - 231
+ 0 0 0 0 0 0 0 0 ; 232 - 239
+ 0 0 0 0 0 0 0 0 ; 240 - 247
+ 0 0 0 0 0 0 0 0 ; 248 - 255
+ ]))
+
+(defun malyon-initialize-unicode-table ()
+ "Initializes the zscii-to-unicode conversion table."
+ (setq malyon-unicode-table
+ (copy-sequence malyon-default-unicode-table))
+ (let* ((ext (malyon-read-word 54))
+ (len (if (zerop ext) 0 (malyon-read-word ext)))
+ (table (if (< len 3) 0 (malyon-read-word (+ ext 6)))))
+ (if (or (< malyon-story-version 5) (zerop table))
+ '()
+ (let ((i 0))
+ (while (< i 96)
+ (aset malyon-unicode-table (+ 155 i) (malyon-char-to-int ??))
+ (setq i (+ 1 i))))
+ (setq len (malyon-read-byte table))
+ (let ((i 0))
+ (while (< i len)
+ (aset malyon-unicode-table (+ 155 i)
+ (malyon-read-word (+ table 1 i)))
+ (setq i (+ 1 i)))))))
+
+(defsubst malyon-zscii-to-unicode (char)
+ "Converts a zscii character to unicode."
+ (if (or (< char 0) (> char 255))
+ ??
+ (let ((uni (aref malyon-unicode-table char)))
+ (if (zerop uni)
+ ??
+ (malyon-unibyte-char-to-multibyte (malyon-int-to-char uni))))))
+
+(defsubst malyon-unicode-to-zscii (char)
+ "Converts a unicode character to zscii."
+ (setq char (malyon-multibyte-char-to-unibyte char))
+ (setq char (if (malyon-characterp char) (malyon-char-to-int char) char))
+ (if (= 13 char)
+ ?\r
+ (let ((i 1) (found 0))
+ (while (and (< i 255) (zerop found))
+ (if (= char (aref malyon-unicode-table i))
+ (setq found i))
+ (setq i (+ i 1)))
+ (malyon-int-to-char found))))
+
+;; output streams
+
+(defvar malyon-output-streams nil
+ "Valid output streams for the interpreter.")
+
+(defvar malyon-output-streams-tables nil
+ "A list of active tables for stream 3.")
+
+(defun malyon-initialize-output-streams ()
+ "Initializes the output streams."
+ (setq malyon-output-streams '())
+ (setq malyon-output-streams-tables '())
+ (malyon-add-output-stream 1 0))
+
+(defun malyon-output-stream-function (stream)
+ "Returns the output function representing the given stream."
+ (cond ((= 1 stream) (if (zerop malyon-current-window)
+ 'malyon-putchar-transcript
+ 'malyon-putchar-status))
+ ((= 2 stream) 'malyon-putchar-printer)))
+
+(defun malyon-add-output-stream (stream table)
+ "Add a new output stream."
+ (if (= stream 3)
+ (progn
+ (setq malyon-output-streams-tables
+ (cons table malyon-output-streams-tables))
+ (malyon-store-word table 0))
+ (let ((function (malyon-output-stream-function stream)))
+ (setq malyon-output-streams
+ (if (member function malyon-output-streams)
+ malyon-output-streams
+ (cons function malyon-output-streams))))))
+
+(defun malyon-remove-output-stream (stream)
+ "Remove an output stream."
+ (if (= stream 3)
+ (setq malyon-output-streams-tables (cdr malyon-output-streams-tables))
+ (setq malyon-output-streams
+ (malyon-remove (malyon-output-stream-function stream)
+ malyon-output-streams))))
+
+(defun malyon-update-output-streams ()
+ "Update output streams when the output window has changed."
+ (let ((one (or (member 'malyon-putchar-transcript malyon-output-streams)
+ (member 'malyon-putchar-status malyon-output-streams))))
+ (setq malyon-output-streams
+ (malyon-remove 'malyon-putchar-transcript
+ (malyon-remove 'malyon-putchar-status
+ malyon-output-streams)))
+ (if one
+ (malyon-add-output-stream 1 0))))
+
+(defsubst malyon-output-character (char)
+ "Output a single character on all active streams."
+ (setq char (malyon-zscii-to-unicode char))
+ (if malyon-output-streams-tables
+ (malyon-putchar-table char (car malyon-output-streams-tables))
+ (malyon-mapc (lambda (s) (funcall s char)) malyon-output-streams)))
+
+;; printing text
+
+(defsubst malyon-abbrev (abbrev x)
+ "Print an abbreviation."
+ (malyon-print-ztext
+ (* 2 (malyon-read-word (+ malyon-abbreviations
+ (* 2 (+ x (* 32 (1- abbrev)))))))))
+
+(defun malyon-newline ()
+ "Print a newline."
+ (if (eq malyon-status-buffer (current-buffer))
+ (goto-char malyon-status-buffer-point)
+ (goto-char (point-max)))
+ (malyon-output-character ?\r)
+ (if (eq malyon-status-buffer (current-buffer))
+ (setq malyon-status-buffer-point (point))
+ (goto-char malyon-last-cursor-position-after-input))
+ (malyon-redisplay-frame (selected-frame) nil))
+
+(defun malyon-print (object)
+ "Print text."
+ (let ((text (if (malyon-characterp object) (char-to-string object) object))
+ (start))
+ (if (eq malyon-transcript-buffer (current-buffer))
+ (goto-char (point-max))
+ (goto-char malyon-status-buffer-point))
+ (setq start (point))
+ (malyon-print-characters (malyon-string-to-list text))
+ (put-text-property start (point) 'face malyon-current-face)
+ (if (eq malyon-status-buffer (current-buffer))
+ (setq malyon-status-buffer-point (point))
+ (goto-char malyon-last-cursor-position-after-input))))
+
+(defun malyon-print-characters (text)
+ "Print a list of characters."
+ (malyon-mapc 'malyon-output-character text))
+
+(defsubst malyon-print-state-new (char shift abbr zscii zcode)
+ "Generate a new print state."
+ (list char shift abbr zscii zcode))
+
+(defsubst malyon-print-state-initial ()
+ "Returns an initial state for the ztext decoder."
+ (malyon-print-state-new nil -6 0 0 0))
+
+(defsubst malyon-print-state-next (x ignore shift abbr zscii z)
+ "Print state transition function."
+ (cond ((= zscii 2)
+ (malyon-print-state-new (+ z x) -6 0 0 0))
+ ((= zscii 1)
+ (malyon-print-state-new nil -6 0 2 (* 32 x)))
+ ((> abbr 0)
+ (malyon-abbrev abbr x)
+ (malyon-print-state-initial))
+ ((= x 0)
+ (malyon-print-state-new ? -6 0 0 0))
+ ((< x 4)
+ (malyon-print-state-new nil -6 x 0 0))
+ ((= x 4)
+ (malyon-print-state-new nil 20 0 0 0))
+ ((= x 5)
+ (malyon-print-state-new nil 46 0 0 0))
+ ((and (= shift 46) (= x 6))
+ (malyon-print-state-new nil -6 0 1 0))
+ ((and (= shift 46) (= x 7))
+ (malyon-print-state-new ?\r -6 0 0 0))
+ (t
+ (malyon-print-state-new
+ (aref malyon-alphabet (+ shift x)) -6 0 0 0))))
+
+(defun malyon-print-text (address)
+ "Print text at address and return the address of the following byte."
+ (let ((start))
+ (if (eq malyon-transcript-buffer (current-buffer))
+ (goto-char (point-max))
+ (goto-char malyon-status-buffer-point))
+ (setq start (point))
+ (setq address (malyon-print-ztext address))
+ (put-text-property start (point) 'face malyon-current-face)
+ (if (eq malyon-status-buffer (current-buffer))
+ (setq malyon-status-buffer-point (point))
+ (goto-char malyon-last-cursor-position-after-input))
+ (malyon-redisplay-frame (selected-frame) nil)
+ address))
+
+(defun malyon-print-ztext (address)
+ "Print the ztext stored at the given address."
+ (let ((high 0) (low) (a) (b) (c) (state (malyon-print-state-initial)))
+ (while (zerop (logand 128 high))
+ (setq high (malyon-read-byte address))
+ (setq low (malyon-read-byte (+ 1 address)))
+ (setq a (logand 31 (lsh high -2)))
+ (setq b (logand 31 (logior (lsh high 3) (lsh low -5))))
+ (setq c (logand 31 low))
+ (setq state (apply 'malyon-print-state-next a state))
+ (if (car state) (malyon-output-character (car state)))
+ (setq state (apply 'malyon-print-state-next b state))
+ (if (car state) (malyon-output-character (car state)))
+ (setq state (apply 'malyon-print-state-next c state))
+ (if (car state) (malyon-output-character (car state)))
+ (setq address (+ 2 address)))
+ address))
+
+(defun malyon-putchar-transcript (char)
+ "Print a single character in the transcript window."
+ (if (char-equal char ?\n)
+ (newline 1)
+ (insert char)
+ (setq malyon-print-separator (null (member char malyon-whitespace))))
+ (if (and malyon-transcript-buffer-buffered
+ (> (current-column) (current-fill-column)))
+ (progn
+ (end-of-line)
+ (forward-word -1)
+ (if (< 0 (current-column))
+ (newline 1))
+ (end-of-line))))
+
+(defun malyon-putchar-status (char)
+ "Print a single character in the status window."
+ (if malyon-status-buffer-delayed-split
+ (progn
+ (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
+ (other-window 1)))
+ (if (char-equal char ?\n)
+ (progn
+ (beginning-of-line)
+ (forward-line 1)
+ (if (= (point) (point-max))
+ (forward-line -1)))
+ (if (> (current-column) (current-fill-column))
+ '()
+ (insert char)
+ (delete-char 1))))
+
+(defun malyon-putchar-table (char table)
+ "Print a single character into a table."
+ (setq char (malyon-unicode-to-zscii char))
+ (malyon-store-byte (+ 2 table (malyon-read-word table)) char)
+ (malyon-store-word table (+ 1 (malyon-read-word table))))
+
+(defun malyon-putchar-printer (char)
+ "Print a single character onto a printer."); not yet implemented
+
+;; more
+
+(defvar malyon-more-continue-keymap nil
+ "The keymap with which to continue after More has finished.")
+
+(defun malyon-more (keymap)
+ "Enter More mode."
+ (if (eq malyon-status-buffer (current-buffer))
+ (use-local-map keymap)
+ (if (< malyon-story-version 5) (malyon-opcode-show-status))
+ (if (< (count-lines malyon-last-cursor-position-after-input (point-max))
+ (malyon-window-displayed-height))
+ (progn
+ (malyon-adjust-transcript)
+ (use-local-map keymap))
+ (goto-char malyon-last-cursor-position-after-input)
+ (beginning-of-line)
+ (recenter 1)
+ (setq malyon-more-continue-keymap keymap)
+ (use-local-map malyon-keymap-more)
+ (message "[More]"))))
+
+(defun malyon-more-status-buffer ()
+ "Enter More mode for the status buffer."
+ (setq malyon-more-continue-keymap (current-local-map))
+ (use-local-map malyon-keymap-more-status)
+ (message "[More]")
+ (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
+
+;; input history
+
+(defvar malyon-history nil
+ "The input history.")
+
+(defun malyon-history-previous ()
+ "Move one entry up in the input history."
+ (let ((prev (aref malyon-history 0))
+ (curr (aref malyon-history 1))
+ (next (aref malyon-history 2)))
+ (if (null prev)
+ curr
+ (aset malyon-history 2 (if curr (cons curr next) next))
+ (aset malyon-history 0 (cdr prev))
+ (aset malyon-history 1 (car prev)))))
+
+(defun malyon-history-next ()
+ "Move one entry down in the input history."
+ (let ((prev (aref malyon-history 0))
+ (curr (aref malyon-history 1))
+ (next (aref malyon-history 2)))
+ (if (null next)
+ curr
+ (aset malyon-history 0 (if curr (cons curr prev) prev))
+ (aset malyon-history 2 (cdr next))
+ (aset malyon-history 1 (car next)))))
+
+(defun malyon-history-clear ()
+ "Clear the input history."
+ (setq malyon-history (vector '() nil '())))
+
+(defun malyon-history-insert (entry)
+ "Insert an entry into the input history."
+ (let* ((prev (aref malyon-history 0))
+ (curr (aref malyon-history 1))
+ (next (aref malyon-history 2))
+ (l (malyon-remove entry
+ (append (nreverse prev)
+ (if curr (cons curr next) next))))
+ (cut (- (length l) 19)))
+ (while (> cut 0)
+ (setq l (cdr l)
+ cut (- cut 1)))
+ (aset malyon-history 0
+ (malyon-remove nil (malyon-remove "" (cons entry (nreverse l)))))
+ (aset malyon-history 1 nil)
+ (aset malyon-history 2 '())))
+
+;; dictionary lookup
+
+(defun malyon-dictionary-word (chars)
+ "Convert a list of characters into a dictionary word."
+ (list (car (car chars))
+ (length chars)
+ (malyon-encode-dictionary-word (append (malyon-mapcan 'cdr chars)
+ '(5 5 5 5 5 5 5 5)))))
+
+(defsubst malyon-join-characters (stop list)
+ "Joins three ztext characters into two bytes."
+ (let ((a (car list))
+ (b (malyon-cadr list))
+ (c (malyon-caddr list))
+ (x (if (zerop stop) 0 128)))
+ (list (logior x (logand 255 (logior (lsh a 2) (lsh b -3))))
+ (logand 255 (logior (lsh b 5) c)))))
+
+(defun malyon-encode-dictionary-word (l)
+ "Converts a list of ztext characters into a dictionary word."
+ (let* ((first l)
+ (second (malyon-cdddr first))
+ (third (malyon-cdddr second)))
+ (apply 'vector
+ (if (< malyon-story-version 5)
+ (append (malyon-join-characters 0 first)
+ (malyon-join-characters 1 second))
+ (append (malyon-join-characters 0 first)
+ (malyon-join-characters 0 second)
+ (malyon-join-characters 1 third))))))
+
+(defun malyon-lookup (dict code)
+ "Look for the given code in the dictionary and return its address."
+ (cond ((not code) 0)
+ ((not dict) (malyon-binary-search code))
+ ((= dict malyon-dictionary) (malyon-binary-search code))
+ (t (malyon-linear-search dict code))))
+
+(defsubst malyon-compare-words (word address)
+ "Compares the given word to the word stored at address."
+ (let* ((i 0)
+ (j address)
+ (x (aref word i))
+ (y (malyon-read-byte j)))
+ (while (not (or (/= x y) (= i malyon-dictionary-word-length)))
+ (setq i (+ 1 i)
+ j (+ 1 j)
+ x (aref word i)
+ y (malyon-read-byte j)))
+ (- x y)))
+
+;; search functions
+
+(defun malyon-binary-search (code)
+ "Binary search through the main dictionary."
+ (let* ((lower 0)
+ (upper (- malyon-dictionary-num-entries 1))
+ (median (/ (+ lower upper) 2))
+ (entry (+ malyon-dictionary-entries
+ (* malyon-dictionary-entry-length median)))
+ (looking (malyon-compare-words code entry)))
+ (while (not (or (> lower upper) (zerop looking)))
+ (setq lower (if (< 0 looking) (+ median 1) lower)
+ upper (if (> 0 looking) (- median 1) upper)
+ median (/ (+ lower upper) 2)
+ entry (+ malyon-dictionary-entries
+ (* malyon-dictionary-entry-length median))
+ looking (malyon-compare-words code entry)))
+ (if (zerop looking) entry 0)))
+
+(defun malyon-linear-search (dictionary code)
+ "Linear search through the given dictionary."
+ (let* ((length (malyon-read-byte (+ dictionary 1
+ (malyon-read-byte dictionary))))
+ (number (malyon-read-word (+ dictionary 2
+ (malyon-read-byte dictionary))))
+ (entries (+ dictionary 4 (malyon-read-byte dictionary)))
+ (i 0)
+ (entry (+ entries (* length i)))
+ (looking (malyon-compare-words code entry)))
+ (while (not (or (>= i number) (zerop looking)))
+ (setq i (+ 1 i)
+ entry (+ entries (* length i))
+ looking (malyon-compare-words code entry)))
+ (if (zerop looking) entry 0)))
+
+;; encoding text and lexical analysis
+
+(defun malyon-split-list (sep list &optional x)
+ "Split a list into sublists as indicated by the separators."
+ (cond ((null list)
+ (list (nreverse x)))
+ ((eq sep (car list))
+ (cons (nreverse x) (malyon-split-list sep (cdr list) '())))
+ (t
+ (malyon-split-list sep (cdr list) (cons (car list) x)))))
+
+(defun malyon-characters-to-words (list)
+ "Turn the list of characters into a list of words."
+ (mapcar 'malyon-dictionary-word
+ (delete '() (malyon-split-list 'malyon-word-separator list))))
+
+(defsubst malyon-char-in-string (c s)
+ "Returns the index of c in s if found, or length of s."
+ (let ((i 0))
+ (while (not (or (= i (length s)) (= c (aref s i))))
+ (setq i (+ 1 i)))
+ i))
+
+(defsubst malyon-encode-into-ztext (c)
+ "Convert a character into ztext."
+ (let* ((index (malyon-char-in-string c malyon-alphabet))
+ (shift (floor index 26))
+ (char (+ 6 (mod index 26))))
+ (cond ((> shift 2) (list 5 6 (logand 31 (lsh c -5)) (logand 31 c)))
+ ((= shift 2) (list 5 char))
+ ((= shift 1) (list 4 char))
+ (t (list char)))))
+
+(defun malyon-encode-single-character (terminating-characters char)
+ "Encode a character into ztext."
+ (let ((pos (car char))
+ (c (cdr char)))
+ (cond ((member c malyon-whitespace)
+ (list 'malyon-word-separator))
+ ((member c terminating-characters)
+ (list 'malyon-word-separator
+ (cons pos (malyon-encode-into-ztext c))
+ 'malyon-word-separator))
+ (t (list (cons pos (malyon-encode-into-ztext c)))))))
+
+(defun malyon-encode-character-list (dict list)
+ "Encode the list of characters into ztext."
+ (let ((l '())
+ (i 0))
+ (while (< i (malyon-read-byte dict))
+ (setq l (cons (malyon-read-byte (+ dict 1 i)) l)
+ i (+ 1 i)))
+ (malyon-mapcan (lambda (x) (malyon-encode-single-character l x)) list)))
+
+(defun malyon-text-length (address)
+ "Return the length of the input text."
+ (if (>= malyon-story-version 5)
+ (malyon-read-byte (+ 1 address))
+ (let ((i 0))
+ (while (not (zerop (malyon-read-byte (+ i 1 address))))
+ (setq i (+ i 1)))
+ i)))
+
+(defun malyon-text-to-character-list (address)
+ "Convert the input text into a list of characters."
+ (let ((i (malyon-text-length address))
+ (text '()))
+ (while (< 0 i)
+ (setq text (cons
+ (cons (if (< malyon-story-version 5) i (+ 1 i))
+ (malyon-read-byte
+ (+ i address (if (< malyon-story-version 5) 0 1))))
+ text)
+ i (- i 1)))
+ text))
+
+(defun malyon-text-to-words (address dictionary)
+ "Turn ztext into a list of dictionary words."
+ (malyon-characters-to-words
+ (malyon-encode-character-list (if dictionary dictionary malyon-dictionary)
+ (malyon-text-to-character-list address))))
+
+;; window management
+
+(defvar malyon-status-buffer-grew-this-turn nil
+ "A flag signalling if the status buffer grew this turn.")
+
+(defun malyon-adjust-transcript ()
+ "Adjust the position of the transcript text."
+ (save-excursion
+ (setq malyon-status-buffer-grew-this-turn nil)
+ (set-buffer malyon-transcript-buffer)
+ (goto-char (point-max))
+ (recenter (- (malyon-window-displayed-height) 2))))
+
+(defun malyon-prepare-status-buffer (status)
+ "Fill the status buffer with empty lines."
+ (save-excursion
+ (set-buffer malyon-status-buffer)
+ (let ((lines (count-lines (point-min) (point-max)))
+ (new status))
+ (if (zerop lines)
+ (newline 1))
+ (goto-char (point-max))
+ (setq status (- status lines -1))
+ (while (> status 0)
+ (insert (make-string (+ 3 malyon-max-column) ? ))
+ (newline 1)
+ (setq status (- status 1)))
+ (goto-char (point-min))
+ (forward-line (+ 1 new))
+ (kill-region (point) (point-max))
+ (insert (make-string (+ 3 malyon-max-column) ? ))
+ (newline 1))))
+
+(defun malyon-restore-window-configuration ()
+ "Restore the saved window configuration."
+ (let ((buffer (window-buffer (selected-window))))
+ (if malyon-window-configuration
+ (set-window-configuration malyon-window-configuration))
+ (cond ((eq malyon-status-buffer buffer) (other-window 1))
+ ((eq malyon-transcript-buffer buffer) (goto-char (point-max))))))
+
+(defun malyon-set-window-configuration (status)
+ "Set up the new window configuration."
+ (cond ((< status malyon-status-buffer-lines)
+ (setq malyon-status-buffer-delayed-split status)
+ (if malyon-status-buffer-grew-this-turn
+ (malyon-more-status-buffer)))
+ ((> status malyon-status-buffer-lines)
+ (malyon-split-buffer-windows status)
+ (setq malyon-status-buffer-grew-this-turn t))
+ ((not malyon-window-configuration)
+ (malyon-split-buffer-windows status))))
+
+(defun malyon-split-buffer-windows (status)
+ "Split the buffer windows.
+The status buffer gets 'status' lines while the transcript buffer
+gets the remaining lines."
+ (delete-other-windows (get-buffer-window (current-buffer)))
+ (setq malyon-status-buffer-lines status)
+ (setq malyon-status-buffer-delayed-split nil)
+ (if (zerop status)
+ '()
+ (split-window (get-buffer-window (current-buffer)) (+ status 3))
+ (switch-to-buffer malyon-status-buffer)
+ (malyon-prepare-status-buffer status)
+ (malyon-opcode-set-cursor 1 1)
+ (other-window 1))
+ (switch-to-buffer malyon-transcript-buffer)
+ (setq malyon-window-configuration (current-window-configuration)))
+
+;; getting and setting the machine state
+
+(defun malyon-current-game-state ()
+ "Return the current state of the interpreter."
+ (vector malyon-instruction-pointer
+ malyon-stack-pointer
+ malyon-frame-pointer
+ (copy-sequence malyon-stack)
+ (copy-sequence malyon-story-file)
+ malyon-game-state-quetzal))
+
+(defun malyon-set-game-state (state)
+ "Installs the given state as the new state of the interpreter."
+ (setq malyon-instruction-pointer (aref state 0))
+ (setq malyon-stack-pointer (aref state 1))
+ (setq malyon-frame-pointer (aref state 2))
+ (setq malyon-stack (copy-sequence (aref state 3)))
+ (setq malyon-story-file (copy-sequence (aref state 4)))
+ (setq malyon-game-state-quetzal (aref state 5))
+ (save-excursion
+ (malyon-erase-buffer malyon-status-buffer)
+ (malyon-split-buffer-windows 0)
+ (setq malyon-last-cursor-position-after-input
+ (malyon-point-max malyon-transcript-buffer))))
+
+;; file utilities
+
+(defsubst malyon-write-byte-to-file (byte)
+ "Write a byte to a file."
+ (insert-char (logand 255 byte) 1))
+
+(defsubst malyon-write-word-to-file (word)
+ "Write a word to the last opened file."
+ (insert-char (logand 255 (lsh word -8)) 1)
+ (insert-char (logand 255 word) 1))
+
+(defsubst malyon-write-dword-to-file (dword)
+ "Write a dword to the last opened file."
+ (insert-char (logand 255 (lsh dword -24)) 1)
+ (insert-char (logand 255 (lsh dword -16)) 1)
+ (insert-char (logand 255 (lsh dword -8)) 1)
+ (insert-char (logand 255 dword) 1))
+
+(defsubst malyon-write-chunk-id-to-file (id)
+ "Write a quetzal chunk id to the last opened file."
+ (insert id))
+
+(defsubst malyon-read-byte-from-file ()
+ "Read the next byte from a file."
+ (if (= (point) (point-max))
+ 0
+ (forward-char 1)
+ (malyon-char-to-int (malyon-char-before))))
+
+(defsubst malyon-read-word-from-file ()
+ "Read the next word from the last opened file."
+ (logior (lsh (malyon-read-byte-from-file) 8) (malyon-read-byte-from-file)))
+
+(defsubst malyon-read-dword-from-file ()
+ "Read the next dword from the last opened file."
+ (logior (lsh (malyon-read-byte-from-file) 24)
+ (lsh (malyon-read-byte-from-file) 16)
+ (lsh (malyon-read-byte-from-file) 8)
+ (malyon-read-byte-from-file)))
+
+(defsubst malyon-read-chunk-id-from-file ()
+ "Read a quetzal chunk id from the last opened file."
+ (string (malyon-int-to-char (malyon-read-byte-from-file))
+ (malyon-int-to-char (malyon-read-byte-from-file))
+ (malyon-int-to-char (malyon-read-byte-from-file))
+ (malyon-int-to-char (malyon-read-byte-from-file))))
+
+(defun malyon-get-file-name (address)
+ "Retrieves the file name stored at address."
+ (let ((name (make-string (malyon-read-byte address) ? ))
+ (i 0))
+ (while (< i (length name))
+ (aset name i (malyon-read-byte (+ address 1 i)))
+ (setq i (+ 1 i)))
+ name))
+
+;; saving data to disk
+
+(defun malyon-save-file (file &optional table length)
+ "Save the current game state or a memory section to disk."
+ (interactive "FSave file: ")
+ (condition-case nil
+ (save-excursion
+ (set-buffer (create-file-buffer file))
+ (malyon-disable-multibyte)
+ (malyon-erase-buffer)
+ (cond (table (malyon-save-table table length))
+ (malyon-game-state-quetzal
+ (malyon-save-quetzal-state (malyon-current-game-state)))
+ (t
+ (malyon-save-game-state (malyon-current-game-state))))
+ (let ((coding-system-for-write 'binary))
+ (write-file file))
+ (kill-buffer nil)
+ 1)
+ (error 0)))
+
+(defun malyon-save-table (table length)
+ "Save the given section of memory to the file."
+ (let ((i 0)
+ (j table))
+ (while (< i length)
+ (malyon-write-byte-to-file (malyon-read-byte j))
+ (setq i (+ 1 i)
+ j (+ 1 j)))))
+
+(defun malyon-save-game-state (state)
+ "Saves the game state to disk."
+ (let ((ip (aref state 0))
+ (sp (aref state 1))
+ (fp (aref state 2))
+ (stack (aref state 3))
+ (mem (aref state 4))
+ (dyn (malyon-read-word 14))
+ (i 0))
+ (malyon-write-word-to-file (length malyon-story-file-name))
+ (while (< i (length malyon-story-file-name))
+ (malyon-write-byte-to-file (aref malyon-story-file-name i))
+ (setq i (+ 1 i)))
+ (malyon-write-dword-to-file ip)
+ (malyon-write-word-to-file sp)
+ (malyon-write-word-to-file fp)
+ (malyon-write-word-to-file dyn)
+ (setq i 0)
+ (while (<= i sp)
+ (malyon-write-dword-to-file (aref stack i))
+ (setq i (+ 1 i)))
+ (setq i 0)
+ (while (< i dyn)
+ (malyon-write-byte-to-file (aref mem i))
+ (setq i (+ 1 i)))))
+
+(defun malyon-save-quetzal-state (state)
+ "Saves the game state to disk in quetzal format."
+ (goto-char (point-min))
+ (malyon-save-quetzal-ifhd state)
+ (malyon-save-quetzal-cmem state)
+ (malyon-save-quetzal-stks state)
+ (goto-char (point-min))
+ (malyon-write-chunk-id-to-file "IFZS")
+ (goto-char (point-min))
+ (malyon-write-dword-to-file (- (point-max) (point-min)))
+ (goto-char (point-min))
+ (malyon-write-chunk-id-to-file "FORM"))
+
+(defun malyon-save-quetzal-ifhd (state)
+ "Saves the IFhd chunk of the quetzal format."
+ (malyon-write-chunk-id-to-file "IFhd")
+ (malyon-write-dword-to-file 13)
+ (malyon-write-word-to-file (malyon-read-word 2))
+ (malyon-write-word-to-file (malyon-read-word 18))
+ (malyon-write-word-to-file (malyon-read-word 20))
+ (malyon-write-word-to-file (malyon-read-word 22))
+ (malyon-write-word-to-file (malyon-read-word 28))
+ (malyon-write-byte-to-file (lsh (aref state 0) -16))
+ (malyon-write-byte-to-file (lsh (aref state 0) -8))
+ (malyon-write-byte-to-file (aref state 0))
+ (malyon-write-byte-to-file 0))
+
+(defun malyon-save-quetzal-cmem (state)
+ "Saves the CMem chunk of the quetzal format."
+ (let ((beginning (point-max))
+ (original (aref malyon-game-state-restart 4))
+ (current (aref state 4))
+ (size (malyon-read-word 14))
+ (byte 0)
+ (count 0)
+ (i 0))
+ (goto-char (point-max))
+ (while (< i size)
+ (setq byte (logxor (aref current i) (aref original i)))
+ (if (zerop byte)
+ (setq count (+ 1 count))
+ (while (> count 0)
+ (malyon-write-byte-to-file 0)
+ (setq count (- count 1))
+ (malyon-write-byte-to-file (min 255 count))
+ (setq count (- count (min 255 count))))
+ (malyon-write-byte-to-file byte))
+ (setq i (+ 1 i)))
+ (setq size (- (point-max) beginning))
+ (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
+ (goto-char beginning)
+ (malyon-write-chunk-id-to-file "CMem")
+ (malyon-write-dword-to-file size)))
+
+(defun malyon-save-quetzal-stks (state)
+ "Saves the Stks chunk of the quetzal format."
+ (let ((beginning (point-max))
+ (size 0))
+ (goto-char (point-max))
+ (malyon-save-quetzal-stack-frame (- (aref state 2) 4)
+ (aref state 1)
+ (aref state 3))
+ (setq size (- (point-max) beginning))
+ (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
+ (goto-char beginning)
+ (malyon-write-chunk-id-to-file "Stks")
+ (malyon-write-dword-to-file size)))
+
+(defun malyon-save-quetzal-stack-frame (fp sp stack)
+ "Saves the stack frames for the Stks chunk."
+ (let* ((frame (malyon-get-stack-frame fp sp stack))
+ (frame-id (aref frame 0))
+ (previous-fp (aref frame 1))
+ (previous-sp (aref frame 2))
+ (return-addr (aref frame 3))
+ (result-addr (aref frame 4))
+ (local-vars (aref frame 5))
+ (num-args (aref frame 6))
+ (eval-stack (aref frame 7)))
+ (if (> frame-id 0)
+ (malyon-save-quetzal-stack-frame previous-fp previous-sp stack))
+ (malyon-write-byte-to-file (lsh return-addr -16))
+ (malyon-write-byte-to-file (lsh return-addr -8))
+ (malyon-write-byte-to-file return-addr)
+ (if (zerop frame-id)
+ (malyon-write-byte-to-file 0)
+ (malyon-write-byte-to-file (logior (if result-addr 0 16)
+ (length local-vars))))
+ (malyon-write-byte-to-file (if result-addr result-addr 0))
+ (malyon-write-byte-to-file (- (lsh 1 num-args) 1))
+ (malyon-write-word-to-file (length eval-stack))
+ (while (not (null local-vars))
+ (malyon-write-word-to-file (car local-vars))
+ (setq local-vars (cdr local-vars)))
+ (while (not (null eval-stack))
+ (malyon-write-word-to-file (car eval-stack))
+ (setq eval-stack (cdr eval-stack)))))
+
+;; restoring data from disk
+
+(defvar malyon-restore-data-error nil
+ "An error message if restoring data from a file failed.")
+
+(defvar malyon-restore-quetzal-stack nil
+ "A temporary stack for restoring quetzal game states.")
+
+(defvar malyon-restore-quetzal-stack-pointer nil
+ "A temporary stack pointer for restoring quetzal game states.")
+
+(defvar malyon-restore-quetzal-frame-pointer nil
+ "A temporary frame-pointer for restoring quetzal game states.")
+
+(defun malyon-restore-file (file &optional table length)
+ "Restore a game state or a memory section from disk."
+ (interactive "fLoad file: ")
+ (if (not (and (file-exists-p file) (file-readable-p file)))
+ 0
+ (condition-case nil
+ (save-excursion
+ (setq malyon-restore-data-error nil)
+ (set-buffer (create-file-buffer file))
+ (malyon-disable-multibyte)
+ (malyon-erase-buffer)
+ (let ((coding-system-for-read 'binary))
+ (insert-file-contents file))
+ (goto-char (point-min))
+ (if table
+ (malyon-restore-table table length)
+ (let* ((first (malyon-read-chunk-id-from-file))
+ (second (malyon-read-dword-from-file))
+ (third (malyon-read-chunk-id-from-file)))
+ (if (and (string= "FORM" first) (string= "IFZS" third))
+ (malyon-restore-quetzal-state (+ 8 second))
+ (goto-char (point-min))
+ (malyon-restore-game-state))))
+ (kill-buffer nil)
+ (if (null malyon-restore-data-error)
+ 2
+ (message malyon-restore-data-error)
+ 0))
+ (error 0))))
+
+(defun malyon-restore-table (table length)
+ "Restore the given section of memory from a file."
+ (let ((i 0)
+ (j table))
+ (while (< i length)
+ (malyon-store-byte j (malyon-read-byte-from-file))
+ (setq i (+ 1 i)
+ j (+ 1 j)))))
+
+(defun malyon-restore-game-state ()
+ "Restore a saved game state from disk."
+ (let ((len 0)
+ (name 0)
+ (story 0)
+ (ip 0)
+ (sp 0)
+ (fp 0)
+ (dyn 0)
+ (stack (copy-sequence malyon-stack))
+ (mem (copy-sequence malyon-story-file))
+ (i 0))
+ (setq len (malyon-read-word-from-file))
+ (setq name (make-string len ? ))
+ (while (< i len)
+ (aset name i (malyon-read-byte-from-file))
+ (setq i (+ 1 i)))
+ (setq ip (malyon-read-dword-from-file))
+ (setq sp (malyon-read-word-from-file))
+ (setq fp (malyon-read-word-from-file))
+ (setq dyn (malyon-read-word-from-file))
+ (setq i 0)
+ (while (<= i sp)
+ (aset stack i (malyon-read-dword-from-file))
+ (setq i (+ 1 i)))
+ (setq i 0)
+ (while (< i dyn)
+ (aset mem i (malyon-read-byte-from-file))
+ (setq i (+ 1 i)))
+ (setq name (file-name-nondirectory name))
+ (setq story (file-name-nondirectory malyon-story-file-name))
+ (if (or (string-match name story) (string-match story name))
+ (malyon-set-game-state (vector ip sp fp stack mem nil))
+ (setq malyon-restore-data-error "Invalid save file."))))
+
+(defun malyon-restore-quetzal-state (size)
+ "Restore a saved quetzal game state from disk."
+ (let ((chunk-id nil)
+ (chunk-len 0)
+ (ip 0)
+ (memory nil)
+ (stack nil)
+ (beginning 0))
+ (while (< (point) size)
+ (setq chunk-id (malyon-read-chunk-id-from-file))
+ (setq chunk-len (malyon-read-dword-from-file))
+ (setq beginning (point))
+ (cond ((string= chunk-id "IFhd")
+ (setq ip (malyon-restore-quetzal-ifhd chunk-len)))
+ ((string= chunk-id "CMem")
+ (setq memory (malyon-restore-quetzal-cmem chunk-len)))
+ ((string= chunk-id "UMem")
+ (setq memory (malyon-restore-quetzal-umem chunk-len)))
+ ((string= chunk-id "Stks")
+ (setq stack (malyon-restore-quetzal-stks chunk-len))))
+ (if (zerop (mod chunk-len 2)) '() (setq chunk-len (+ 1 chunk-len)))
+ (goto-char (+ beginning chunk-len)))
+ (cond ((and ip memory stack)
+ (malyon-set-game-state (vector ip
+ (aref stack 0)
+ (aref stack 1)
+ (aref stack 2)
+ memory
+ t)))
+ ((null malyon-restore-data-error)
+ (setq malyon-restore-data-error "invalid quetzal file.")))))
+
+(defun malyon-restore-quetzal-ifhd (size)
+ "Restore an IFhd chunk from disk. Return the instruction pointer."
+ (if (and (= (malyon-read-word-from-file) (malyon-read-word 2))
+ (= (malyon-read-word-from-file) (malyon-read-word 18))
+ (= (malyon-read-word-from-file) (malyon-read-word 20))
+ (= (malyon-read-word-from-file) (malyon-read-word 22))
+ (= (malyon-read-word-from-file) (malyon-read-word 28)))
+ (logior (lsh (malyon-read-byte-from-file) 16)
+ (lsh (malyon-read-byte-from-file) 8)
+ (malyon-read-byte-from-file))
+ (setq malyon-restore-data-error "quetzal file doesn't belong to game.")
+ nil))
+
+(defun malyon-restore-quetzal-cmem (size)
+ "Restore a CMem chunk from disk. Return the entire memory layout."
+ (let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
+ (max-size (+ (point) size))
+ (byte 0)
+ (i 0))
+ (while (< (point) max-size)
+ (setq byte (malyon-read-byte-from-file))
+ (if (zerop byte)
+ (setq i (+ 1 i (malyon-read-byte-from-file)))
+ (aset memory i (logxor byte (aref memory i)))
+ (setq i (+ 1 i))))
+ memory))
+
+(defun malyon-restore-quetzal-umem (size)
+ "Restore a UMem chunk from disk. Return the entire memory layout."
+ (let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
+ (i 0))
+ (while (< i size)
+ (aset memory i (malyon-read-byte-from-file))
+ (setq i (+ 1 i)))
+ memory))
+
+(defun malyon-restore-quetzal-stks (size)
+ "Restore a Stks chunk from disk. Return a vector containing the
+stack pointer, the frame pointer, and the stack itself."
+ (let ((i 0) (frame-id 0))
+ (setq malyon-restore-quetzal-stack
+ (copy-sequence (aref malyon-game-state-restart 3)))
+ (setq malyon-restore-quetzal-stack-pointer -1)
+ (setq malyon-restore-quetzal-frame-pointer 2)
+ (while (< i size)
+ (let* ((beginning (point))
+ (return3 (malyon-read-byte-from-file))
+ (return2 (malyon-read-byte-from-file))
+ (return1 (malyon-read-byte-from-file))
+ (return-addr (logior (lsh return3 16) (lsh return2 8) return1))
+ (result-locals (malyon-read-byte-from-file))
+ (has-result (zerop (logand 16 result-locals)))
+ (num-locals (logand 15 result-locals))
+ (result-addr (malyon-read-byte-from-file))
+ (arg-flags (+ 1 (malyon-read-byte-from-file)))
+ (num-args 0)
+ (eval-size (malyon-read-word-from-file))
+ (local-vars '())
+ (eval-stack '()))
+ (while (> num-locals 0)
+ (setq local-vars (cons (malyon-read-word-from-file) local-vars))
+ (setq num-locals (- num-locals 1)))
+ (while (> eval-size 0)
+ (setq eval-stack (cons (malyon-read-word-from-file) eval-stack))
+ (setq eval-size (- eval-size 1)))
+ (while (> arg-flags 1)
+ (setq arg-flags (lsh arg-flags -1))
+ (setq num-args (+ num-args 1)))
+ (malyon-push-stack-frame frame-id
+ return-addr
+ (if (zerop frame-id)
+ nil
+ (if has-result result-addr nil))
+ (reverse local-vars)
+ num-args
+ (reverse eval-stack))
+ (setq frame-id (+ 1 frame-id))
+ (setq i (+ i (- (point) beginning)))))
+ (vector malyon-restore-quetzal-stack-pointer
+ malyon-restore-quetzal-frame-pointer
+ malyon-restore-quetzal-stack)))
+
+;; object table management
+
+(defsubst malyon-object-address (object)
+ "Compute the address at which the object is stored."
+ (+ malyon-object-table
+ (* 2 malyon-object-properties)
+ (* malyon-object-table-entry-size (- object 1))))
+
+(defsubst malyon-object-read-parent (address)
+ "Return the parent."
+ (if (< malyon-story-version 5)
+ (malyon-read-byte (+ 4 address))
+ (malyon-read-word (+ 6 address))))
+
+(defsubst malyon-object-read-sibling (address)
+ "Return the next sibling."
+ (if (< malyon-story-version 5)
+ (malyon-read-byte (+ 5 address))
+ (malyon-read-word (+ 8 address))))
+
+(defsubst malyon-object-read-child (address)
+ "Return the first child."
+ (if (< malyon-story-version 5)
+ (malyon-read-byte (+ 6 address))
+ (malyon-read-word (+ 10 address))))
+
+(defsubst malyon-object-store-parent (address value)
+ "Set the parent."
+ (if (< malyon-story-version 5)
+ (malyon-store-byte (+ 4 address) value)
+ (malyon-store-word (+ 6 address) value)))
+
+(defsubst malyon-object-store-sibling (address value)
+ "Set the next sibling."
+ (if (< malyon-story-version 5)
+ (malyon-store-byte (+ 5 address) value)
+ (malyon-store-word (+ 8 address) value)))
+
+(defsubst malyon-object-store-child (address value)
+ "Set the first child."
+ (if (< malyon-story-version 5)
+ (malyon-store-byte (+ 6 address) value)
+ (malyon-store-word (+ 10 address) value)))
+
+(defun malyon-find-property (object property)
+ "Return the address of the object's property, or 0 if it doesn't exist."
+ (let ((next (malyon-first-property object))
+ (number 0))
+ (setq number (logand (malyon-read-byte next) malyon-object-properties))
+ (while (> number property)
+ (setq next (malyon-next-property next))
+ (setq number (logand (malyon-read-byte next) malyon-object-properties)))
+ (if (= number property) next 0)))
+
+(defun malyon-first-property (object)
+ "Get the address of the object's first property."
+ (let ((header (malyon-read-word (+ malyon-object-property-offset
+ (malyon-object-address object)))))
+ (+ header 1 (* 2 (malyon-read-byte header)))))
+
+(defun malyon-next-property (property)
+ "Get the address of the following property."
+ (let ((size (malyon-read-byte property))
+ (addr (+ property 1)))
+ (+ 1 addr (cond ((< malyon-story-version 5) (lsh size -5))
+ ((zerop (logand 128 size)) (lsh size -6))
+ (t
+ (let ((second (logand 63 (malyon-read-byte addr))))
+ (if (= 0 second) 64 second)))))))
+
+(defun malyon-remove-object (object)
+ "Remove the object from the children list of its parent."
+ (let* ((address (malyon-object-address object))
+ (parent (malyon-object-read-parent address))
+ (sibling (malyon-object-read-sibling address)))
+ (malyon-object-store-parent address 0)
+ (malyon-object-store-sibling address 0)
+ (if (/= parent 0)
+ (let ((parent-addr (malyon-object-address parent)))
+ (let ((children (malyon-object-read-child parent-addr)))
+ (if (or (= children 0) (= children object))
+ (malyon-object-store-child parent-addr sibling)
+ (let ((this (malyon-object-address children)))
+ (let ((next (malyon-object-read-sibling this)))
+ (while (/= next object)
+ (setq this (malyon-object-address next))
+ (setq next (malyon-object-read-sibling this)))
+ (malyon-object-store-sibling this sibling)))))))))
+
+;; function calls and code branches
+
+(defun malyon-call-routine (routine arguments &optional result)
+ "Call a routine with the given arguments and return its result."
+ (if (= routine 0)
+ (if result (malyon-store-variable result 0) 0)
+ (malyon-push-stack (if result 0 1))
+ (malyon-push-stack (if result result 0))
+ (malyon-push-stack malyon-instruction-pointer)
+ (malyon-push-stack
+ (logior (lsh (- malyon-stack-pointer malyon-frame-pointer) 8)
+ (length arguments)))
+ (setq malyon-instruction-pointer (* malyon-packed-multiplier routine))
+ (let ((args (malyon-read-code-byte)) (value nil))
+ (if malyon-game-state-quetzal
+ (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
+ (malyon-push-stack (logior (lsh (+ 1 id) 8) args))))
+ (setq malyon-frame-pointer malyon-stack-pointer)
+ (while (> args 0)
+ (setq value (if (< malyon-story-version 5) (malyon-read-code-word) 0))
+ (malyon-push-stack (if (null arguments) value (car arguments)))
+ (setq arguments (cdr arguments))
+ (setq args (- args 1))))))
+
+(defun malyon-jump-if (condition)
+ "Jump depending on the condition and the following jump data."
+ (let ((byte (malyon-read-code-byte))
+ (offset nil)
+ (iftrue nil))
+ (setq iftrue (/= 0 (logand byte 128)))
+ (setq offset (logand byte 63))
+ (if (= 0 (logand byte 64))
+ (progn
+ (setq offset (logior (lsh offset 8) (malyon-read-code-byte)))
+ (if (>= offset 8192) (setq offset (- offset 16384)))))
+ (if (or (and iftrue condition) (and (not iftrue) (not condition)))
+ (progn
+ (cond ((= offset 0) (malyon-opcode-rfalse))
+ ((= offset 1) (malyon-opcode-rtrue))
+ (t (setq
+ malyon-instruction-pointer
+ (+ malyon-instruction-pointer offset -2))))))))
+
+(defun malyon-return (value)
+ "Return from a routine."
+ (setq malyon-stack-pointer malyon-frame-pointer)
+ (if malyon-game-state-quetzal (malyon-pop-stack))
+ (setq malyon-frame-pointer
+ (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
+ (setq malyon-instruction-pointer (malyon-pop-stack))
+ (let ((result (malyon-pop-stack))
+ (store (malyon-pop-stack)))
+ (if (zerop store)
+ (malyon-return-store result value)
+ (malyon-return-ignore result value))))
+
+(defun malyon-return-ignore (where value)
+ "Return from a routine ignoring the result.")
+
+(defun malyon-return-store (where value)
+ "Return from a routine storing the result."
+ (malyon-store-variable where value))
+
+(defun malyon-push-initial-frame ()
+ "Push the initial stack frame required in quetzal mode."
+ (if malyon-game-state-quetzal
+ (progn
+ (malyon-push-stack 1)
+ (malyon-push-stack 0)
+ (malyon-push-stack 0)
+ (malyon-push-stack 0)
+ (malyon-push-stack 0))))
+
+(defun malyon-get-stack-frame (fp sp stack)
+ "Return a decoded stack frame in quetzal mode.
+The result is a vector containing the frame id, the fp of the
+previous frame, the sp of the previous frame, the return address,
+the result variable if any, a list of local variables, the number
+of arguments, and a list of the evaluation stack elements."
+ (let* ((has-result (zerop (aref stack fp)))
+ (result-addr (if has-result (aref stack (+ 1 fp)) nil))
+ (return-addr (aref stack (+ 2 fp)))
+ (offset (lsh (aref stack (+ 3 fp)) -8))
+ (num-args (logand 255 (aref stack (+ 3 fp))))
+ (frame-id (lsh (aref stack (+ 4 fp)) -8))
+ (num-locals (logand 255 (aref stack (+ 4 fp))))
+ (start-locals (+ 5 fp))
+ (start-eval (+ 5 fp num-locals))
+ (local-vars '())
+ (eval-stack '()))
+ (if (not (zerop num-locals))
+ (setq local-vars
+ (malyon-vector-to-list stack start-locals start-eval)))
+ (if (> sp start-eval)
+ (setq eval-stack
+ (malyon-vector-to-list stack start-eval (+ 1 sp))))
+ (vector frame-id
+ (- fp offset 2)
+ (- fp 1)
+ return-addr
+ result-addr
+ local-vars
+ num-args
+ eval-stack)))
+
+(defsubst malyon-restore-quetzal-push-stack (value)
+ "Push a value onto the restore quetzal stack."
+ (setq malyon-restore-quetzal-stack-pointer
+ (+ malyon-restore-quetzal-stack-pointer 1))
+ (aset malyon-restore-quetzal-stack
+ malyon-restore-quetzal-stack-pointer
+ value))
+
+(defun malyon-push-stack-frame
+ (frame-id return-addr result local-vars num-args eval-stack)
+ "Pushes a new stack frame in quetzal mode."
+ (malyon-restore-quetzal-push-stack (if result 0 1))
+ (malyon-restore-quetzal-push-stack (if result result 0))
+ (malyon-restore-quetzal-push-stack return-addr)
+ (malyon-restore-quetzal-push-stack
+ (logior (lsh (- malyon-restore-quetzal-stack-pointer
+ malyon-restore-quetzal-frame-pointer) 8)
+ num-args))
+ (malyon-restore-quetzal-push-stack
+ (logior (lsh frame-id 8) (length local-vars)))
+ (setq malyon-restore-quetzal-frame-pointer
+ malyon-restore-quetzal-stack-pointer)
+ (while (not (null local-vars))
+ (malyon-restore-quetzal-push-stack (car local-vars))
+ (setq local-vars (cdr local-vars)))
+ (while (not (null eval-stack))
+ (malyon-restore-quetzal-push-stack (car eval-stack))
+ (setq eval-stack (cdr eval-stack))))
+
+;; other stuff
+
+(defvar malyon-aread-text nil
+ "Text buffer for user input.")
+
+(defvar malyon-aread-parse nil
+ "Parse buffer for user input.")
+
+(defvar malyon-aread-beginning-of-line nil
+ "The beginning of the input line.")
+
+;; execution
+
+(defun malyon-interpreter ()
+ "Run the z code interpreter on the given story file."
+ (condition-case nil
+ (progn
+ (malyon-restore-window-configuration)
+ (if malyon-story-file
+ (catch 'malyon-end-of-interpreter-loop
+ (setq malyon-last-cursor-position-after-input
+ (malyon-point-max malyon-transcript-buffer))
+ (malyon-execute))))
+ (error
+ (malyon-fatal-error "unspecified internal runtime error."))))
+
+(defsubst malyon-fetch-variable-operands (specifier)
+ "Fetch a variable number of operands based on the specifier argument."
+ (let ((var (logand specifier 49152))
+ (op '()))
+ (setq specifier (logand 65535 specifier))
+ (while (/= 0 specifier)
+ (cond ((= var 0) (setq op (cons (malyon-read-code-word) op)))
+ ((= var 16384) (setq op (cons (malyon-read-code-byte) op)))
+ ((= var 32768) (setq op (cons (malyon-read-variable
+ (malyon-read-code-byte)) op)))
+ (t (setq specifier 0)))
+ (setq specifier (logand 65535 (lsh specifier 2)))
+ (setq var (logand specifier 49152)))
+ (nreverse op)))
+
+(defsubst malyon-fetch-extended (opcode)
+ "Fetch operands for an extended instruction."
+ (malyon-fetch-variable-operands
+ (logior (lsh (malyon-read-code-byte) 8) 255)))
+
+(defsubst malyon-fetch-variable (opcode)
+ "Fetch operands for a variable instruction."
+ (malyon-fetch-variable-operands
+ (if (or (= opcode 236) (= opcode 250))
+ (malyon-read-code-word)
+ (logior (lsh (malyon-read-code-byte) 8) 255))))
+
+(defsubst malyon-fetch-short (opcode)
+ "Fetch operands for a short instruction."
+ (let ((op (logand opcode 48)))
+ (cond ((= op 0) (list (malyon-read-code-word)))
+ ((= op 16) (list (malyon-read-code-byte)))
+ ((= op 32) (list (malyon-read-variable (malyon-read-code-byte)))))))
+
+(defsubst malyon-fetch-long (instr)
+ "Fetch operands for a long instruction."
+ (let ((byte1 (malyon-read-code-byte))
+ (byte2 (malyon-read-code-byte)))
+ (list (if (= (logand instr 64) 0) byte1 (malyon-read-variable byte1))
+ (if (= (logand instr 32) 0) byte2 (malyon-read-variable byte2)))))
+
+(defun malyon-execute ()
+ "Execute z code instructions.
+Load the next instruction opcode and its operands and execute it.
+Repeat ad infinitum."
+ (let ((opcode) (operands)); (pc))
+ (while t
+; (setq pc malyon-instruction-pointer)
+ (setq opcode (malyon-read-code-byte))
+ (setq operands (cond ((= opcode 190)
+ (setq opcode (+ 256 (malyon-read-code-byte)))
+ (malyon-fetch-extended opcode))
+ ((>= opcode 192)
+ (malyon-fetch-variable opcode))
+ ((>= opcode 128)
+ (malyon-fetch-short opcode))
+ (t
+ (malyon-fetch-long opcode))))
+; (malyon-trace-opcode pc opcode operands)
+ (apply (aref malyon-opcodes opcode) operands))))
+
+;; opcodes
+
+(defsubst malyon-number (n)
+ "Convert an unsigned number into a signed one."
+ (if (< n 32768) n (- n 65536)))
+
+(defun malyon-opcode-add (a b)
+ "Addition."
+ (malyon-store-variable (malyon-read-code-byte)
+ (+ (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-and (a b)
+ "Bitwise and."
+ (malyon-store-variable (malyon-read-code-byte) (logand a b)))
+
+(defun malyon-opcode-aread (text parse &optional time routine)
+ "Read input text."
+ (setq malyon-aread-text text)
+ (setq malyon-aread-parse parse)
+ (goto-char (point-max))
+ (setq malyon-aread-beginning-of-line (point))
+; Some games violate these assumptions for the "Quit" question.
+; (if (> 3 (malyon-read-byte text))
+; (malyon-fatal-error "text buffer less than 3 bytes."))
+; (if (and (not (zerop parse)) (> 2 (malyon-read-byte parse)))
+; (malyon-fatal-error "parse buffer less than 2 bytes."))
+ (malyon-more malyon-keymap-read)
+ (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
+
+(defun malyon-opcode-art-shift (value places)
+ "Arithmetic shift."
+ (malyon-store-variable (malyon-read-code-byte) (ash value places)))
+
+(defun malyon-opcode-buffer-mode (mode)
+ "Toggles buffering of text in the transcript window."
+ (setq malyon-transcript-buffer-buffered (/= 0 mode)))
+
+(defun malyon-opcode-calln (routine &rest arguments)
+ "Call a routine and ignore the result."
+ (malyon-call-routine routine arguments))
+
+(defun malyon-opcode-calls (routine &rest arguments)
+ "Call a routine and store the result."
+ (malyon-call-routine routine arguments (malyon-read-code-byte)))
+
+(defun malyon-opcode-catch ()
+ "Return the current stack frame."
+ (malyon-store-variable
+ (malyon-read-code-byte)
+ (if malyon-game-state-quetzal
+ (lsh (aref malyon-stack malyon-frame-pointer) -8)
+ malyon-frame-pointer)))
+
+(defun malyon-opcode-check-arg-count (count)
+ "Tests the number of arguments passed to routine."
+ (malyon-jump-if
+ (<= count (logand 255 (aref malyon-stack
+ (if malyon-game-state-quetzal
+ (- malyon-frame-pointer 1)
+ malyon-frame-pointer))))))
+
+(defun malyon-opcode-check-unicode (char)
+ "Check whether the given character is valid for input/output."
+ (malyon-store-variable (malyon-read-code-byte) 0))
+
+(defun malyon-opcode-clear-attr (object attribute)
+ "Clear the given attribute in the given object."
+ (let ((attributes (malyon-object-address object))
+ (byte (lsh attribute -3)))
+ (malyon-store-byte (+ attributes byte)
+ (logand (malyon-read-byte (+ attributes byte))
+ (logxor (lsh 128 (- (logand attribute 7)))
+ 255)))))
+
+(defun malyon-opcode-copy-table (first second size)
+ "Copies first table onto second one."
+ (let* ((length (abs (malyon-number size)))
+ (zero (zerop second))
+ (forward (or (< (malyon-number size) 0) (> first second)))
+ (i 0)
+ (a (if forward first (+ first length -1)))
+ (b (if forward (if zero first second) (+ second length -1))))
+ (while (< i length)
+ (malyon-store-byte b (if zero 0 (malyon-read-byte a)))
+ (setq i (+ i 1)
+ a (if forward (+ a 1) (- a 1))
+ b (if forward (+ b 1) (- b 1))))))
+
+(defun malyon-opcode-dec (var)
+ "Decrement variable."
+ (malyon-store-variable var
+ (- (malyon-number (malyon-read-variable var)) 1)))
+
+(defun malyon-opcode-dec-chk (variable threshold)
+ "Decrement variable and jump if it's less than the given value."
+ (let ((value (malyon-number (malyon-read-variable variable))))
+ (malyon-store-variable variable (- value 1))
+ (malyon-jump-if (< (- value 1) (malyon-number threshold)))))
+
+(defun malyon-opcode-div (a b)
+ "Division."
+ (if (zerop b) (malyon-fatal-error "division by 0."))
+ (malyon-store-variable (malyon-read-code-byte)
+ (/ (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-encode-text (text length from encoded)
+ "Encode the zscii text starting at from with the given length.
+The result is stored at encoded."
+ (let* ((i length)
+ (j encoded)
+ (l '())
+ (word '()))
+ (while (< 0 i)
+ (setq l (cons (malyon-read-byte (+ text from i -1)) l)
+ i (- i 1)))
+ (setq word (malyon-encode-dictionary-word
+ (append (malyon-mapcan 'malyon-encode-into-ztext l)
+ '(5 5 5 5 5 5 5 5))))
+ (while (< i 6)
+ (malyon-store-byte j (car l))
+ (setq i (+ 1 i)
+ j (+ 1 j)
+ l (cdr word)))))
+
+(defun malyon-opcode-erase-line (value)
+ "Erases the rest of the line."
+ (if (= value 1)
+ (if (eq malyon-transcript-buffer (current-buffer))
+ (kill-line nil)
+ (save-excursion
+ (let ((i (current-column)))
+ (while (<= i malyon-max-column)
+ (insert ? )
+ (delete-char 1)
+ (setq i (+ 1 i))))))))
+
+(defun malyon-opcode-erase-window (window)
+ "Erase the contents of the given window."
+ (save-excursion
+ (let ((w (malyon-number window)))
+ (if (or (= w 0) (= w -1) (= w -2))
+ (malyon-erase-buffer malyon-transcript-buffer))
+ (if (or (= w 1) (= w -1) (= w -2))
+ (malyon-erase-buffer malyon-status-buffer))
+ (if (= w -1)
+ (malyon-split-buffer-windows 0)))
+ (setq malyon-last-cursor-position-after-input
+ (malyon-point-max malyon-transcript-buffer))))
+
+(defun malyon-opcode-get-child (object)
+ "Get the first child of the given object and jump."
+ (let ((child (malyon-object-read-child (malyon-object-address object))))
+ (malyon-store-variable (malyon-read-code-byte) child)
+ (malyon-jump-if (/= 0 child))))
+
+(defun malyon-opcode-get-cursor (array)
+ "Retrieves the current cursor position."
+ (save-excursion
+ (set-buffer malyon-status-buffer)
+ (malyon-store-word array (- (count-lines (point-min) (point)) 1))
+ (malyon-store-word (+ 2 array) (+ 1 (current-column)))))
+
+(defun malyon-opcode-get-next-prop (object property)
+ "Retrieve the first or next property id of object."
+ (let ((next (malyon-first-property object))
+ (number 0))
+ (if (zerop property)
+ '()
+ (setq number (logand (malyon-read-byte next)
+ malyon-object-properties))
+ (setq next (malyon-next-property next))
+ (while (> number property)
+ (setq number (logand (malyon-read-byte next)
+ malyon-object-properties))
+ (setq next (malyon-next-property next)))
+ (if (/= number property)
+ (malyon-fatal-error "property does not exist.")))
+ (setq number (logand (malyon-read-byte next) malyon-object-properties))
+ (malyon-store-variable (malyon-read-code-byte) number)))
+
+(defun malyon-opcode-get-parent (object)
+ "Get the parent of the given object."
+ (malyon-store-variable (malyon-read-code-byte)
+ (malyon-object-read-parent
+ (malyon-object-address object))))
+
+(defun malyon-opcode-get-prop (object property)
+ "Get the value of the object's property."
+ (let* ((address (malyon-find-property object property))
+ (size (malyon-read-byte address)))
+ (malyon-store-variable
+ (malyon-read-code-byte)
+ (cond ((zerop address)
+ (malyon-read-word (+ malyon-object-table (* 2 (- property 1)))))
+ ((and (< malyon-story-version 5) (zerop (lsh size -5)))
+ (malyon-read-byte (+ address 1)))
+ ((and (>= malyon-story-version 5) (zerop (logand 192 size)))
+ (malyon-read-byte (+ address 1)))
+ (t
+ (malyon-read-word (+ address 1)))))))
+
+(defun malyon-opcode-get-prop-addr (object property)
+ "Get the address of the object's property."
+ (let* ((address (malyon-find-property object property))
+ (size (malyon-read-byte address))
+ (offset (if (< malyon-story-version 5)
+ 1
+ (if (zerop (logand 128 size)) 1 2))))
+ (malyon-store-variable (malyon-read-code-byte)
+ (if (zerop address) 0 (+ address offset)))))
+
+(defun malyon-opcode-get-prop-len (property)
+ "Get the length of the object's property."
+ (let ((size (malyon-read-byte (- property 1))))
+ (malyon-store-variable
+ (malyon-read-code-byte)
+ (cond ((< malyon-story-version 5) (+ 1 (lsh size -5)))
+ ((zerop (logand 128 size)) (+ 1 (lsh size -6)))
+ ((zerop (logand 63 size)) 64)
+ (t (logand 63 size))))))
+
+(defun malyon-opcode-get-sibling (object)
+ "Get the next object in the tree and jump."
+ (let ((sibling (malyon-object-read-sibling (malyon-object-address object))))
+ (malyon-store-variable (malyon-read-code-byte) sibling)
+ (malyon-jump-if (/= 0 sibling))))
+
+(defun malyon-opcode-illegal (&rest ignore)
+ "Print an error message and exit the interpreter."
+ (malyon-fatal-error "illegal opcode."))
+
+(defun malyon-opcode-inc (var)
+ "Increment variable."
+ (malyon-store-variable var
+ (+ (malyon-number (malyon-read-variable var)) 1)))
+
+(defun malyon-opcode-inc-chk (variable threshold)
+ "Increment variable and jump if it's greater than the given value."
+ (let ((value (malyon-number (malyon-read-variable variable))))
+ (malyon-store-variable variable (+ value 1))
+ (malyon-jump-if (> (+ value 1) (malyon-number threshold)))))
+
+(defun malyon-opcode-input-stream (number)
+ "Select the given input stream. Only the keyboard is supported."
+ (if (zerop (malyon-number number))
+ '()
+ (message "Only the keyboard is supported as an input stream.")))
+
+(defun malyon-opcode-insert-obj (object destination)
+ "Insert an object into the children list of another."
+ (let ((child (malyon-object-address object))
+ (parent (malyon-object-address destination)))
+ (malyon-remove-object object)
+ (malyon-object-store-parent child destination)
+ (malyon-object-store-sibling child (malyon-object-read-child parent))
+ (malyon-object-store-child parent object)))
+
+(defun malyon-opcode-je (a &rest rest)
+ "Jump if first operand equals any of the following."
+ (malyon-jump-if (member (malyon-number a) (mapcar 'malyon-number rest))))
+
+(defun malyon-opcode-jg (a b)
+ "Jump if first operand > second operand."
+ (malyon-jump-if (> (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-jin (child parent)
+ "Jump if second object is parent of the first one."
+ (malyon-jump-if
+ (= parent (malyon-object-read-parent (malyon-object-address child)))))
+
+(defun malyon-opcode-jl (a b)
+ "Jump if first operand < second operand."
+ (malyon-jump-if (< (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-jump (offset)
+ "Jump unconditionally."
+ (setq malyon-instruction-pointer (+ malyon-instruction-pointer
+ (malyon-number offset) -2)))
+
+(defun malyon-opcode-jz (a)
+ "Jump if operand = 0."
+ (malyon-jump-if (zerop a)))
+
+(defun malyon-opcode-load (variable)
+ "Load a variable."
+ (malyon-store-variable (malyon-read-code-byte)
+ (malyon-read-variable variable)))
+
+(defun malyon-opcode-loadb (array index)
+ "Load an array element into a variable."
+ (malyon-store-variable (malyon-read-code-byte)
+ (malyon-read-byte (+ array index))))
+
+(defun malyon-opcode-loadw (array index)
+ "Load an array element into a variable."
+ (malyon-store-variable (malyon-read-code-byte)
+ (malyon-read-word (+ array (* 2 index)))))
+
+(defun malyon-opcode-log-shift (value places)
+ "Logical shift."
+ (malyon-store-variable (malyon-read-code-byte) (lsh value places)))
+
+(defun malyon-opcode-mod (a b)
+ "Modulo."
+ (malyon-store-variable (malyon-read-code-byte)
+ (mod (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-mul (a b)
+ "Multiplication."
+ (malyon-store-variable (malyon-read-code-byte)
+ (* (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-new-line ()
+ "Print a newline."
+ (malyon-newline))
+
+(defun malyon-opcode-nop (&rest ignore)
+ "Do nothing.")
+
+(defun malyon-opcode-not (a)
+ "Bitwise not."
+ (malyon-store-variable (malyon-read-code-byte) (logand 65535 (lognot a))))
+
+(defun malyon-opcode-or (a b)
+ "Bitwise or."
+ (malyon-store-variable (malyon-read-code-byte) (logior a b)))
+
+(defun malyon-opcode-output-stream (stream &optional table)
+ "Select an output stream."
+ (let ((stream (malyon-number stream)))
+ (cond ((< 0 stream) (malyon-add-output-stream stream table))
+ ((> 0 stream) (malyon-remove-output-stream (- stream))))))
+
+(defun malyon-opcode-piracy ()
+ "Piracy check, effectively an unconditional jump."
+ (malyon-jump-if 1))
+
+(defun malyon-opcode-pop ()
+ "Pop a value off the stack."
+ (malyon-pop-stack))
+
+(defun malyon-opcode-print ()
+ "Print a string."
+ (setq malyon-instruction-pointer
+ (malyon-print-text malyon-instruction-pointer)))
+
+(defun malyon-opcode-print-addr (address)
+ "Print a string."
+ (malyon-print-text address))
+
+(defun malyon-opcode-print-char (c)
+ "Print a character."
+ (malyon-print (char-to-string c)))
+
+(defun malyon-opcode-print-num (n)
+ "Print a number."
+ (malyon-print (number-to-string (malyon-number n))))
+
+(defun malyon-opcode-print-obj (obj)
+ "Print the short name of the object."
+ (malyon-print-text
+ (+ 1 (malyon-read-word (+ malyon-object-property-offset
+ (malyon-object-address obj))))))
+
+(defun malyon-opcode-print-paddr (address)
+ "Print a string."
+ (malyon-print-text (* malyon-packed-multiplier address)))
+
+(defun malyon-opcode-print-ret ()
+ "Print a string, print a newline, return true/1."
+ (setq malyon-instruction-pointer
+ (malyon-print-text malyon-instruction-pointer))
+ (malyon-newline)
+ (malyon-return 1))
+
+(defun malyon-opcode-print-table (text width &optional height skip)
+ "Print the given table."
+ (if (not height) (setq height 1))
+ (if (not skip) (setq skip 0))
+ (let ((column (current-column))
+ (address text)
+ (y 0)
+ (x 0))
+ (while (< y height)
+ (if (zerop y)
+ '()
+ (malyon-newline)
+ (malyon-print-characters (make-string column ? )))
+ (setq x 0)
+ (while (< x width)
+ (malyon-output-character (malyon-read-byte address))
+ (setq address (+ 1 address))
+ (setq x (+ 1 x)))
+ (setq address (+ skip address))
+ (setq y (+ 1 y)))))
+
+(defun malyon-opcode-print-unicode (char)
+ "Prints a unicode character.")
+
+(defun malyon-opcode-pull (variable)
+ "Pull value off stack."
+ (malyon-store-variable variable (malyon-pop-stack)))
+
+(defun malyon-opcode-push (value)
+ "Push value onto stack."
+ (malyon-push-stack value))
+
+(defun malyon-opcode-put-prop (object property value)
+ "Set the object's property to the given value."
+ (let* ((address (malyon-find-property object property))
+ (size (malyon-read-byte address)))
+ (cond ((= address 0)
+ (malyon-fatal-error "property does not exist."))
+ ((and (< malyon-story-version 5) (zerop (lsh size -5)))
+ (malyon-store-byte (+ 1 address) (logand 255 value)))
+ ((and (>= malyon-story-version 5) (zerop (logand size 192)))
+ (malyon-store-byte (+ 1 address) (logand 255 value)))
+ (t
+ (malyon-store-word (+ 1 address) value)))))
+
+(defun malyon-opcode-quit ()
+ "End the game immediately."
+ (malyon-adjust-transcript)
+ (malyon-cleanup)
+ (throw 'malyon-end-of-interpreter-loop 'malyon-opcode-quit))
+
+(defun malyon-opcode-random (limit)
+ "Generate a random number or set the seed value."
+ (malyon-store-variable (malyon-read-code-byte)
+ (if (>= 0 (malyon-number limit))
+ 0
+ (+ 1 (random (malyon-number limit))))))
+
+(defun malyon-opcode-read-char (&optional device &rest ignore)
+ "Read a character."
+ (if (and device (/= 1 device))
+ (malyon-fatal-error "illegal device specified in read_char."))
+ (if (eq malyon-transcript-buffer (current-buffer))
+ (goto-char (point-max)))
+ (message "[Press a key.]")
+ (malyon-more malyon-keymap-readchar)
+ (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-character))
+
+(defun malyon-opcode-remove-obj (object)
+ "Remove an object from its parent's children list."
+ (malyon-remove-object object))
+
+(defun malyon-opcode-restart ()
+ "Restart the game."
+ (malyon-set-game-state malyon-game-state-restart))
+
+(defun malyon-opcode-restore (&optional table bytes name)
+ "Restore a saved game state or a section of memory from a file."
+ (let ((result (if name
+ (malyon-restore-file
+ (malyon-get-file-name name) table bytes)
+ (call-interactively 'malyon-restore-file))))
+ (if (< malyon-story-version 5)
+ (malyon-jump-if (not (zerop result)))
+ (malyon-store-variable (malyon-read-code-byte) result))))
+
+(defun malyon-opcode-restore-undo ()
+ "Restore game state for undo."
+ (if malyon-game-state-undo
+ (malyon-set-game-state malyon-game-state-undo))
+ (malyon-store-variable (malyon-read-code-byte) 2))
+
+(defun malyon-opcode-ret (value)
+ "Return a value."
+ (malyon-return value))
+
+(defun malyon-opcode-ret-popped ()
+ "Return top of stack."
+ (malyon-return (malyon-pop-stack)))
+
+(defun malyon-opcode-rfalse ()
+ "Return false/0."
+ (malyon-return 0))
+
+(defun malyon-opcode-rtrue ()
+ "Return true/1."
+ (malyon-return 1))
+
+(defun malyon-opcode-save (&optional table bytes name)
+ "Save the current game state or a section of memory to a file."
+ (let ((result (if name
+ (malyon-save-file (malyon-get-file-name name) table bytes)
+ (call-interactively 'malyon-save-file))))
+ (if (< malyon-story-version 5)
+ (malyon-jump-if (not (zerop result)))
+ (malyon-store-variable (malyon-read-code-byte) result))))
+
+(defun malyon-opcode-save-undo ()
+ "Save game state for undo."
+ (setq malyon-game-state-undo (malyon-current-game-state))
+ (malyon-store-byte (malyon-read-code-byte) 1))
+
+(defun malyon-opcode-scan-table (x table len &optional form)
+ "Scan the given table for the first occurrence of x."
+ (if (not form) (setq form 130))
+ (let ((inc (logand 127 form))
+ (byte (zerop (logand 128 form)))
+ (addr table)
+ (found 0)
+ (index 0))
+ (while (and (zerop found) (< index len))
+ (setq found
+ (if byte
+ (if (= x (malyon-read-byte addr)) addr 0)
+ (if (= x (malyon-read-word addr)) addr 0)))
+ (setq addr (+ addr inc))
+ (setq index (+ index 1)))
+ (malyon-store-variable (malyon-read-code-byte) found)
+ (malyon-jump-if (not (zerop found)))))
+
+(defun malyon-opcode-set-attr (object attribute)
+ "Set the given attribute in the given object."
+ (let ((attributes (malyon-object-address object))
+ (byte (lsh attribute -3)))
+ (malyon-store-byte (+ attributes byte)
+ (logior (malyon-read-byte (+ attributes byte))
+ (lsh 128 (- (logand attribute 7)))))))
+
+(defun malyon-opcode-set-color (foreground background)
+ "Sets the fore- and background colors ie. does nothing.")
+
+(defun malyon-opcode-set-cursor (&optional line column)
+ "Set the cursor."
+ (if (eq malyon-transcript-buffer (current-buffer))
+ (goto-char (point-max))
+ (if malyon-status-buffer-delayed-split
+ (progn
+ (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
+ (other-window 1)))
+ (if line '() (setq line (count-lines (point-min) (point))))
+ (if column '() (setq column (current-column)))
+ (if (> line malyon-status-buffer-lines)
+ (progn
+ (malyon-split-buffer-windows line)
+ (other-window 1)))
+ (goto-char (point-min))
+ (if (and (<= 1 line) (<= line malyon-status-buffer-lines))
+ (forward-line line)
+ (beginning-of-line))
+ (if (and (<= 1 column) (<= column malyon-max-column))
+ (forward-char (- column 1))
+ (beginning-of-line))
+ (setq malyon-status-buffer-point (point))))
+
+(defun malyon-opcode-set-font (font)
+ "Sets the font if available or 0 otherwise."
+ (malyon-store-variable (malyon-read-code-byte) 0))
+
+(defun malyon-opcode-set-text-style (style)
+ "Set the text style/face."
+ (let ((face (assq style malyon-faces)))
+ (setq malyon-current-face (if face (cdr face) 'malyon-face-plain))))
+
+(defun malyon-opcode-set-window (window)
+ "Set the current window."
+ (malyon-restore-window-configuration)
+ (setq malyon-current-window window)
+ (malyon-update-output-streams)
+ (if (zerop window)
+ (if (not (eq malyon-transcript-buffer (current-buffer)))
+ (other-window 1))
+ (if (not (eq malyon-status-buffer (current-buffer)))
+ (other-window 1))
+ (malyon-opcode-set-cursor 1 1)))
+
+(defun malyon-opcode-show-status ()
+ "Display the status line."
+ (save-excursion
+ (malyon-opcode-split-window 1)
+ (malyon-restore-window-configuration)
+ (malyon-opcode-set-window 1)
+ (malyon-prepare-status-buffer 1)
+ (malyon-opcode-set-cursor 1 1)
+ (malyon-opcode-print-obj (malyon-read-global-variable 0))
+ (if (<= (current-column) (- (current-fill-column) 10))
+ (let* ((x (malyon-read-global-variable 1))
+ (y (malyon-read-global-variable 2))
+ (hours (if (> x 12) (- x 12) x))
+ (ampm (if (> x 12) "PM" "AM"))
+ (score (format "%4d/%4d" x y))
+ (time (format "%02d:%02d%s" hours y ampm)))
+ (malyon-opcode-set-cursor 1 (- (current-fill-column) 10))
+ (malyon-print (if malyon-score-game score time))))
+ (malyon-opcode-set-window 0)
+ (malyon-adjust-transcript)))
+
+(defun malyon-opcode-split-window (size)
+ "Split upper and lower window."
+ (malyon-set-window-configuration size))
+
+(defun malyon-opcode-store (variable value)
+ "Store a value in a variable."
+ (malyon-store-variable variable value))
+
+(defun malyon-opcode-storeb (array index value)
+ "Store a value in an array at the given index."
+ (malyon-store-byte (+ array index) value))
+
+(defun malyon-opcode-storew (array index value)
+ "Store a value in an array at the given index."
+ (malyon-store-word (+ array (* 2 index)) value))
+
+(defun malyon-opcode-sub (a b)
+ "Subtraction."
+ (malyon-store-variable (malyon-read-code-byte)
+ (- (malyon-number a) (malyon-number b))))
+
+(defun malyon-opcode-test (bitmap flags)
+ "Test if all of the flags are set in the bitmap."
+ (malyon-jump-if (= flags (logand bitmap flags))))
+
+(defun malyon-opcode-test-attr (object attribute)
+ "Jump depending on the given attribute in the given object."
+ (malyon-jump-if
+ (/= 0 (logand (malyon-read-byte (+ (malyon-object-address object)
+ (lsh attribute -3)))
+ (lsh 128 (- (logand attribute 7)))))))
+
+(defun malyon-opcode-throw (value frame)
+ "Return from the given stack frame."
+ (if malyon-game-state-quetzal
+ (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
+ (while (/= frame id)
+ (setq malyon-stack-pointer malyon-frame-pointer)
+ (malyon-pop-stack)
+ (setq malyon-frame-pointer
+ (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
+ (malyon-pop-stack)
+ (malyon-pop-stack)
+ (setq id (lsh (aref malyon-stack malyon-frame-pointer) -8))))
+ (setq malyon-frame-pointer frame))
+ (malyon-return value))
+
+(defun malyon-opcode-tokenise (text parse &optional dict flag)
+ "Perform lexical analysis on the text buffer."
+ (let* ((words (malyon-text-to-words text dict))
+ (word (car words))
+ (start (car word))
+ (len (malyon-cadr word))
+ (code (malyon-caddr word))
+ (entry (malyon-lookup dict code))
+ (i 0))
+ (while (not (or (null words) (= i (malyon-read-byte parse))))
+ (if (and (zerop entry) flag (/= 0 flag))
+ '()
+ (malyon-store-word (+ 2 parse (* 4 i)) entry)
+ (malyon-store-byte (+ 4 parse (* 4 i)) len)
+ (malyon-store-byte (+ 5 parse (* 4 i)) start))
+ (setq words (cdr words)
+ word (car words)
+ start (car word)
+ len (malyon-cadr word)
+ code (malyon-caddr word)
+ entry (malyon-lookup dict code)
+ i (+ 1 i)))
+ (malyon-store-byte (+ 1 parse) i)))
+
+(defun malyon-opcode-verify ()
+ "Verify the correctness of the story file."
+ (let ((length (+ 1 (* malyon-packed-multiplier (malyon-read-word 26))))
+ (sum 0)
+ (i 64))
+ (while (< i length)
+ (setq sum (mod (+ sum (malyon-read-byte i)) 65536)
+ i (+ 1 i)))
+ (malyon-jump-if (= (malyon-read-word 28) sum))))
+
+;; keymap utilities
+
+(defun malyon-end-input ()
+ "Store the input line in a text buffer and perform lexical analysis."
+ (interactive)
+ (condition-case nil
+ (progn
+ (malyon-adjust-transcript)
+ (switch-to-buffer malyon-transcript-buffer)
+ (goto-char (point-max))
+ (let* ((input (downcase
+ (buffer-substring-no-properties
+ (if (< malyon-aread-beginning-of-line (point))
+ malyon-aread-beginning-of-line
+ (point))
+ (point))))
+ (vec (malyon-string-to-vector input))
+ (text (apply 'vector (mapcar 'malyon-unicode-to-zscii vec)))
+ (len (min (malyon-read-byte malyon-aread-text) (length text)))
+ (i 0))
+ (malyon-history-insert input)
+ (if (>= malyon-story-version 5)
+ (malyon-store-byte (+ malyon-aread-text 1) len))
+ (while (< i len)
+ (malyon-store-byte
+ (+ malyon-aread-text (if (< malyon-story-version 5) 1 2) i)
+ (malyon-char-to-int (aref text i)))
+ (setq i (+ 1 i)))
+ (if (< malyon-story-version 5)
+ (malyon-store-byte (+ malyon-aread-text 1 len) 0)))
+ (if (/= 0 malyon-aread-parse)
+ (malyon-opcode-tokenise malyon-aread-text malyon-aread-parse))
+ (newline)
+ (if (>= malyon-story-version 5)
+ (malyon-store-variable (malyon-read-code-byte) 10))
+ (malyon-interpreter))
+ (error
+ (malyon-fatal-error "unspecified internal runtime error."))))
+
+(defun malyon-more-char ()
+ "Page down in More mode."
+ (interactive)
+ (condition-case nil
+ (scroll-up)
+ (error))
+ (if (>= (count-lines (point) (point-max))
+ (malyon-window-displayed-height))
+ (message "[More]")
+ (goto-char (point-max))
+ (malyon-adjust-transcript)
+ (use-local-map malyon-more-continue-keymap)))
+
+(defun malyon-more-char-status ()
+ "Wait for a key then continue."
+ (interactive)
+ (condition-case nil
+ (progn
+ (malyon-adjust-transcript)
+ (use-local-map malyon-more-continue-keymap)
+ (malyon-interpreter))
+ (error
+ (malyon-fatal-error "unspecified internal runtime error."))))
+
+(defun malyon-wait-char ()
+ "Store the input character in a variable and resume execution."
+ (interactive)
+ (condition-case nil
+ (progn
+ (malyon-store-variable
+ (malyon-read-code-byte)
+ (malyon-char-to-int (malyon-unicode-to-zscii last-command-char)))
+ (use-local-map malyon-keymap-read)
+ (malyon-interpreter))
+ (error
+ (malyon-fatal-error "unspecified internal runtime error."))))
+
+(defun malyon-history-previous-char (arg)
+ "Display the previous item in the input history."
+ (interactive "p")
+ (let ((input (malyon-history-previous)))
+ (cond ((> malyon-aread-beginning-of-line (point))
+ (funcall malyon-history-saved-up arg))
+ (input
+ (save-excursion
+ (set-buffer malyon-transcript-buffer)
+ (delete-region malyon-aread-beginning-of-line (point-max)))
+ (goto-char (point-max))
+ (insert input)
+ (malyon-adjust-transcript)))))
+
+(defun malyon-history-next-char (arg)
+ "Display the next item in the input history."
+ (interactive "p")
+ (let ((input (malyon-history-next)))
+ (cond ((> malyon-aread-beginning-of-line (point))
+ (funcall malyon-history-saved-down arg))
+ (input
+ (save-excursion
+ (set-buffer malyon-transcript-buffer)
+ (delete-region malyon-aread-beginning-of-line (point-max)))
+ (goto-char (point-max))
+ (insert input)
+ (malyon-adjust-transcript)))))
+
+(defun malyon-beginning-of-line (arg)
+ "Go to the beginning of the line."
+ (interactive "p")
+ (if (> malyon-aread-beginning-of-line (point))
+ (beginning-of-line)
+ (goto-char malyon-aread-beginning-of-line)))
+
+(defun malyon-kill-region (arg)
+ "Kill region."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (kill-region (point) (mark))
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-kill-line (arg)
+ "Kill rest of the current line."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (kill-line)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-kill-word (arg)
+ "Kill the current word."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (kill-word 1)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-yank (arg)
+ "Yank."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (yank)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-yank-pop (arg)
+ "Yank pop."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (yank-pop 1)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-delete-char (arg)
+ "Delete a character."
+ (interactive "p")
+ (if (<= malyon-aread-beginning-of-line (point))
+ (delete-char 1)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-backward-delete-char (arg)
+ "Delete a character backwards."
+ (interactive "p")
+ (if (< malyon-aread-beginning-of-line (point))
+ (backward-delete-char-untabify 1)
+ (message "Editing is restricted to the input prompt.")))
+
+(defun malyon-self-insert-command (arg)
+ "Insert a character."
+ (interactive "p")
+ (if (> malyon-aread-beginning-of-line (point))
+ (goto-char (point-max)))
+ (self-insert-command 1))
+
+;; tracing utility
+
+(defun malyon-trace-file ()
+ "Turn tracing on for a particular file."
+ (let ((trace
+ (get-buffer-create
+ (concat "Malyon Trace " malyon-story-file-name))))
+ (if trace
+ (save-excursion
+ (set-buffer trace)
+ (malyon-erase-buffer)
+ (insert (concat "Tracing " malyon-story-file-name "..."))
+ (newline)))))
+
+(defun malyon-trace-newline ()
+ "Output tracing newline."
+ (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
+ (if trace
+ (save-excursion
+ (set-buffer trace)
+ (goto-char (point-max))
+ (newline)))))
+
+(defun malyon-trace-opcode (pc opcode operands)
+ "Output a z code instruction."
+ (malyon-trace-string
+ (format "%8d %-3d %-25s %s\n"
+ pc
+ opcode
+ (symbol-name (aref malyon-opcodes opcode))
+ (apply 'concat (malyon-mapcan
+ (lambda (x)
+ (list " "
+ (number-to-string
+ (if (malyon-characterp x)
+ (malyon-char-to-int x)
+ x))))
+ operands)))))
+
+(defun malyon-trace-string (s)
+ "Output tracing string."
+ (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
+ (if (and trace s)
+ (save-excursion
+ (set-buffer trace)
+ (goto-char (point-max))
+ (insert s)))))
+
+(defun malyon-trace-object (o)
+ "Output tracing object."
+ (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
+ (if (and trace o)
+ (save-excursion
+ (set-buffer trace)
+ (goto-char (point-max))
+ (prin1 o trace)))))
+
+;;; announce malyon-mode
+
+(provide 'malyon-mode)
+(provide 'malyon)
+
+;;; malyon-mode.el ends here
--- /dev/null
+;;; org-mac-protocol.el -- process events triggered by the
+;;; org-mac-protocol suite of AppleScripts
+
+;; Copyright (C) 2009, 2010 Christopher Suckling
+
+;; Authors: Christopher Suckling <suckling at gmail dot com>
+
+;; 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.
+
+;; It is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+;; License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;; Version: 0.634
+;; Keywords: outlines, hyperlinks, wp
+
+;;; Commentary
+;;
+;; This file provides org-protocol handlers and various hacks to
+;; produce a nicely centered, pop-up remember frame for links passed
+;; to emacsclient by the org-mac-protocol suite of AppleScripts. It
+;; also defines new org-mode hyperlink types for opening files in
+;; various OS X applications.
+
+;;; Installation and Usage
+;;
+;; Please see org-mac-protocol.org
+
+;;; Credit
+;;
+;; Portions of this code are developed from a blog post by Jack Moffitt:
+;; http://metajack.im/2008/12/30/gtd-capture-with-emacs-orgmode/
+
+(require 'cl)
+(require 'org-protocol)
+(require 'org-bibtex)
+
+;;; Define org-mode hyperlink types
+;;
+;; BibDesk
+
+(org-add-link-type "bibdesk" 'org-mac-bibdesk-open)
+
+(defun org-mac-bibdesk-open (uri)
+ "Visit bibtex entry in BibDesk"
+ (let* ((key (when (string-match "::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"BibDesk.app\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set theKey to \"" key "\"\n"
+ "open theDoc\n"
+ "tell document 1 of application \"BibDesk\"\n"
+ "set somePubs to (publications whose cite key contains theKey)\n"
+ "set the selection to somePubs\n"
+ "set theSelection to the selection\n"
+ "set thePub to get item 1 of theSelection\n"
+ "show thePub\n"
+ "end tell\n"
+ "end tell"))))
+
+;; Skim
+
+(org-add-link-type "skim" 'org-mac-skim-open)
+
+(defun org-mac-skim-open (uri)
+ "Visit page of pdf in Skim"
+ (let* ((page (when (string-match "::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"Skim\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set thePage to " page "\n"
+ "open theDoc\n"
+ "go document 1 to page thePage of document 1\n"
+ "end tell"))))
+
+;; Pages
+
+(org-add-link-type "pages" 'org-mac-pages-open)
+
+(defun org-mac-pages-open (uri)
+ "Visit page of document in Pages. Reliant on character offset
+from start of document, so link may degrade if document is
+edited"
+ (let* ((charoff (when (string-match "::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"Pages\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set theCharOff to " charoff "\n"
+ "open theDoc\n"
+ "select character theCharOff of document 1\n"
+ "end tell"))))
+
+;; Numbers
+
+(org-add-link-type "numbers" 'org-mac-numbers-open)
+
+(defun org-mac-numbers-open (uri)
+ "Visit range of spreadsheet in Numbers. Although the correct
+cells will be selected, it may be necessary to change sheets
+manually"
+ (let* ((sheet (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (table (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
+ (org-protocol-unhex-string (match-string 2 uri))))
+ (range (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
+ (match-string 3 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"Numbers\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set theSheet to \"" sheet "\"\n"
+ "set theTable to \"" table "\"\n"
+ "set theRange to \"" range "\"\n"
+ "open theDoc\n"
+ "tell document 1\n"
+ "tell sheet (theSheet as integer)\n"
+ "tell table theTable\n"
+ "set selection range to range theRange\n"
+ "end tell\n"
+ "end tell\n"
+ "end tell\n"
+ "end tell"))))
+
+
+;; Keynote
+
+(org-add-link-type "keynote" 'org-mac-keynote-open)
+
+(defun org-mac-keynote-open (uri)
+ "Visit slide in Keynote"
+ (let* ((slide (when (string-match "::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"Keynote\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set theSlide to " slide "\n"
+ "open theDoc\n"
+ "show slide theSlide of slideshow 1\n"
+ "end tell"))))
+
+
+;; iTunes
+
+(org-add-link-type "iTunes" 'org-mac-iTunes-open)
+
+(defun org-mac-iTunes-open (uri)
+ "Visit track in iTunes"
+ (let* ((track (when (string-match "[0-9a-zA-Z]+\\'" uri)
+ (match-string 0 uri))))
+ (do-applescript
+ (concat
+ "tell application \"iTunes\"\n"
+ "activate\n"
+ "set theTrack to \"" track "\"\n"
+ "set view of front browser window to user playlist \"Music\" of source \"Library\"\n"
+ "play (some track of playlist \"Music\" of source \"Library\" whose persistent ID is theTrack)\n"
+ "playpause\n"
+ "end tell"
+ ))))
+
+
+;; Address Book
+;; Support based on code by Alexander Poslavsky
+
+(org-add-link-type "address" 'org-mac-addressbook-open)
+
+(defun org-mac-addressbook-open (uri)
+ "Applescript to open correct address-book entry"
+ (do-applescript
+ (concat
+ "set theID to \"" uri "\"\n"
+
+ "tell application \"System Events\"\n"
+ "activate\n"
+ "try\n"
+ "open location \"addressbook\:\/\/\" \& theID\n"
+ "on error\n"
+ "display dialog \"no matching contact found\"\n"
+ "end try\n"
+ "end tell"
+ )))
+
+
+;;; Variables and advice for managing *remember* frames
+
+;; updated for org-capture hooks
+
+(defvar width-of-display (x-display-pixel-width)
+ "For some reason, (x-display-pixel-width) returns corrupted
+values when called during (org-mac-protocol-remember); this
+ensures that correct value is returned")
+(setq width-of-display (x-display-pixel-width))
+
+(defvar height-of-display (x-display-pixel-height)
+ "For some reason, (x-display-pixel-height) returns corrupted
+values when called during (org-mac-protocol-remember); this
+ensures that correct value is returned")
+(setq height-of-display (x-display-pixel-height))
+
+(defvar org-mac-protocol-app nil
+ "The application that AppleScript will activate
+after the *remember* buffer is killed")
+
+(defadvice remember-finalize (after delete-remember-frame activate)
+ "Advise remember-finalize to close the frame if it is the mac-remember frame"
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (mapc
+ (lambda (x)
+ (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
+ (make-frame-visible x)))
+ (frame-list))
+ (mapc
+ (lambda (x)
+ (when (equal (frame-parameter x 'name) "*mac-remember*")
+ (delete-frame x)))
+ (frame-list))
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-protocol-app "\"\n"
+ "activate\n"
+ "end tell"))))
+
+(defadvice remember-destroy (after delete-remember-frame activate)
+ "Advise remember-destroy to close the frame if it is the
+mac-rememeber frame"
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (mapc
+ (lambda (x)
+ (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
+ (make-frame-visible x)))
+ (frame-list))
+ (mapc
+ (lambda (x)
+ (when (equal (frame-parameter x 'name) "*mac-remember*")
+ (delete-frame x)))
+ (frame-list))
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-protocol-app "\"\n"
+ "activate\n"
+ "end tell"))))
+
+(defadvice org-remember-apply-template (before delete-non-remember-windows activate)
+ "Advise org-remember to delete non-remember windows if it is in
+the remember frame"
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (delete-other-windows)))
+
+(add-hook 'org-capture-mode-hook
+ '(lambda ()
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (delete-other-windows))))
+
+(add-hook 'org-capture-after-finalize-hook
+ '(lambda ()
+ (unless (boundp 'org-refile-for-capture)
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (mapc
+ (lambda (x)
+ (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
+ (make-frame-visible x)))
+ (frame-list))
+ (mapc
+ (lambda (x)
+ (when (equal (frame-parameter x 'name) "*mac-remember*")
+ (delete-frame x)))
+ (frame-list))
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-protocol-app "\"\n"
+ "activate\n"
+ "end tell"))))))
+
+(add-hook 'org-after-refile-insert-hook
+ '(lambda ()
+ (when (boundp 'org-refile-for-capture)
+ (when (equal "*mac-remember*" (frame-parameter nil 'name))
+ (mapc
+ (lambda (x)
+ (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
+ (make-frame-visible x)))
+ (frame-list))
+ (mapc
+ (lambda (x)
+ (when (equal (frame-parameter x 'name) "*mac-remember*")
+ (delete-frame x)))
+ (frame-list))
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-protocol-app "\"\n"
+ "activate\n"
+ "end tell"))))))
+
+;;; Define org-protocol protocols
+
+(add-to-list 'org-protocol-protocol-alist
+ '("org-mac-remember"
+ :protocol "mac-remember"
+ :function org-mac-protocol-remember
+ :kill-client t))
+
+(add-to-list 'org-protocol-protocol-alist
+ '("org-mac-safari-tabs"
+ :protocol "safari-tabs"
+ :function org-mac-safari-tabs
+ :kill-client t))
+
+(defun org-mac-protocol-remember (data)
+ "Process an org-protocol://mac-remember:// scheme URL.
+Pop up a small, centred Emacs frame containing a remember
+buffer. Destroys the frame after the remember buffer is filed and
+return to originating application. This code is
+essentially (org-protocol-remember) with an additional :shortdesc
+link property"
+
+ (let* ((elements (org-protocol-split-data data nil ":"))
+ (info (car elements))
+ (app (org-protocol-unhex-string (cadr elements)))
+ (parts (org-protocol-split-data info t))
+ (template (or (and (= 1 (length (car parts))) (pop parts))
+ org-protocol-default-template-key))
+ (url (org-protocol-sanitize-uri (car parts)))
+ (type (if (string-match "^\\([a-z]+\\):" url)
+ (match-string 1 url)))
+ (title (or (cadr parts) ""))
+ (shorttitle (or (caddr parts) ""))
+ (region (or (cadddr parts) ""))
+ (orglink (org-make-link-string
+ url (if (string-match "[^[:space:]]" title) title url)))
+ (org-capture-link-is-already-stored t)
+ remember-annotation-functions)
+
+ (setq org-mac-protocol-app app)
+
+ (do-applescript
+ (concat
+ "tell application \"Emacs\"\n"
+ "activate\n"
+ "end tell"))
+
+ (make-frame '((name . "*mac-remember*") (width . 80) (height . 20)))
+ (mapc (lambda (x)
+ (if (not (equal (frame-parameter x 'name) "*mac-remember*"))
+ (make-frame-invisible x)
+ (let ((center-left
+ (/ (- width-of-display (frame-pixel-width)) 2))
+ (center-top
+ (/ (- (- height-of-display 22) (frame-pixel-height)) 2)))
+ (set-frame-parameter nil 'top center-top)
+ (set-frame-parameter nil 'left center-left))))
+ (frame-list))
+ (select-frame-by-name "*mac-remember*")
+
+ (setq org-stored-links
+ (cons (list url title) org-stored-links))
+ (kill-new orglink)
+ (org-store-link-props :type type
+ :link url
+ :description title
+ :shortdesc shorttitle
+ :initial region)
+ (message "protocol: %s" (plist-get org-store-link-plist :shortdesc))
+
+ (if (boundp 'org-capture-templates)
+ (org-capture nil template)
+ (org-remember nil (string-to-char template))))
+ nil)
+
+(defun org-mac-safari-tabs (data)
+ "Process an org-protocol://safari-tabs:// scheme URL.
+Inserts a formatted list of hyperlinks to the tabs open in the
+front Safari window"
+ (let* ((elements (org-protocol-split-data data nil "::"))
+ ;; discard the last element, as it is blank
+ (links (butlast elements)))
+ (mapc (lambda (x)
+ (org-protocol-store-link x))
+ links))
+ nil)
+
+
+(provide 'org-mac-protocol)
--- /dev/null
+;;; package.el --- Simple package system for Emacs
+
+;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
+
+;; Author: Tom Tromey <tromey@redhat.com>
+;; Created: 10 Mar 2007
+;; Version: 1.0
+;; Keywords: tools
+;; Package-Requires: ((tabulated-list "0"))
+
+;; 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/>.
+
+;;; Change Log:
+
+;; 2 Apr 2007 - now using ChangeLog file
+;; 15 Mar 2007 - updated documentation
+;; 14 Mar 2007 - Changed how obsolete packages are handled
+;; 13 Mar 2007 - Wrote package-install-from-buffer
+;; 12 Mar 2007 - Wrote package-menu mode
+
+;;; Commentary:
+
+;; The idea behind package.el is to be able to download packages and
+;; install them. Packages are versioned and have versioned
+;; dependencies. Furthermore, this supports built-in packages which
+;; may or may not be newer than user-specified packages. This makes
+;; it possible to upgrade Emacs and automatically disable packages
+;; which have moved from external to core. (Note though that we don't
+;; currently register any of these, so this feature does not actually
+;; work.)
+
+;; A package is described by its name and version. The distribution
+;; format is either a tar file or a single .el file.
+
+;; A tar file should be named "NAME-VERSION.tar". The tar file must
+;; unpack into a directory named after the package and version:
+;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el"
+;; which consists of a call to define-package. It may also contain a
+;; "dir" file and the info files it references.
+
+;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
+;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
+
+;; The downloader downloads all dependent packages. By default,
+;; packages come from the official GNU sources, but others may be
+;; added by customizing the `package-archives' alist. Packages get
+;; byte-compiled at install time.
+
+;; At activation time we will set up the load-path and the info path,
+;; and we will load the package's autoloads. If a package's
+;; dependencies are not available, we will not activate that package.
+
+;; Conceptually a package has multiple state transitions:
+;;
+;; * Download. Fetching the package from ELPA.
+;; * Install. Untar the package, or write the .el file, into
+;; ~/.emacs.d/elpa/ directory.
+;; * Byte compile. Currently this phase is done during install,
+;; but we may change this.
+;; * Activate. Evaluate the autoloads for the package to make it
+;; available to the user.
+;; * Load. Actually load the package and run some code from it.
+
+;; Other external functions you may want to use:
+;;
+;; M-x list-packages
+;; Enters a mode similar to buffer-menu which lets you manage
+;; packages. You can choose packages for install (mark with "i",
+;; then "x" to execute) or deletion (not implemented yet), and you
+;; can see what packages are available. This will automatically
+;; fetch the latest list of packages from ELPA.
+;;
+;; M-x package-install-from-buffer
+;; Install a package consisting of a single .el file that appears
+;; in the current buffer. This only works for packages which
+;; define a Version header properly; package.el also supports the
+;; extension headers Package-Version (in case Version is an RCS id
+;; or similar), and Package-Requires (if the package requires other
+;; packages).
+;;
+;; M-x package-install-file
+;; Install a package from the indicated file. The package can be
+;; either a tar file or a .el file. A tar file must contain an
+;; appropriately-named "-pkg.el" file; a .el file must be properly
+;; formatted as with package-install-from-buffer.
+
+;;; Thanks:
+;;; (sorted by sort-lines):
+
+;; Jim Blandy <jimbNOSPAMred-bean.com>
+;; Karl Fogel <kfogelNOSPAMred-bean.com>
+;; Kevin Ryde <user42NOSPAMzip.com.au>
+;; Lawrence Mitchell
+;; Michael Olson <mwolsonNOSPAMmember.fsf.org>
+;; Sebastian Tennant <sebyteNOSPAMsmolny.plus.com>
+;; Stefan Monnier <monnierNOSPAMiro.umontreal.ca>
+;; Vinicius Jose Latorre <viniciusjlNOSPAMig.com.br>
+;; Phil Hagelberg <philNOSPAMhagelb.org>
+
+;;; ToDo:
+
+;; - a trust mechanism, since compiling a package can run arbitrary code.
+;; For example, download package signatures and check that they match.
+;; - putting info dirs at the start of the info path means
+;; users see a weird ordering of categories. OTOH we want to
+;; override later entries. maybe emacs needs to enforce
+;; the standard layout?
+;; - put bytecode in a separate directory tree
+;; - perhaps give users a way to recompile their bytecode
+;; or do it automatically when emacs changes
+;; - give users a way to know whether a package is installed ok
+;; - give users a way to view a package's documentation when it
+;; only appears in the .el
+;; - use/extend checkdoc so people can tell if their package will work
+;; - "installed" instead of a blank in the status column
+;; - tramp needs its files to be compiled in a certain order.
+;; how to handle this? fix tramp?
+;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22?
+;; - maybe we need separate .elc directories for various emacs versions
+;; and also emacs-vs-xemacs. That way conditional compilation can
+;; work. But would this break anything?
+;; - should store the package's keywords in archive-contents, then
+;; let the users filter the package-menu by keyword. See
+;; finder-by-keyword. (We could also let people view the
+;; Commentary, but it isn't clear how useful this is.)
+;; - William Xu suggests being able to open a package file without
+;; installing it
+;; - Interface with desktop.el so that restarting after an install
+;; works properly
+;; - Implement M-x package-upgrade, to upgrade any/all existing packages
+;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info
+;; ... except maybe lisp?
+;; - It may be nice to have a macro that expands to the package's
+;; private data dir, aka ".../etc". Or, maybe data-directory
+;; needs to be a list (though this would be less nice)
+;; a few packages want this, eg sokoban
+;; - package menu needs:
+;; ability to know which packages are built-in & thus not deletable
+;; it can sometimes print odd results, like 0.3 available but 0.4 active
+;; why is that?
+;; - Allow multiple versions on the server...?
+;; [ why bother? ]
+;; - Don't install a package which will invalidate dependencies overall
+;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5))
+;; [ currently thinking, why bother.. KISS ]
+;; - Allow optional package dependencies
+;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
+;; and just don't compile to add to load path ...?
+;; - Have a list of archive URLs? [ maybe there's no point ]
+;; - David Kastrup pointed out on the xemacs list that for GPL it
+;; is friendlier to ship the source tree. We could "support" that
+;; by just having a "src" subdir in the package. This isn't ideal
+;; but it probably is not worth trying to support random source
+;; tree layouts, build schemes, etc.
+;; - Our treatment of the info path is somewhat bogus
+;; - perhaps have an "unstable" tree in ELPA as well as a stable one
+
+;;; Code:
+
+(require 'tabulated-list)
+
+(defgroup package nil
+ "Manager for Emacs Lisp packages."
+ :group 'applications
+ :version "24.1")
+
+;;;###autoload
+(defcustom package-enable-at-startup t
+ "Whether to activate installed packages when Emacs starts.
+If non-nil, packages are activated after reading the init file
+and before `after-init-hook'. Activation is not done if
+`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+
+Even if the value is nil, you can type \\[package-initialize] to
+activate the package system at any time."
+ :type 'boolean
+ :group 'package
+ :version "24.1")
+
+(defcustom package-load-list '(all)
+ "List of packages for `package-initialize' to load.
+Each element in this list should be a list (NAME VERSION), or the
+symbol `all'. The symbol `all' says to load the latest installed
+versions of all packages not specified by other elements.
+
+For an element (NAME VERSION), NAME is a package name (a symbol).
+VERSION should be t, a string, or nil.
+If VERSION is t, all versions are loaded, though obsolete ones
+ will be put in `package-obsolete-alist' and not activated.
+If VERSION is a string, only that version is ever loaded.
+ Any other version, even if newer, is silently ignored.
+ Hence, the package is \"held\" at that version.
+If VERSION is nil, the package is not loaded (it is \"disabled\")."
+ :type '(repeat symbol)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defvar Info-directory-list)
+(declare-function info-initialize "info" ())
+(declare-function url-http-parse-response "url-http" ())
+(declare-function lm-header "lisp-mnt" (header))
+(declare-function lm-commentary "lisp-mnt" (&optional file))
+(defvar url-http-end-of-headers)
+
+(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
+ "An alist of archives from which to fetch.
+The default value points to the GNU Emacs package repository.
+
+Each element has the form (ID . LOCATION).
+ ID is an archive name, as a string.
+ LOCATION specifies the base location for the archive.
+ If it starts with \"http:\", it is treated as a HTTP URL;
+ otherwise it should be an absolute directory name.
+ (Other types of URL are currently not supported.)
+
+Only add locations that you trust, since fetching and installing
+a package can run arbitrary code."
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (string :tag "URL or directory name"))
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defconst package-archive-version 1
+ "Version number of the package archive understood by this file.
+Lower version numbers than this will probably be understood as well.")
+
+(defconst package-el-version "1.0"
+ "Version of package.el.")
+
+;; We don't prime the cache since it tends to get out of date.
+(defvar package-archive-contents nil
+ "Cache of the contents of the Emacs Lisp Package Archive.
+This is an alist mapping package names (symbols) to package
+descriptor vectors. These are like the vectors for `package-alist'
+but have extra entries: one which is 'tar for tar packages and
+'single for single-file packages, and one which is the name of
+the archive from which it came.")
+(put 'package-archive-contents 'risky-local-variable t)
+
+(defcustom package-user-dir (locate-user-emacs-file "elpa")
+ "Directory containing the user's Emacs Lisp packages.
+The directory name should be absolute.
+Apart from this directory, Emacs also looks for system-wide
+packages in `package-directory-list'."
+ :type 'directory
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defcustom package-directory-list
+ ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
+ (let (result)
+ (dolist (f load-path)
+ (and (stringp f)
+ (equal (file-name-nondirectory f) "site-lisp")
+ (push (expand-file-name "elpa" f) result)))
+ (nreverse result))
+ "List of additional directories containing Emacs Lisp packages.
+Each directory name should be absolute.
+
+These directories contain packages intended for system-wide; in
+contrast, `package-user-dir' contains packages for personal use."
+ :type '(repeat directory)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+;; The value is precomputed in finder-inf.el, but don't load that
+;; until it's needed (i.e. when `package-initialize' is called).
+(defvar package--builtins nil
+ "Alist of built-in packages.
+The actual value is initialized by loading the library
+`finder-inf'; this is not done until it is needed, e.g. by the
+function `package-built-in-p'.
+
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
+The vector DESC has the form [VERSION-LIST REQS DOCSTRING].
+ VERSION-LIST is a version list.
+ REQS is a list of packages required by the package, each
+ requirement having the form (NAME VL), where NAME is a string
+ and VL is a version list.
+ DOCSTRING is a brief description of the package.")
+(put 'package--builtins 'risky-local-variable t)
+
+(defvar package-alist nil
+ "Alist of all packages available for activation.
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
+
+The vector DESC has the form [VERSION-LIST REQS DOCSTRING].
+ VERSION-LIST is a version list.
+ REQS is a list of packages required by the package, each
+ requirement having the form (NAME VL) where NAME is a string
+ and VL is a version list.
+ DOCSTRING is a brief description of the package.
+
+This variable is set automatically by `package-load-descriptor',
+called via `package-initialize'. To change which packages are
+loaded and/or activated, customize `package-load-list'.")
+(put 'package-alist 'risky-local-variable t)
+
+(defvar package-activated-list nil
+ "List of the names of currently activated packages.")
+(put 'package-activated-list 'risky-local-variable t)
+
+(defvar package-obsolete-alist nil
+ "Representation of obsolete packages.
+Like `package-alist', but maps package name to a second alist.
+The inner alist is keyed by version.")
+(put 'package-obsolete-alist 'risky-local-variable t)
+
+(defun package-version-join (vlist)
+ "Return the version string corresponding to the list VLIST.
+This is, approximately, the inverse of `version-to-list'.
+\(Actually, it returns only one of the possible inverses, since
+`version-to-list' is a many-to-one operation.)"
+ (if (null vlist)
+ ""
+ (let ((str-list (list "." (int-to-string (car vlist)))))
+ (dolist (num (cdr vlist))
+ (cond
+ ((>= num 0)
+ (push (int-to-string num) str-list)
+ (push "." str-list))
+ ((< num -3)
+ (error "Invalid version list `%s'" vlist))
+ (t
+ ;; pre, or beta, or alpha
+ (cond ((equal "." (car str-list))
+ (pop str-list))
+ ((not (string-match "[0-9]+" (car str-list)))
+ (error "Invalid version list `%s'" vlist)))
+ (push (cond ((= num -1) "pre")
+ ((= num -2) "beta")
+ ((= num -3) "alpha"))
+ str-list))))
+ (if (equal "." (car str-list))
+ (pop str-list))
+ (apply 'concat (nreverse str-list)))))
+
+(defun package-strip-version (dirname)
+ "Strip the version from a combined package name and version.
+E.g., if given \"quux-23.0\", will return \"quux\""
+ (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
+ (match-string 1 dirname)))
+
+(defun package-load-descriptor (dir package)
+ "Load the description file in directory DIR for package PACKAGE.
+Here, PACKAGE is a string of the form NAME-VERSION, where NAME is
+the package name and VERSION is its version."
+ (let* ((pkg-dir (expand-file-name package dir))
+ (pkg-file (expand-file-name
+ (concat (package-strip-version package) "-pkg")
+ pkg-dir)))
+ (when (and (file-directory-p pkg-dir)
+ (file-exists-p (concat pkg-file ".el")))
+ (load pkg-file nil t))))
+
+(defun package-load-all-descriptors ()
+ "Load descriptors for installed Emacs Lisp packages.
+This looks for package subdirectories in `package-user-dir' and
+`package-directory-list'. The variable `package-load-list'
+controls which package subdirectories may be loaded.
+
+In each valid package subdirectory, this function loads the
+description file containing a call to `define-package', which
+updates `package-alist' and `package-obsolete-alist'."
+ (let ((regexp (concat "\\`" package-subdirectory-regexp "\\'")))
+ (dolist (dir (cons package-user-dir package-directory-list))
+ (when (file-directory-p dir)
+ (dolist (subdir (directory-files dir))
+ (when (string-match regexp subdir)
+ (package-maybe-load-descriptor (match-string 1 subdir)
+ (match-string 2 subdir)
+ dir)))))))
+
+(defun package-maybe-load-descriptor (name version dir)
+ "Maybe load a specific package from directory DIR.
+NAME and VERSION are the package's name and version strings.
+This function checks `package-load-list', before actually loading
+the package by calling `package-load-descriptor'."
+ (let ((force (assq (intern name) package-load-list))
+ (subdir (concat name "-" version)))
+ (and (file-directory-p (expand-file-name subdir dir))
+ ;; Check `package-load-list':
+ (cond ((null force)
+ (memq 'all package-load-list))
+ ((null (setq force (cadr force)))
+ nil) ; disabled
+ ((eq force t)
+ t)
+ ((stringp force) ; held
+ (version-list-= (version-to-list version)
+ (version-to-list force)))
+ (t
+ (error "Invalid element in `package-load-list'")))
+ ;; Actually load the descriptor:
+ (package-load-descriptor dir subdir))))
+
+(defsubst package-desc-vers (desc)
+ "Extract version from a package description vector."
+ (aref desc 0))
+
+(defsubst package-desc-reqs (desc)
+ "Extract requirements from a package description vector."
+ (aref desc 1))
+
+(defsubst package-desc-doc (desc)
+ "Extract doc string from a package description vector."
+ (aref desc 2))
+
+(defsubst package-desc-kind (desc)
+ "Extract the kind of download from an archive package description vector."
+ (aref desc 3))
+
+(defun package--dir (name version)
+ "Return the directory where a package is installed, or nil if none.
+NAME and VERSION are both strings."
+ (let* ((subdir (concat name "-" version))
+ (dir-list (cons package-user-dir package-directory-list))
+ pkg-dir)
+ (while dir-list
+ (let ((subdir-full (expand-file-name subdir (car dir-list))))
+ (if (file-directory-p subdir-full)
+ (setq pkg-dir subdir-full
+ dir-list nil)
+ (setq dir-list (cdr dir-list)))))
+ pkg-dir))
+
+(defun package-activate-1 (package pkg-vec)
+ (let* ((name (symbol-name package))
+ (version-str (package-version-join (package-desc-vers pkg-vec)))
+ (pkg-dir (package--dir name version-str)))
+ (unless pkg-dir
+ (error "Internal error: unable to find directory for `%s-%s'"
+ name version-str))
+ ;; Add info node.
+ (when (file-exists-p (expand-file-name "dir" pkg-dir))
+ ;; FIXME: not the friendliest, but simple.
+ (require 'info)
+ (info-initialize)
+ (push pkg-dir Info-directory-list))
+ ;; Add to load path, add autoloads, and activate the package.
+ (push pkg-dir load-path)
+ (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
+ (push package package-activated-list)
+ ;; Don't return nil.
+ t))
+
+(defun package-built-in-p (package &optional min-version)
+ "Return true if PACKAGE is built-in to Emacs.
+Optional arg MIN-VERSION, if non-nil, should be a version list
+specifying the minimum acceptable version."
+ (require 'finder-inf nil t) ; For `package--builtins'.
+ (if (eq package 'emacs)
+ (version-list-<= min-version (version-to-list emacs-version))
+ (let ((elt (assq package package--builtins)))
+ (and elt (version-list-<= min-version
+ (package-desc-vers (cdr elt)))))))
+
+;; This function goes ahead and activates a newer version of a package
+;; if an older one was already activated. This is not ideal; we'd at
+;; least need to check to see if the package has actually been loaded,
+;; and not merely activated.
+(defun package-activate (package min-version)
+ "Activate package PACKAGE, of version MIN-VERSION or newer.
+MIN-VERSION should be a version list.
+If PACKAGE has any dependencies, recursively activate them.
+Return nil if the package could not be activated."
+ (let ((pkg-vec (cdr (assq package package-alist)))
+ available-version found)
+ ;; Check if PACKAGE is available in `package-alist'.
+ (when pkg-vec
+ (setq available-version (package-desc-vers pkg-vec)
+ found (version-list-<= min-version available-version)))
+ (cond
+ ;; If no such package is found, maybe it's built-in.
+ ((null found)
+ (package-built-in-p package min-version))
+ ;; If the package is already activated, just return t.
+ ((memq package package-activated-list)
+ t)
+ ;; Otherwise, proceed with activation.
+ (t
+ (let ((fail (catch 'dep-failure
+ ;; Activate its dependencies recursively.
+ (dolist (req (package-desc-reqs pkg-vec))
+ (unless (package-activate (car req) (cadr req))
+ (throw 'dep-failure req))))))
+ (if fail
+ (warn "Unable to activate package `%s'.
+Required package `%s-%s' is unavailable"
+ package (car fail) (package-version-join (cadr fail)))
+ ;; If all goes well, activate the package itself.
+ (package-activate-1 package pkg-vec)))))))
+
+(defun package-mark-obsolete (package pkg-vec)
+ "Put package on the obsolete list, if not already there."
+ (let ((elt (assq package package-obsolete-alist)))
+ (if elt
+ ;; If this obsolete version does not exist in the list, update
+ ;; it the list.
+ (unless (assoc (package-desc-vers pkg-vec) (cdr elt))
+ (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec)
+ (cdr elt))))
+ ;; Make a new association.
+ (push (cons package (list (cons (package-desc-vers pkg-vec)
+ pkg-vec)))
+ package-obsolete-alist))))
+
+(defun define-package (name-string version-string
+ &optional docstring requirements
+ &rest _extra-properties)
+ "Define a new package.
+NAME-STRING is the name of the package, as a string.
+VERSION-STRING is the version of the package, as a string.
+DOCSTRING is a short description of the package, a string.
+REQUIREMENTS is a list of dependencies on other packages.
+ Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
+ where OTHER-VERSION is a string.
+
+EXTRA-PROPERTIES is currently unused."
+ (let* ((name (intern name-string))
+ (version (version-to-list version-string))
+ (new-pkg-desc
+ (cons name
+ (vector version
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requirements)
+ docstring)))
+ (old-pkg (assq name package-alist)))
+ (cond
+ ;; If there's no old package, just add this to `package-alist'.
+ ((null old-pkg)
+ (push new-pkg-desc package-alist))
+ ((version-list-< (package-desc-vers (cdr old-pkg)) version)
+ ;; Remove the old package and declare it obsolete.
+ (package-mark-obsolete name (cdr old-pkg))
+ (setq package-alist (cons new-pkg-desc
+ (delq old-pkg package-alist))))
+ ;; You can have two packages with the same version, e.g. one in
+ ;; the system package directory and one in your private
+ ;; directory. We just let the first one win.
+ ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
+ ;; The package is born obsolete.
+ (package-mark-obsolete name (cdr new-pkg-desc))))))
+
+;; From Emacs 22.
+(defun package-autoload-ensure-default-file (file)
+ "Make sure that the autoload file FILE exists and if not create it."
+ (unless (file-exists-p file)
+ (write-region
+ (concat ";;; " (file-name-nondirectory file)
+ " --- automatically extracted autoloads\n"
+ ";;\n"
+ ";;; Code:\n\n"
+ "\f\n;; Local Variables:\n"
+ ";; version-control: never\n"
+ ";; no-byte-compile: t\n"
+ ";; no-update-autoloads: t\n"
+ ";; End:\n"
+ ";;; " (file-name-nondirectory file)
+ " ends here\n")
+ nil file))
+ file)
+
+(defun package-generate-autoloads (name pkg-dir)
+ (require 'autoload) ;Load before we let-bind generated-autoload-file!
+ (let* ((auto-name (concat name "-autoloads.el"))
+ ;;(ignore-name (concat name "-pkg.el"))
+ (generated-autoload-file (expand-file-name auto-name pkg-dir))
+ (version-control 'never))
+ (unless (fboundp 'autoload-ensure-default-file)
+ (package-autoload-ensure-default-file generated-autoload-file))
+ (update-directory-autoloads pkg-dir)
+ (let ((buf (find-buffer-visiting generated-autoload-file)))
+ (when buf (kill-buffer buf)))))
+
+(defvar tar-parse-info)
+(declare-function tar-untar-buffer "tar-mode" ())
+(declare-function tar-header-name "tar-mode" (tar-header))
+(declare-function tar-header-link-type "tar-mode" (tar-header))
+
+(defun package-untar-buffer (dir)
+ "Untar the current buffer.
+This uses `tar-untar-buffer' from Tar mode. All files should
+untar into a directory named DIR; otherwise, signal an error."
+ (require 'tar-mode)
+ (tar-mode)
+ ;; Make sure everything extracts into DIR.
+ (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
+ (case-fold-search (memq system-type '(windows-nt ms-dos cygwin))))
+ (dolist (tar-data tar-parse-info)
+ (let ((name (expand-file-name (tar-header-name tar-data))))
+ (or (string-match regexp name)
+ ;; Tarballs created by some utilities don't list
+ ;; directories with a trailing slash (Bug#13136).
+ (and (string-equal dir name)
+ (eq (tar-header-link-type tar-data) 5))
+ (error "Package does not untar cleanly into directory %s/" dir)))))
+ (tar-untar-buffer))
+
+(defun package-unpack (package version)
+ (let* ((name (symbol-name package))
+ (dirname (concat name "-" version))
+ (pkg-dir (expand-file-name dirname package-user-dir)))
+ (make-directory package-user-dir t)
+ ;; FIXME: should we delete PKG-DIR if it exists?
+ (let* ((default-directory (file-name-as-directory package-user-dir)))
+ (package-untar-buffer dirname)
+ (package--make-autoloads-and-compile name pkg-dir))))
+
+(defun package--make-autoloads-and-compile (name pkg-dir)
+ "Generate autoloads and do byte-compilation for package named NAME.
+PKG-DIR is the name of the package directory."
+ (package-generate-autoloads name pkg-dir)
+ (let ((load-path (cons pkg-dir load-path)))
+ ;; We must load the autoloads file before byte compiling, in
+ ;; case there are magic cookies to set up non-trivial paths.
+ (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
+ (byte-recompile-directory pkg-dir 0 t)))
+
+(defun package--write-file-no-coding (file-name)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name)))
+
+(defun package-unpack-single (file-name version desc requires)
+ "Install the contents of the current buffer as a package."
+ ;; Special case "package".
+ (if (string= file-name "package")
+ (package--write-file-no-coding
+ (expand-file-name (concat file-name ".el") package-user-dir))
+ (let* ((pkg-dir (expand-file-name (concat file-name "-"
+ (package-version-join
+ (version-to-list version)))
+ package-user-dir))
+ (el-file (expand-file-name (concat file-name ".el") pkg-dir))
+ (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
+ (make-directory pkg-dir t)
+ (package--write-file-no-coding el-file)
+ (let ((print-level nil)
+ (print-length nil))
+ (write-region
+ (concat
+ (prin1-to-string
+ (list 'define-package
+ file-name
+ version
+ desc
+ (list 'quote
+ ;; Turn version lists into string form.
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (package-version-join (cadr elt))))
+ requires))))
+ "\n")
+ nil
+ pkg-file
+ nil nil nil 'excl))
+ (package--make-autoloads-and-compile file-name pkg-dir))))
+
+(defmacro package--with-work-buffer (location file &rest body)
+ "Run BODY in a buffer containing the contents of FILE at LOCATION.
+LOCATION is the base location of a package archive, and should be
+one of the URLs (or file names) specified in `package-archives'.
+FILE is the name of a file relative to that base location.
+
+This macro retrieves FILE from LOCATION into a temporary buffer,
+and evaluates BODY while that buffer is current. This work
+buffer is killed afterwards. Return the last value in BODY."
+ `(let* ((http (string-match "\\`https?:" ,location))
+ (buffer
+ (if http
+ (url-retrieve-synchronously (concat ,location ,file))
+ (generate-new-buffer "*package work buffer*"))))
+ (prog1
+ (with-current-buffer buffer
+ (if http
+ (progn (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point)))
+ (unless (file-name-absolute-p ,location)
+ (error "Archive location %s is not an absolute file name"
+ ,location))
+ (insert-file-contents (expand-file-name ,file ,location)))
+ ,@body)
+ (kill-buffer buffer))))
+
+(defun package-handle-response ()
+ "Handle the response from a `url-retrieve-synchronously' call.
+Parse the HTTP response and throw if an error occurred.
+The url package seems to require extra processing for this.
+This should be called in a `save-excursion', in the download buffer.
+It will move point to somewhere in the headers."
+ ;; We assume HTTP here.
+ (require 'url-http)
+ (let ((response (url-http-parse-response)))
+ (when (or (< response 200) (>= response 300))
+ (error "Error during download request:%s"
+ (buffer-substring-no-properties (point) (progn
+ (end-of-line)
+ (point)))))))
+
+(defun package-download-single (name version desc requires)
+ "Download and install a single-file package."
+ (let ((location (package-archive-base name))
+ (file (concat (symbol-name name) "-" version ".el")))
+ (package--with-work-buffer location file
+ (package-unpack-single (symbol-name name) version desc requires))))
+
+(defun package-download-tar (name version)
+ "Download and install a tar package."
+ (let ((location (package-archive-base name))
+ (file (concat (symbol-name name) "-" version ".tar")))
+ (package--with-work-buffer location file
+ (package-unpack name version))))
+
+(defvar package--initialized nil)
+
+(defun package-installed-p (package &optional min-version)
+ "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
+MIN-VERSION should be a version list."
+ (unless package--initialized (error "package.el is not yet initialized!"))
+ (let ((pkg-desc (assq package package-alist)))
+ (if pkg-desc
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc)))
+ ;; Also check built-in packages.
+ (package-built-in-p package min-version))))
+
+(defun package-compute-transaction (package-list requirements)
+ "Return a list of packages to be installed, including PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+
+REQUIREMENTS should be a list of additional requirements; each
+element in this list should have the form (PACKAGE VERSION-LIST),
+where PACKAGE is a package name and VERSION-LIST is the required
+version of that package.
+
+This function recursively computes the requirements of the
+packages in REQUIREMENTS, and returns a list of all the packages
+that must be installed. Packages that are already installed are
+not included in this list."
+ (dolist (elt requirements)
+ (let* ((next-pkg (car elt))
+ (next-version (cadr elt)))
+ (unless (package-installed-p next-pkg next-version)
+ ;; A package is required, but not installed. It might also be
+ ;; blocked via `package-load-list'.
+ (let ((pkg-desc (assq next-pkg package-archive-contents))
+ hold)
+ (when (setq hold (assq next-pkg package-load-list))
+ (setq hold (cadr hold))
+ (cond ((eq hold t))
+ ((eq hold nil)
+ (error "Required package '%s' is disabled"
+ (symbol-name next-pkg)))
+ ((null (stringp hold))
+ (error "Invalid element in `package-load-list'"))
+ ((version-list-< (version-to-list hold) next-version)
+ (error "Package `%s' held at version %s, \
+but version %s required"
+ (symbol-name next-pkg) hold
+ (package-version-join next-version)))))
+ (unless pkg-desc
+ (error "Package `%s-%s' is unavailable"
+ (symbol-name next-pkg)
+ (package-version-join next-version)))
+ (unless (version-list-<= next-version
+ (package-desc-vers (cdr pkg-desc)))
+ (error
+ "Need package `%s-%s', but only %s is available"
+ (symbol-name next-pkg) (package-version-join next-version)
+ (package-version-join (package-desc-vers (cdr pkg-desc)))))
+ ;; Only add to the transaction if we don't already have it.
+ (unless (memq next-pkg package-list)
+ (push next-pkg package-list))
+ (setq package-list
+ (package-compute-transaction package-list
+ (package-desc-reqs
+ (cdr pkg-desc))))))))
+ package-list)
+
+(defun package-read-from-string (str)
+ "Read a Lisp expression from STR.
+Signal an error if the entire string was not used."
+ (let* ((read-data (read-from-string str))
+ (more-left
+ (condition-case nil
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string
+ (substring str (cdr read-data))))
+ t)
+ (end-of-file nil))))
+ (if more-left
+ (error "Can't read whole string")
+ (car read-data))))
+
+(defun package--read-archive-file (file)
+ "Re-read archive file FILE, if it exists.
+Will return the data from the file, or nil if the file does not exist.
+Will throw an error if the archive version is too new."
+ (let ((filename (expand-file-name file package-user-dir)))
+ (when (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (let ((contents (read (current-buffer))))
+ (if (> (car contents) package-archive-version)
+ (error "Package archive version %d is higher than %d"
+ (car contents) package-archive-version))
+ (cdr contents))))))
+
+(defun package-read-all-archive-contents ()
+ "Re-read `archive-contents', if it exists.
+If successful, set `package-archive-contents'."
+ (setq package-archive-contents nil)
+ (dolist (archive package-archives)
+ (package-read-archive-contents (car archive))))
+
+(defun package-read-archive-contents (archive)
+ "Re-read archive contents for ARCHIVE.
+If successful, set the variable `package-archive-contents'.
+If the archive version is too new, signal an error."
+ ;; Version 1 of 'archive-contents' is identical to our internal
+ ;; representation.
+ (let* ((dir (concat "archives/" archive))
+ (contents-file (concat dir "/archive-contents"))
+ contents)
+ (when (setq contents (package--read-archive-file contents-file))
+ (dolist (package contents)
+ (package--add-to-archive-contents package archive)))))
+
+(defun package--add-to-archive-contents (package archive)
+ "Add the PACKAGE from the given ARCHIVE if necessary.
+Also, add the originating archive to the end of the package vector."
+ (let* ((name (car package))
+ (version (package-desc-vers (cdr package)))
+ (entry (cons name
+ (vconcat (cdr package) (vector archive))))
+ (existing-package (assq name package-archive-contents)))
+ (cond ((not existing-package)
+ (add-to-list 'package-archive-contents entry))
+ ((version-list-< (package-desc-vers (cdr existing-package))
+ version)
+ ;; Replace the entry with this one.
+ (setq package-archive-contents
+ (cons entry
+ (delq existing-package
+ package-archive-contents)))))))
+
+(defun package-download-transaction (package-list)
+ "Download and install all the packages in PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+This function assumes that all package requirements in
+PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
+using `package-compute-transaction'."
+ (dolist (elt package-list)
+ (let* ((desc (cdr (assq elt package-archive-contents)))
+ ;; As an exception, if package is "held" in
+ ;; `package-load-list', download the held version.
+ (hold (cadr (assq elt package-load-list)))
+ (v-string (or (and (stringp hold) hold)
+ (package-version-join (package-desc-vers desc))))
+ (kind (package-desc-kind desc)))
+ (cond
+ ((eq kind 'tar)
+ (package-download-tar elt v-string))
+ ((eq kind 'single)
+ (package-download-single elt v-string
+ (package-desc-doc desc)
+ (package-desc-reqs desc)))
+ (t
+ (error "Unknown package kind: %s" (symbol-name kind))))
+ ;; If package A depends on package B, then A may `require' B
+ ;; during byte compilation. So we need to activate B before
+ ;; unpacking A.
+ (package-maybe-load-descriptor (symbol-name elt) v-string
+ package-user-dir)
+ (package-activate elt (version-to-list v-string)))))
+
+;;;###autoload
+(defun package-install (name)
+ "Install the package named NAME.
+NAME should be the name of one of the available packages in an
+archive in `package-archives'. Interactively, prompt for NAME."
+ (interactive
+ (progn
+ ;; Initialize the package system to get the list of package
+ ;; symbols for completion.
+ (unless package--initialized
+ (package-initialize t))
+ (unless package-archive-contents
+ (package-refresh-contents))
+ (list (intern (completing-read
+ "Install package: "
+ (mapcar (lambda (elt)
+ (cons (symbol-name (car elt))
+ nil))
+ package-archive-contents)
+ nil t)))))
+ (let ((pkg-desc (assq name package-archive-contents)))
+ (unless pkg-desc
+ (error "Package `%s' is not available for installation"
+ (symbol-name name)))
+ (package-download-transaction
+ (package-compute-transaction (list name)
+ (package-desc-reqs (cdr pkg-desc))))))
+
+(defun package-strip-rcs-id (str)
+ "Strip RCS version ID from the version string STR.
+If the result looks like a dotted numeric version, return it.
+Otherwise return nil."
+ (when str
+ (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
+ (setq str (substring str (match-end 0))))
+ (condition-case nil
+ (if (version-to-list str)
+ str)
+ (error nil))))
+
+(defun package-buffer-info ()
+ "Return a vector describing the package in the current buffer.
+The vector has the form
+
+ [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
+
+FILENAME is the file name, a string, sans the \".el\" extension.
+REQUIRES is a list of requirements, each requirement having the
+ form (NAME VER); NAME is a string and VER is a version list.
+DESCRIPTION is the package description, a string.
+VERSION is the version, a string.
+COMMENTARY is the commentary section, a string, or nil if none.
+
+If the buffer does not contain a conforming package, signal an
+error. If there is a package, narrow the buffer to the file's
+boundaries."
+ (goto-char (point-min))
+ (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
+ (error "Packages lacks a file header"))
+ (let ((file-name (match-string-no-properties 1))
+ (desc (match-string-no-properties 2))
+ (start (line-beginning-position)))
+ (unless (search-forward (concat ";;; " file-name ".el ends here"))
+ (error "Package lacks a terminating comment"))
+ ;; Try to include a trailing newline.
+ (forward-line)
+ (narrow-to-region start (point))
+ (require 'lisp-mnt)
+ ;; Use some headers we've invented to drive the process.
+ (let* ((requires-str (lm-header "package-requires"))
+ (requires (if requires-str
+ (package-read-from-string requires-str)))
+ ;; Prefer Package-Version; if defined, the package author
+ ;; probably wants us to use it. Otherwise try Version.
+ (pkg-version
+ (or (package-strip-rcs-id (lm-header "package-version"))
+ (package-strip-rcs-id (lm-header "version"))))
+ (commentary (lm-commentary)))
+ (unless pkg-version
+ (error
+ "Package lacks a \"Version\" or \"Package-Version\" header"))
+ ;; Turn string version numbers into list form.
+ (setq requires
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requires))
+ (vector file-name requires desc pkg-version commentary))))
+
+(defun package-tar-file-info (file)
+ "Find package information for a tar file.
+FILE is the name of the tar file to examine.
+The return result is a vector like `package-buffer-info'."
+ (let ((default-directory (file-name-directory file))
+ (file (file-name-nondirectory file)))
+ (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
+ file)
+ (error "Invalid package name `%s'" file))
+ (let* ((pkg-name (match-string-no-properties 1 file))
+ (pkg-version (match-string-no-properties 2 file))
+ ;; Extract the package descriptor.
+ (pkg-def-contents (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+
+ pkg-name "-" pkg-version "/"
+ pkg-name "-pkg.el")))
+ (pkg-def-parsed (package-read-from-string pkg-def-contents)))
+ (unless (eq (car pkg-def-parsed) 'define-package)
+ (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
+ (let ((name-str (nth 1 pkg-def-parsed))
+ (version-string (nth 2 pkg-def-parsed))
+ (docstring (nth 3 pkg-def-parsed))
+ (requires (nth 4 pkg-def-parsed))
+ (readme (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/README"))))
+ (unless (equal pkg-version version-string)
+ (error "Package has inconsistent versions"))
+ (unless (equal pkg-name name-str)
+ (error "Package has inconsistent names"))
+ ;; Kind of a hack.
+ (if (string-match ": Not found in archive" readme)
+ (setq readme nil))
+ ;; Turn string version numbers into list form.
+ (if (eq (car requires) 'quote)
+ (setq requires (car (cdr requires))))
+ (setq requires
+ (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
+ requires))
+ (vector pkg-name requires docstring version-string readme)))))
+
+;;;###autoload
+(defun package-install-from-buffer (pkg-info type)
+ "Install a package from the current buffer.
+When called interactively, the current buffer is assumed to be a
+single .el file that follows the packaging guidelines; see info
+node `(elisp)Packaging'.
+
+When called from Lisp, PKG-INFO is a vector describing the
+information, of the type returned by `package-buffer-info'; and
+TYPE is the package type (either `single' or `tar')."
+ (interactive (list (package-buffer-info) 'single))
+ (save-excursion
+ (save-restriction
+ (let* ((file-name (aref pkg-info 0))
+ (requires (aref pkg-info 1))
+ (desc (if (string= (aref pkg-info 2) "")
+ "No description available."
+ (aref pkg-info 2)))
+ (pkg-version (aref pkg-info 3)))
+ ;; Download and install the dependencies.
+ (let ((transaction (package-compute-transaction nil requires)))
+ (package-download-transaction transaction))
+ ;; Install the package itself.
+ (cond
+ ((eq type 'single)
+ (package-unpack-single file-name pkg-version desc requires))
+ ((eq type 'tar)
+ (package-unpack (intern file-name) pkg-version))
+ (t
+ (error "Unknown type: %s" (symbol-name type))))
+ ;; Try to activate it.
+ (package-initialize)))))
+
+;;;###autoload
+(defun package-install-file (file)
+ "Install a package from a file.
+The file can either be a tar file or an Emacs Lisp file."
+ (interactive "fPackage file name: ")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (cond
+ ((string-match "\\.el$" file)
+ (package-install-from-buffer (package-buffer-info) 'single))
+ ((string-match "\\.tar$" file)
+ (package-install-from-buffer (package-tar-file-info file) 'tar))
+ (t (error "Unrecognized extension `%s'" (file-name-extension file))))))
+
+(defun package-delete (name version)
+ (let ((dir (package--dir name version)))
+ (if (string-equal (file-name-directory dir)
+ (file-name-as-directory
+ (expand-file-name package-user-dir)))
+ (progn
+ (delete-directory dir t t)
+ (message "Package `%s-%s' deleted." name version))
+ ;; Don't delete "system" packages
+ (error "Package `%s-%s' is a system package, not deleting"
+ name version))))
+
+(defun package-archive-base (name)
+ "Return the archive containing the package NAME."
+ (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
+ (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
+
+(defun package--download-one-archive (archive file)
+ "Retrieve an archive file FILE from ARCHIVE, and cache it.
+ARCHIVE should be a cons cell of the form (NAME . LOCATION),
+similar to an entry in `package-alist'. Save the cached copy to
+\"archives/NAME/archive-contents\" in `package-user-dir'."
+ (let* ((dir (expand-file-name "archives" package-user-dir))
+ (dir (expand-file-name (car archive) dir)))
+ (package--with-work-buffer (cdr archive) file
+ ;; Read the retrieved buffer to make sure it is valid (e.g. it
+ ;; may fetch a URL redirect page).
+ (when (listp (read buffer))
+ (make-directory dir t)
+ (setq buffer-file-name (expand-file-name file dir))
+ (let ((version-control 'never))
+ (save-buffer))))))
+
+;;;###autoload
+(defun package-refresh-contents ()
+ "Download the ELPA archive description if needed.
+This informs Emacs about the latest versions of all packages, and
+makes them available for download."
+ (interactive)
+ (unless (file-exists-p package-user-dir)
+ (make-directory package-user-dir t))
+ (dolist (archive package-archives)
+ (condition-case-unless-debug nil
+ (package--download-one-archive archive "archive-contents")
+ (error (message "Failed to download `%s' archive."
+ (car archive)))))
+ (package-read-all-archive-contents))
+
+;;;###autoload
+(defun package-initialize (&optional no-activate)
+ "Load Emacs Lisp packages, and activate them.
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages."
+ (interactive)
+ (setq package-alist nil
+ package-obsolete-alist nil)
+ (package-load-all-descriptors)
+ (package-read-all-archive-contents)
+ (unless no-activate
+ (dolist (elt package-alist)
+ (package-activate (car elt) (package-desc-vers (cdr elt)))))
+ (setq package--initialized t))
+
+\f
+;;;; Package description buffer.
+
+;;;###autoload
+(defun describe-package (package)
+ "Display the full documentation of PACKAGE (a symbol)."
+ (interactive
+ (let* ((guess (function-called-at-point))
+ packages val)
+ (require 'finder-inf nil t)
+ ;; Load the package list if necessary (but don't activate them).
+ (unless package--initialized
+ (package-initialize t))
+ (setq packages (append (mapcar 'car package-alist)
+ (mapcar 'car package-archive-contents)
+ (mapcar 'car package--builtins)))
+ (unless (memq guess packages)
+ (setq guess nil))
+ (setq packages (mapcar 'symbol-name packages))
+ (setq val
+ (completing-read (if guess
+ (format "Describe package (default %s): "
+ guess)
+ "Describe package: ")
+ packages nil t nil nil guess))
+ (list (if (equal val "") guess (intern val)))))
+ (if (or (null package) (not (symbolp package)))
+ (message "No package specified")
+ (help-setup-xref (list #'describe-package package)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (describe-package-1 package)))))
+
+(defun describe-package-1 (package)
+ (require 'lisp-mnt)
+ (let ((package-name (symbol-name package))
+ (built-in (assq package package--builtins))
+ desc pkg-dir reqs version installable archive)
+ (prin1 package)
+ (princ " is ")
+ (cond
+ ;; Loaded packages are in `package-alist'.
+ ((setq desc (cdr (assq package package-alist)))
+ (setq version (package-version-join (package-desc-vers desc)))
+ (if (setq pkg-dir (package--dir package-name version))
+ (insert "an installed package.\n\n")
+ ;; This normally does not happen.
+ (insert "a deleted package.\n\n")))
+ ;; Available packages are in `package-archive-contents'.
+ ((setq desc (cdr (assq package package-archive-contents)))
+ (setq version (package-version-join (package-desc-vers desc))
+ archive (aref desc (- (length desc) 1))
+ installable t)
+ (if built-in
+ (insert "a built-in package.\n\n")
+ (insert "an uninstalled package.\n\n")))
+ (built-in
+ (setq desc (cdr built-in)
+ version (package-version-join (package-desc-vers desc)))
+ (insert "a built-in package.\n\n"))
+ (t
+ (insert "an orphan package.\n\n")))
+
+ (insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
+ (cond (pkg-dir
+ (insert (propertize "Installed"
+ 'font-lock-face 'font-lock-comment-face))
+ (insert " in `")
+ ;; Todo: Add button for uninstalling.
+ (help-insert-xref-button (file-name-as-directory pkg-dir)
+ 'help-package-def pkg-dir)
+ (if built-in
+ (insert "',\n shadowing a "
+ (propertize "built-in package"
+ 'font-lock-face 'font-lock-builtin-face)
+ ".")
+ (insert "'.")))
+ (installable
+ (if built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
+ " Alternate version available")
+ (insert "Available"))
+ (insert " from " archive)
+ (insert " -- ")
+ (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
+ (button-face (if (display-graphic-p)
+ '(:box (:line-width 2 :color "dark grey")
+ :background "light grey"
+ :foreground "black")
+ 'link)))
+ (insert-text-button button-text 'face button-face 'follow-link t
+ 'package-symbol package
+ 'action 'package-install-button-action)))
+ (built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
+ (t (insert "Deleted.")))
+ (insert "\n")
+ (and version (> (length version) 0)
+ (insert " "
+ (propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
+
+ (setq reqs (if desc (package-desc-reqs desc)))
+ (when reqs
+ (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
+ (let ((first t)
+ name vers text)
+ (dolist (req reqs)
+ (setq name (car req)
+ vers (cadr req)
+ text (format "%s-%s" (symbol-name name)
+ (package-version-join vers)))
+ (cond (first (setq first nil))
+ ((>= (+ 2 (current-column) (length text))
+ (window-width))
+ (insert ",\n "))
+ (t (insert ", ")))
+ (help-insert-xref-button text 'help-package name))
+ (insert "\n")))
+ (insert " " (propertize "Summary" 'font-lock-face 'bold)
+ ": " (if desc (package-desc-doc desc)) "\n\n")
+
+ (if built-in
+ ;; For built-in packages, insert the commentary.
+ (let ((fn (locate-file (concat package-name ".el") load-path
+ load-file-rep-suffixes))
+ (opoint (point)))
+ (insert (or (lm-commentary fn) ""))
+ (save-excursion
+ (goto-char opoint)
+ (when (re-search-forward "^;;; Commentary:\n" nil t)
+ (replace-match ""))
+ (while (re-search-forward "^\\(;+ ?\\)" nil t)
+ (replace-match ""))))
+ (let ((readme (expand-file-name (concat package-name "-readme.txt")
+ package-user-dir))
+ readme-string)
+ ;; For elpa packages, try downloading the commentary. If that
+ ;; fails, try an existing readme file in `package-user-dir'.
+ (cond ((condition-case nil
+ (package--with-work-buffer (package-archive-base package)
+ (concat package-name "-readme.txt")
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (let ((version-control 'never))
+ (save-buffer))
+ (setq readme-string (buffer-string))
+ t)
+ (error nil))
+ (insert readme-string))
+ ((file-readable-p readme)
+ (insert-file-contents readme)
+ (goto-char (point-max))))))))
+
+(defun package-install-button-action (button)
+ (let ((package (button-get button 'package-symbol)))
+ (when (y-or-n-p (format "Install package `%s'? " package))
+ (package-install package)
+ (revert-buffer nil t)
+ (goto-char (point-min)))))
+
+\f
+;;;; Package menu mode.
+
+(defvar package-menu-mode-map
+ (let ((map (make-sparse-keymap))
+ (menu-map (make-sparse-keymap "Package")))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map "\C-m" 'package-menu-describe-package)
+ (define-key map "u" 'package-menu-mark-unmark)
+ (define-key map "\177" 'package-menu-backup-unmark)
+ (define-key map "d" 'package-menu-mark-delete)
+ (define-key map "i" 'package-menu-mark-install)
+ (define-key map "U" 'package-menu-mark-upgrades)
+ (define-key map "r" 'package-menu-refresh)
+ (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
+ (define-key map "x" 'package-menu-execute)
+ (define-key map "h" 'package-menu-quick-help)
+ (define-key map "?" 'package-menu-describe-package)
+ (define-key map [menu-bar package-menu] (cons "Package" menu-map))
+ (define-key menu-map [mq]
+ '(menu-item "Quit" quit-window
+ :help "Quit package selection"))
+ (define-key menu-map [s1] '("--"))
+ (define-key menu-map [mn]
+ '(menu-item "Next" next-line
+ :help "Next Line"))
+ (define-key menu-map [mp]
+ '(menu-item "Previous" previous-line
+ :help "Previous Line"))
+ (define-key menu-map [s2] '("--"))
+ (define-key menu-map [mu]
+ '(menu-item "Unmark" package-menu-mark-unmark
+ :help "Clear any marks on a package and move to the next line"))
+ (define-key menu-map [munm]
+ '(menu-item "Unmark Backwards" package-menu-backup-unmark
+ :help "Back up one line and clear any marks on that package"))
+ (define-key menu-map [md]
+ '(menu-item "Mark for Deletion" package-menu-mark-delete
+ :help "Mark a package for deletion and move to the next line"))
+ (define-key menu-map [mi]
+ '(menu-item "Mark for Install" package-menu-mark-install
+ :help "Mark a package for installation and move to the next line"))
+ (define-key menu-map [mupgrades]
+ '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades
+ :help "Mark packages that have a newer version for upgrading"))
+ (define-key menu-map [s3] '("--"))
+ (define-key menu-map [mg]
+ '(menu-item "Update Package List" revert-buffer
+ :help "Update the list of packages"))
+ (define-key menu-map [mr]
+ '(menu-item "Refresh Package List" package-menu-refresh
+ :help "Download the ELPA archive"))
+ (define-key menu-map [s4] '("--"))
+ (define-key menu-map [mt]
+ '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion
+ :help "Mark all obsolete packages for deletion"))
+ (define-key menu-map [mx]
+ '(menu-item "Execute Actions" package-menu-execute
+ :help "Perform all the marked actions"))
+ (define-key menu-map [s5] '("--"))
+ (define-key menu-map [mh]
+ '(menu-item "Help" package-menu-quick-help
+ :help "Show short key binding help for package-menu-mode"))
+ (define-key menu-map [mc]
+ '(menu-item "View Commentary" package-menu-view-commentary
+ :help "Display information about this package"))
+ map)
+ "Local keymap for `package-menu-mode' buffers.")
+
+(defvar package-menu--new-package-list nil
+ "List of newly-available packages since `list-packages' was last called.")
+
+(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
+ "Major mode for browsing a list of packages.
+Letters do not insert themselves; instead, they are commands.
+\\<package-menu-mode-map>
+\\{package-menu-mode-map}"
+ (setq tabulated-list-format [("Package" 18 package-menu--name-predicate)
+ ("Version" 12 nil)
+ ("Status" 10 package-menu--status-predicate)
+ ("Description" 0 nil)])
+ (setq tabulated-list-padding 2)
+ (setq tabulated-list-sort-key (cons "Status" nil))
+ (tabulated-list-init-header))
+
+(defmacro package--push (package desc status listname)
+ "Convenience macro for `package-menu--generate'.
+If the alist stored in the symbol LISTNAME lacks an entry for a
+package PACKAGE with descriptor DESC, add one. The alist is
+keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is
+a symbol and VERSION-LIST is a version list."
+ `(let* ((version (package-desc-vers ,desc))
+ (key (cons ,package version)))
+ (unless (assoc key ,listname)
+ (push (list key ,status (package-desc-doc ,desc)) ,listname))))
+
+(defun package-menu--generate (remember-pos packages)
+ "Populate the Package Menu.
+If REMEMBER-POS is non-nil, keep point on the same entry.
+PACKAGES should be t, which means to display all known packages,
+or a list of package names (symbols) to display."
+ ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION).
+ (let (info-list name)
+ ;; Installed packages:
+ (dolist (elt package-alist)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (package--push name (cdr elt)
+ (if (stringp (cadr (assq name package-load-list)))
+ "held" "installed")
+ info-list)))
+
+ ;; Built-in packages:
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (eq packages t) (memq name packages)))
+ (package--push name (cdr elt) "built-in" info-list)))
+
+ ;; Available and disabled packages:
+ (dolist (elt package-archive-contents)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (let ((hold (assq name package-load-list)))
+ (package--push name (cdr elt)
+ (cond
+ ((and hold (null (cadr hold))) "disabled")
+ ((memq name package-menu--new-package-list) "new")
+ (t "available"))
+ info-list))))
+
+ ;; Obsolete packages:
+ (dolist (elt package-obsolete-alist)
+ (dolist (inner-elt (cdr elt))
+ (when (or (eq packages t) (memq (car elt) packages))
+ (package--push (car elt) (cdr inner-elt) "obsolete" info-list))))
+
+ ;; Print the result.
+ (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list))
+ (tabulated-list-print remember-pos)))
+
+(defun package-menu--print-info (pkg)
+ "Return a package entry suitable for `tabulated-list-entries'.
+PKG has the form ((PACKAGE . VERSION) STATUS DOC).
+Return (KEY [NAME VERSION STATUS DOC]), where KEY is the
+identifier (NAME . VERSION-LIST)."
+ (let* ((package (caar pkg))
+ (version (cdr (car pkg)))
+ (status (nth 1 pkg))
+ (doc (or (nth 2 pkg) ""))
+ (face (cond
+ ((string= status "built-in") 'font-lock-builtin-face)
+ ((string= status "available") 'default)
+ ((string= status "new") 'bold)
+ ((string= status "held") 'font-lock-constant-face)
+ ((string= status "disabled") 'font-lock-warning-face)
+ ((string= status "installed") 'font-lock-comment-face)
+ (t 'font-lock-warning-face)))) ; obsolete.
+ (list (cons package version)
+ (vector (list (symbol-name package)
+ 'face 'link
+ 'follow-link t
+ 'package-symbol package
+ 'action 'package-menu-describe-package)
+ (propertize (package-version-join version)
+ 'font-lock-face face)
+ (propertize status 'font-lock-face face)
+ (propertize doc 'font-lock-face face)))))
+
+(defun package-menu-refresh ()
+ "Download the Emacs Lisp package archive.
+This fetches the contents of each archive specified in
+`package-archives', and then refreshes the package menu."
+ (interactive)
+ (unless (derived-mode-p 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
+ (package-refresh-contents)
+ (package-menu--generate t t))
+
+(defun package-menu-describe-package (&optional button)
+ "Describe the current package.
+If optional arg BUTTON is non-nil, describe its associated package."
+ (interactive)
+ (let ((package (if button (button-get button 'package-symbol)
+ (car (tabulated-list-get-id)))))
+ (if package
+ (describe-package package))))
+
+;; fixme numeric argument
+(defun package-menu-mark-delete (&optional _num)
+ "Mark a package for deletion and move to the next line."
+ (interactive "p")
+ (if (member (package-menu-get-status) '("installed" "obsolete"))
+ (tabulated-list-put-tag "D" t)
+ (forward-line)))
+
+(defun package-menu-mark-install (&optional _num)
+ "Mark a package for installation and move to the next line."
+ (interactive "p")
+ (if (member (package-menu-get-status) '("available" "new"))
+ (tabulated-list-put-tag "I" t)
+ (forward-line)))
+
+(defun package-menu-mark-unmark (&optional _num)
+ "Clear any marks on a package and move to the next line."
+ (interactive "p")
+ (tabulated-list-put-tag " " t))
+
+(defun package-menu-backup-unmark ()
+ "Back up one line and clear any marks on that package."
+ (interactive)
+ (forward-line -1)
+ (tabulated-list-put-tag " "))
+
+(defun package-menu-mark-obsolete-for-deletion ()
+ "Mark all obsolete packages for deletion."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (equal (package-menu-get-status) "obsolete")
+ (tabulated-list-put-tag "D" t)
+ (forward-line 1)))))
+
+(defun package-menu-quick-help ()
+ "Show short key binding help for package-menu-mode."
+ (interactive)
+ (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
+
+(define-obsolete-function-alias
+ 'package-menu-view-commentary 'package-menu-describe-package "24.1")
+
+(defun package-menu-get-status ()
+ (let* ((pkg (tabulated-list-get-id))
+ (entry (and pkg (assq pkg tabulated-list-entries))))
+ (if entry
+ (aref (cadr entry) 2)
+ "")))
+
+(defun package-menu--find-upgrades ()
+ (let (installed available upgrades)
+ ;; Build list of installed/available packages in this buffer.
+ (dolist (entry tabulated-list-entries)
+ ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC])
+ (let ((pkg (car entry))
+ (status (aref (cadr entry) 2)))
+ (cond ((equal status "installed")
+ (push pkg installed))
+ ((member status '("available" "new"))
+ (push pkg available)))))
+ ;; Loop through list of installed packages, finding upgrades
+ (dolist (pkg installed)
+ (let ((avail-pkg (assq (car pkg) available)))
+ (and avail-pkg
+ (version-list-< (cdr pkg) (cdr avail-pkg))
+ (push avail-pkg upgrades))))
+ upgrades))
+
+(defun package-menu-mark-upgrades ()
+ "Mark all upgradable packages in the Package Menu.
+For each installed package with a newer version available, place
+an (I)nstall flag on the available version and a (D)elete flag on
+the installed version. A subsequent \\[package-menu-execute]
+call will upgrade the package."
+ (interactive)
+ (unless (derived-mode-p 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
+ (let ((upgrades (package-menu--find-upgrades)))
+ (if (null upgrades)
+ (message "No packages to upgrade.")
+ (widen)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let* ((pkg (tabulated-list-get-id))
+ (upgrade (assq (car pkg) upgrades)))
+ (cond ((null upgrade)
+ (forward-line 1))
+ ((equal pkg upgrade)
+ (package-menu-mark-install))
+ (t
+ (package-menu-mark-delete))))))
+ (message "%d package%s marked for upgrading."
+ (length upgrades)
+ (if (= (length upgrades) 1) "" "s")))))
+
+(defun package-menu-execute (&optional noquery)
+ "Perform marked Package Menu actions.
+Packages marked for installation are downloaded and installed;
+packages marked for deletion are removed.
+Optional argument NOQUERY non-nil means do not ask the user to confirm."
+ (interactive)
+ (unless (derived-mode-p 'package-menu-mode)
+ (error "The current buffer is not in Package Menu mode"))
+ (let (install-list delete-list cmd id)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq cmd (char-after))
+ (unless (eq cmd ?\s)
+ ;; This is the key (PACKAGE . VERSION-LIST).
+ (setq id (tabulated-list-get-id))
+ (cond ((eq cmd ?D)
+ (push (cons (symbol-name (car id))
+ (package-version-join (cdr id)))
+ delete-list))
+ ((eq cmd ?I)
+ (push (car id) install-list))))
+ (forward-line)))
+ (when install-list
+ (if (or
+ noquery
+ (yes-or-no-p
+ (if (= (length install-list) 1)
+ (format "Install package `%s'? " (car install-list))
+ (format "Install these %d packages (%s)? "
+ (length install-list)
+ (mapconcat 'symbol-name install-list ", ")))))
+ (mapc 'package-install install-list)))
+ ;; Delete packages, prompting if necessary.
+ (when delete-list
+ (if (or
+ noquery
+ (yes-or-no-p
+ (if (= (length delete-list) 1)
+ (format "Delete package `%s-%s'? "
+ (caar delete-list)
+ (cdr (car delete-list)))
+ (format "Delete these %d packages (%s)? "
+ (length delete-list)
+ (mapconcat (lambda (elt)
+ (concat (car elt) "-" (cdr elt)))
+ delete-list
+ ", ")))))
+ (dolist (elt delete-list)
+ (condition-case-unless-debug err
+ (package-delete (car elt) (cdr elt))
+ (error (message (cadr err)))))
+ (error "Aborted")))
+ ;; If we deleted anything, regenerate `package-alist'. This is done
+ ;; automatically if we installed a package.
+ (and delete-list (null install-list)
+ (package-initialize))
+ (if (or delete-list install-list)
+ (package-menu--generate t t)
+ (message "No operations specified."))))
+
+(defun package-menu--version-predicate (A B)
+ (let ((vA (or (aref (cadr A) 1) '(0)))
+ (vB (or (aref (cadr B) 1) '(0))))
+ (if (version-list-= vA vB)
+ (package-menu--name-predicate A B)
+ (version-list-< vA vB))))
+
+(defun package-menu--status-predicate (A B)
+ (let ((sA (aref (cadr A) 2))
+ (sB (aref (cadr B) 2)))
+ (cond ((string= sA sB)
+ (package-menu--name-predicate A B))
+ ((string= sA "new") t)
+ ((string= sB "new") nil)
+ ((string= sA "available") t)
+ ((string= sB "available") nil)
+ ((string= sA "installed") t)
+ ((string= sB "installed") nil)
+ ((string= sA "held") t)
+ ((string= sB "held") nil)
+ ((string= sA "built-in") t)
+ ((string= sB "built-in") nil)
+ ((string= sA "obsolete") t)
+ ((string= sB "obsolete") nil)
+ (t (string< sA sB)))))
+
+(defun package-menu--description-predicate (A B)
+ (let ((dA (aref (cadr A) 3))
+ (dB (aref (cadr B) 3)))
+ (if (string= dA dB)
+ (package-menu--name-predicate A B)
+ (string< dA dB))))
+
+(defun package-menu--name-predicate (A B)
+ (string< (symbol-name (caar A))
+ (symbol-name (caar B))))
+
+;;;###autoload
+(defun list-packages (&optional no-fetch)
+ "Display a list of packages.
+This first fetches the updated list of packages before
+displaying, unless a prefix argument NO-FETCH is specified.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive "P")
+ (require 'finder-inf nil t)
+ ;; Initialize the package system if necessary.
+ (unless package--initialized
+ (package-initialize t))
+ (let (old-archives new-packages)
+ (unless no-fetch
+ ;; Read the locally-cached archive-contents.
+ (package-read-all-archive-contents)
+ (setq old-archives package-archive-contents)
+ ;; Fetch the remote list of packages.
+ (package-refresh-contents)
+ ;; Find which packages are new.
+ (dolist (elt package-archive-contents)
+ (unless (assq (car elt) old-archives)
+ (push (car elt) new-packages))))
+
+ ;; Generate the Package Menu.
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (set (make-local-variable 'package-menu--new-package-list)
+ new-packages)
+ (package-menu--generate nil t))
+ ;; The package menu buffer has keybindings. If the user types
+ ;; `M-x list-packages', that suggests it should become current.
+ (switch-to-buffer buf))
+
+ (let ((upgrades (package-menu--find-upgrades)))
+ (if upgrades
+ (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
+ (length upgrades)
+ (if (= (length upgrades) 1) "" "s")
+ (substitute-command-keys "\\[package-menu-mark-upgrades]")
+ (if (= (length upgrades) 1) "it" "them"))))))
+
+;;;###autoload
+(defalias 'package-list-packages 'list-packages)
+
+;; Used in finder.el
+(defun package-show-package-list (packages)
+ "Display PACKAGES in a *Packages* buffer.
+This is similar to `list-packages', but it does not fetch the
+updated list of packages, and it only displays packages with
+names in PACKAGES (which should be a list of symbols)."
+ (require 'finder-inf nil t)
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (package-menu--generate nil packages))
+ (switch-to-buffer buf)))
+
+(defun package-list-packages-no-fetch ()
+ "Display a list of packages.
+Does not fetch the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive)
+ (list-packages t))
+
+(provide 'package)
+
+;;; package.el ends here
--- /dev/null
+;;; synonyms.el --- Look up synonyms for a word or phrase in a thesaurus.
+;;
+;; Filename: synonyms.el
+;; Description: Look up synonyms for a word or phrase in a thesaurus.
+;; Author: Drew Adams
+;; Maintainer: Drew Adams (concat "drew.adams" "@" "oracle" ".com")
+;; Copyright (C) 2005-2014, Drew Adams, all rights reserved.
+;; Created: Tue Dec 20 14:39:26 2005
+;; Version: 0
+;; Package-Requires: ()
+;; Last-Updated: Thu Dec 26 09:51:41 2013 (-0800)
+;; By: dradams
+;; Update #: 2518
+;; URL: http://www.emacswiki.org/synonyms.el
+;; Doc URL: http://www.emacswiki.org/ThesauriAndSynonyms
+;; Keywords: text, dictionary, thesaurus, spelling, apropos, help
+;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x, 24.x
+;;
+;; Features that might be required by this library:
+;;
+;; `thingatpt', `thingatpt+'.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+;;
+;; Look up synonyms for a word or phrase in a thesaurus.
+;;
+;;
+;; Getting Started
+;; ---------------
+;;
+;; To use library Synonyms, you will need the Moby Thesaurus II file,
+;; `mthesaur.txt', available here:
+;;
+;; ftp://ibiblio.org/pub/docs/books/gutenberg/etext02/mthes10.zip
+;;
+;; Put this in your initialization file (~/.emacs):
+;;
+;; ;; The file names are absolute, not relative, locations
+;; ;; - e.g. /foobar/mthesaur.txt.cache, not mthesaur.txt.cache
+;; (setq synonyms-file <name & location of mthesaur.txt>)
+;; (setq synonyms-cache-file <name & location of your cache file>)
+;; (require 'synonyms)
+;;
+;; As an alternative to the first two lines, you can use Customize to
+;; set `synonyms-file' and `synonyms-cache-file' persistently. The
+;; second of these files is created by this library, to serve as a
+;; synonym cache for completion.
+;;
+;; The main command is `synonyms'. It prompts you for a word or
+;; phrase to look up in the thesaurus. The synonyms found are then
+;; displayed in buffer *Synonyms*. For example, `M-x synonyms RET
+;; democracy' displays synonyms for `democracy'.
+;;
+;; If you do not define `synonyms-file' and `synonyms-cache-file'
+;; prior to using command `synonyms', that command will prompt you to
+;; define them. If you want to use the same values during subsequent
+;; Emacs sessions, then you should use `M-x customize-option' to save
+;; those newly defined values.
+;;
+;;
+;; Some Definitions
+;; ----------------
+;;
+;; The thesaurus is divided into "entries", which are like glossary
+;; entries: each entry is followed by associated words and phrases,
+;; which, for lack of a better word, I refer to as "synonyms". For
+;; example, `democracy' is an entry, and it is followed by its
+;; synonyms. Some synonyms are not also entries. For example,
+;; `patriarchy' is in the thesaurus as a synonym but not as an entry.
+;;
+;; Note: What I call "synonyms" here are not necessarily synonyms, in
+;; the sense of having the same or even similar meanings. They are
+;; simply terms collected together with the same thesaurus entry
+;; because they are related in some way - the grouping is what
+;; defines their relation.
+;;
+;; In Moby Thesaurus II, the meanings of synonyms in the same group
+;; do have something in common, but this might be simply the fact
+;; that they are terms of a similar kind. For example, the
+;; "synonyms" following the `democracy' thesaurus entry are words
+;; such as `dictatorship' and `autocracy'. These are different forms
+;; of the same general thing: government - they are certainly not
+;; synonymous with each other or with the entry `democracy'.
+;;
+;;
+;; Searching the Thesaurus
+;; -----------------------
+;;
+;; The default input value for command `synonyms' is the word under
+;; the cursor. Alternatively, if a region is active and you are in
+;; Transient Mark mode (recommended), then it is the text in the
+;; region (selection).
+;;
+;; Your input is actually treated as a regular expression (regexp),
+;; so you can also input patterns like `for.*ion', which will match
+;; thesaurus entries `formation', `formulation', `fornication',
+;; `fortification', and `forward motion'. Note that the last of
+;; these is a phrase rather than a single word.
+;;
+;; Using a regexp as input is a powerful way to search, but be aware
+;; that it can be costly in CPU time and computer memory if the
+;; regexp is not appropriate. The regexp `.*' will, for example,
+;; likely use up available memory before being able to return the
+;; entire thesaurus (it's very large). You can always use `C-g' to
+;; interrupt a thesaurus search if you mistakenly use an inefficient
+;; regexp.
+;;
+;;
+;; Using a Prefix Argument To Do More
+;; ----------------------------------
+;;
+;; You can use a prefix argument to modify searching and the
+;; presentation of search results, as follows:
+;;
+;; `C-u' - Search for additional synonyms, in two senses:
+;;
+;; 1) Return also synonyms that are matched partially
+;; by the input.
+;;
+;; 2) Search the entire thesaurus for input matches,
+;; even if the input matches a thesaurus entry.
+;;
+;; `M--' - Append the search results to any previous search
+;; results, in buffer *Synonyms*. (Normally, the new
+;; results replace any previous results.)
+;;
+;; `C-u C-u' - `C-u' plus `M--': Search more and append results.
+;;
+;; If you find yourself often using a particular prefix argument (for
+;; example, to append results), then you might want to instead change
+;; the default behavior to reflect this preference. Options
+;; `synonyms-match-more-flag' and `synonyms-append-result-flag'
+;; correspond to using `C-u' and `M--', respectively. In fact, a
+;; prefix argument simply toggles the value of the corresponding
+;; option for the duration of the command. So, for example, if
+;; `synonyms-append-result-flag' is t and you use `M--', then results
+;; will not be appended.
+;;
+;; When partially matching input (`C-u', sense #1), complete synonyms
+;; are matched against your input. This means that you generally
+;; need not add a preceding or trailing `.*' to try to match a
+;; complete synonym. For example, input `format' will match the
+;; complete synonyms `conformation', `efformation', `format',
+;; `formation', `formative', `formational', `information',
+;; `informative', `informational', `malformation', `deformation',
+;; `reformation', `transformation', `reformatory', and so on - there
+;; is no need to input `.*format.*' to match the same synonyms.
+;;
+;; To better understand the meaning of #2 above for `C-u' (to
+;; continue the search even if your input matches an entry), try, for
+;; example, `C-u M-x synonyms RET widespread'. You'll see not only
+;; the main synonyms listed for `widespread' as an entry, but also
+;; lots of different meanings of `widespread', judging by the entries
+;; for which it is listed as a synonym:
+;;
+;; `accepted', `ample', `broad', `broadcast', `capacious',
+;; `catholic', `commodious', `commonness', `conventional',
+;; `currency', `current', `customary', `deep', `deltoid',
+;; `diffuse', `discrete', `dispersed', `disseminated',
+;; `dissipated', `distributed', `epidemic', `established',
+;; `everyday', `expansive', `extended', `extensive', `familiar',
+;; `fan shaped', `far flung', `far reaching', `flaring', `full',
+;; `general', `indiscriminate', `infinite', `large scale',
+;; `liberal', `normal', `normality', `open', `ordinary',
+;; `outstretched', `pervasive', `popular', `prescribed',
+;; `prescriptive', `prevailing', `prevalence', `prevalent',
+;; `public', `rampant', `received', `regnant', `regular',
+;; `regulation', `reign', `rife', `roomy', `ruling', `run',
+;; `scattered', `set', spacious`', `sparse', `splay', `sporadic',
+;; `sprawling', `spread', `standard', `stock', `straggling',
+;; `stretched out', `sweeping', `time-honored', `traditional',
+;; `universal', `usual', `vast', `voluminous', `wholesale', `wide
+;; open', `wide', and `wonted'.
+;;
+;; These are just the entries! Each of these is of course followed by
+;; its own synonyms - perhaps 100 or 300, including `widespread'.
+;;
+;; This list of entries is not the same list as the synonyms for
+;; entry `widespread'. There are words and phrases here that are not
+;; in the latter list, and vice versa. For example, the former (but
+;; not the latter) list includes `full'; the latter (but not the
+;; former) list includes `wide-reaching'.
+;;
+;; The latter are the words most closely related to `widespread'.
+;; The list above are the other thesaurus entries (corresponding to
+;; main categories) to which `widespread' is most closely related.
+;; Looking at all of the synonym groups in which `widespread' appears
+;; can tell you additional information about its meanings - and it
+;; can provide additional synonyms for `widespread'.
+;;
+;;
+;; Using Completion with Synonyms
+;; ------------------------------
+;;
+;; You can complete words and phrases in the minibuffer, as input to
+;; command `synonyms'. You can use library Synonyms together with
+;; library `Icicles to complete a partial word in a text buffer into a
+;; word or phrase in the thesaurus. If you use both libraries then
+;; load Icicles after Synonyms. For more information on Icicles, see
+;; `http://www.emacswiki.org/Icicles'.
+;;
+;; ** Minibuffer Input Completion **
+;;
+;; You can enter any text to match against thesaurus synonyms. When
+;; you are prompted by command `synonyms' to enter this text, you can
+;; also use input completion to complete to a thesaurus synonym.
+;; That is, even though you can enter any text (including a regexp),
+;; completion will only complete to synonyms in the thesaurus.
+;;
+;; If you load library Icicles, then a more powerful version of
+;; command `synonyms' is used. In particular, it lets you:
+;;
+;; - Use `S-TAB' during completion to see the list of all synonyms
+;; (thesaurus terms) that match your minibuffer input so far.
+;;
+;; - Use `next' (or repeated `S-TAB'), and `prior' (usually keys
+;; `Page Down' and `Page Up') during completion to cycle through
+;; the completion candidates (synonyms) that match your input.
+;;
+;; - Use `C-next' and `C-prior' during completion to display the
+;; synonyms of the current completion candidate.
+;;
+;; ** Completing Buffer Text Using the Thesaurus **
+;;
+;; Icicles also provides two commands for using completion to insert
+;; thesaurus entries in a buffer:
+;;
+;; - `icicle-complete-thesaurus-entry' completes a word in a text
+;; buffer to any word or phrase in the thesaurus. I bind it to
+;; `C-c /'.
+;;
+;; - `icicle-insert-thesaurus-entry' inserts thesaurus words and
+;; phrases in a text buffer. It is a multi-command, which means
+;; that, within a single call to it, you can insert any number of
+;; thesaurus entries, in succession. If you want to, you can
+;; write an entire book using a single call to
+;; `icicle-insert-thesaurus-entry'!
+;;
+;;
+;; Browsing the Thesaurus
+;; ----------------------
+;;
+;; Besides using command `synonyms' to search for synonyms, you can
+;; use Synonyms to browse the thesaurus. This is really just the
+;; same thing, but key and mouse bindings are provided in buffer
+;; *Synonyms*, so you need not input anything - just point and click
+;; the hyperlinks. Buffer *Synonyms* is in Synonyms major mode,
+;; which provides a few additional features.
+;;
+;; You can still choose to search for additional synonyms or append
+;; search results, without bothering with a prefix argument, by using
+;; modifier keys (Control, Meta) with a mouse click.
+;;
+;; Another way of browsing is to revisit previous search-result
+;; pages. You can do this using commands `synonyms-history-backward'
+;; and `synonyms-history-forward'. In buffer *Synonyms*, these are
+;; bound to the following key sequences, for convenience:
+;;
+;; `l', `p', `mouse-4' - `synonyms-history-backward'
+;; `r', `n', `mouse-5' - `synonyms-history-forward'
+;;
+;; The `l' and `r' bindings correspond to the history bindings in
+;; Info. The `p' and `n' bindings stand for "previous" and "next".
+;; The bindings to additional mouse buttons correspond to typical
+;; bindings for Back and Forward in Web browsers.
+;;
+;; In addition to these bindings, the same history commands can be
+;; accessed by clicking links [Back] and [Forward] with `mouse-2'.
+;;
+;; If you have previously used the append option (via, for example,
+;; `M-mouse2'), so that there are multiple search results in buffer
+;; *Synonyms*, then using a history command simply takes you to the
+;; preceding (for [Back]) or following (for [Forward]) result in the
+;; buffer, measured from the current cursor position. Depending on
+;; the cursor position, this might be different from the previous or
+;; next search made previously.
+;;
+;; This is for convenience, but it is also more efficient in the case
+;; of a regexp search that takes a long time. Except for this
+;; special treatment of appended results, whenever you navigate the
+;; search-results history you are actually searching again for a
+;; synonym you sought previously. The case of appended results is
+;; analogous to accessing a Web browser cache when navigating the
+;; history.
+;;
+;; You can of course use modifier keys (Control, Meta) while you
+;; click links [Back] and [Forward], to impose their usual behavior:
+;; search for additional synonyms or append search results, or both.
+;;
+;; Finally, some people prefer menus, so there is a Synonyms menu-bar
+;; menu when you are in Synonyms mode, complete with all of the
+;; functionalities described above.
+;;
+;; For more information on the browsing possibilities in buffer
+;; *Synonyms*, use `?' in Synonyms mode.
+;;
+;;
+;; Dictionary Definitions, Antonyms, etc.
+;; --------------------------------------
+;;
+;; Synonyms works with a large but simple database of groups of words
+;; and phrases that are synonyms of each other. This database does
+;; not provide definitions of words or phrases; it simply groups
+;; them. Command `synonym-definition' (aka `dictionary-definition')
+;; lets you look up a word or phrase (or a regexp) using one or more
+;; dictionaries on the Web. That is usually the best source for this
+;; kind of information, but you obviously need an Internet connection
+;; to use this command.
+;;
+;; Options (variables) `synonyms-dictionary-url' and
+;; `synonyms-dictionary-alternate-url' are URLs you can set to point
+;; to the dictionaries of your choice. The default value of
+;; `synonyms-dictionary-alternate-url' looks up the search term in
+;; multiple dictionaries, and it lets you use wildcards. Use `C-h v
+;; synonyms-dictionary-alternate-url' for more information. The
+;; default value of `synonyms-dictionary-url' usually provides a
+;; quicker answer. Both of these URLs also give you access to
+;; additional information about the search term (antonyms, etymology,
+;; even pronunciation).
+;;
+;; In buffer *Synonyms*, you can simply hit `d' followed by `RET' or
+;; `mouse-2' to look up a term that is in the buffer. Just as for
+;; looking up a synonym by clicking `mouse-2', if you select text
+;; (region), then that text is looked up.
+;;
+;;
+;; A Cache File of Synonyms
+;; ------------------------
+;;
+;; The very first time you use Synonyms, a large list of synonyms
+;; will be compiled and written to a cache file. This is slow - it
+;; takes 2-3 minutes - but it is only a one-time cost. From then on,
+;; whenever you first use Synonyms during an Emacs session, the cache
+;; file will be read (quickly), to create the list of synonyms that
+;; are used for minibuffer completion.
+;;
+;;
+;; Using Other Thesauri, Dictionaries, and so on - CSV data
+;; --------------------------------------------------------
+;;
+;; There is nothing in library Synonyms that ties it to the Moby
+;; Thesaurus II thesaurus. All of its functionality will work with
+;; any file of comma-separated values. Each line of such a file is
+;; interpreted as a synonym group, as understood here, and the first
+;; word or phrase on each line is interpreted as a thesaurus entry,
+;; as understood here. This means only that search results are
+;; organized into sections with entry headers.
+;;
+;; If, for example, you had a CSV file of personal contacts, where
+;; the first term in each line was a last name or a company name,
+;; then you could use library Synonyms to query it, producing the
+;; same kind of output as for the thesaurus.
+;;
+;; One thing to keep in mind if you try to use library Synonyms with
+;; a different CSV file is that there are several different CSV-file
+;; syntaxes. The one that Synonyms is built to use is a simple one,
+;; with no quote marks around entries and no embedded quote marks
+;; within entries.
+;;
+;; Similarly, there is nothing here that limits the functionality to
+;; English. If you had a thesaurus in another language, it should
+;; work as well.
+;;
+;; Currently, Synonyms works with a single raw synonyms file
+;; (thesaurus) and a corresponding single cache file (for
+;; completion). However, it would be easy to extend the
+;; functionality to use multiple thesauri or, in general, multiple
+;; CSV files. Suggestions of requirements (e.g. ways to select a
+;; thesaurus for particular passages of text) are welcome.
+
+;;
+;;
+;; Things Defined Here
+;; -------------------
+;;
+;; Faces defined here -
+;;
+;; `synonyms-heading', `synonyms-search-text',
+;; `synonyms-mouse-face'.
+;;
+;;
+;; User options (variables) defined here -
+;;
+;; `synonyms-append-result-flag', `synonyms-cache-file',
+;; `synonyms-file', `synonyms-fill-column',
+;; `synonyms-match-more-flag', `synonyms-mode-hook',
+;; `synonyms-use-cygwin-flag'.
+;;
+;; Commands defined here -
+;;
+;; `dictionary-definition', `synonyms', `synonyms-append-result',
+;; `synonyms-append-result-no-read', `synonyms-definition',
+;; `synonyms-definition-mouse', `synonyms-definition-no-read',
+;; `synonyms-ensure-synonyms-read-from-cache',
+;; `synonyms-history-backward', `synonyms-history-forward',
+;; `synonyms-make-obarray', `synonyms-match-more',
+;; `synonyms-match-more-no-read',
+;; `synonyms-match-more+append-result',
+;; `synonyms-match-more+append-result-no-read', `synonyms-mode',
+;; `synonyms-mouse', `synonyms-mouse-append-result',
+;; `synonyms-mouse-match-more',
+;; `synonyms-mouse-match-more+append-result', `synonyms-no-read',
+;; `synonyms-write-synonyms-to-cache'.
+;;
+;; Non-interactive functions defined here -
+;;
+;; `synonyms-action', `synonyms-add-history-links',
+;; `synonyms-default-regexp', `synonyms-define-cache-file',
+;; `synonyms-define-synonyms-file', `synonyms-format-entries',
+;; `synonyms-format-entry', `synonyms-format-finish',
+;; `synonyms-format-synonyms',
+;; `synonyms-hack-backslashes-if-cygwin', `synonyms-lookup',
+;; `synonyms-nearest-word', `synonyms-file-readable-p',
+;; `synonyms-search-entries', `synonyms-search-synonyms',
+;; `synonyms-show-synonyms', `synonyms-file-writable-p'.
+;;
+;; Internal variables defined here -
+;;
+;; `synonyms-history', `synonyms-history-forward',
+;; `synonyms-list-for-obarray', `synonyms-mode-map',
+;; `synonyms-obarray', `synonyms-search-text'.
+;;
+;; Key bindings made here - see `synonyms-mode'. All key bindings
+;; are local to Synonyms mode; no global bindings are made here.
+
+;;
+;;
+;; Acknowledgements
+;; ----------------
+;;
+;; The basic functionality provided here was derived from library
+;; `mthesaur.el', by Tad Ashlock <taashloNOSPAMcyberdude.com>. That
+;; library, in turn, was inspired by library `thesaurus.el', by Ray
+;; Nickson. Thanks also to those who sent helpful bug reports.
+;;
+;;
+;; Note on MS Windows Emacs 20 and Cygwin `grep'
+;; ---------------------------------------------
+;;
+;; There is apparently a bug in the Emacs (at least versions 20-22) C
+;; code that implements function `call-process' on MS Windows. When
+;; using native Windows Emacs with Cygwin commands, such as `grep',
+;; the C code removes a level of backslashes in some cases, so string
+;; arguments supplied to `call-process' need to have twice as many
+;; backslashes as they should need in those cases. It is for this
+;; reason that option `synonyms-use-cygwin-flag' is supplied here.
+;; When that option is non-nil, backslashes in regexps are hacked to
+;; do the right thing. (In Emacs 20, this means doubling the
+;; backslashes; in Emacs 21-22, this means doubling them unless there
+;; are spaces in the search string.)
+;;
+;;
+;; Maybe To Do?
+;; ------------
+;;
+;; 1. It would be ideal to have not only synonym information but also
+;; definitions, antonyms, more general and more specific terms,
+;; filtering by part of speech (verb vs adjective etc.), and so
+;; on. A good example of what I'd really like to have is provided
+;; by the free Windows program WordWeb (available here:
+;; http://wordweb.info/). Combining that functionality with
+;; Icicles completion features would provide a great tool, IMO.
+;;
+;; `synonyms-definition*' goes a long way toward providing this,
+;; and perhaps it is the best way to go, since there is so much
+;; more definitional info on the Web.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Change Log:
+;;
+;; 2012/08/21 dadams
+;; Call tap-put-thing-at-point-props after load thingatpt+.el.
+;; 2012/08/18 dadams
+;; Invoke tap-define-aliases-wo-prefix if thingatpt+.el is loaded.
+;; 2012/03/02 dadams
+;; Require cl.el at compile time only for Emacs 20.
+;; 2011/07/30 dadams
+;; Moved Icicles code to icicles-cmd2.el. Removed soft-require of icicles.el.
+;; 2011/02/11 dadams
+;; Better defaults for faces, for dark backgrounds.
+;; 2011/01/04 dadams
+;; Added autoload cookies (for defgroup, defface, defcustom, and commands).
+;; 2010/08/20 dadams
+;; synonyms - non-Icicles version: Made ARG optional too.
+;; synonyms(-no-read|-history-(backward|forward)):
+;; Use ARG, not current-prefix-arg.
+;; 2010/01/12 dadams
+;; synonyms-history-(backward|forward): save-excursion + set-buffer -> with-current-buffer.
+;; 2007/12/05 dadams
+;; synonyms-obarray: Removed * doc-string prefix.
+;; 2007/02/10 dadams
+;; icicle-sort-case-insensitively -> icicle-case-insensitive-string-less-p.
+;; 2006/12/22 dadams
+;; Renamed group synonyms to Synonyms. :group 'icicles -> :group 'Icicles.
+;; 2006/03/31 dadams
+;; synonyms-write-synonyms-to-cache: Use prin1 instead of pp.
+;; 2006/03/17 dadams
+;; synonyms-file-(read|writ)able-p: Put non-empty string condition first.
+;; 2006/03/14 dadams
+;; synonyms-file-(read|writ)able-p: Make sure also not a directory.
+;; 2006/03/12 dadams
+;; synonyms-ensure-synonyms-read-from-cache, synonyms-define-synonyms-file:
+;; Set synonyms(-cache)-file to expanded version.
+;; 2006/03/01 dadams
+;; Updated Commentary to mention Icicles completion of synonyms.
+;; 2006/02/02 dadams
+;; synonyms-define-cache-file: Fixed typo.
+;; 2006/01/28 dadams
+;; synonyms-define-cache-file: wrap file-name-directory in expand-file-name.
+;; 2006/01/19 dadams
+;; synonyms-format-finish: Minor tweak to regexp: space and tab, but not newline or formfeed.
+;; 2006/01/18 dadams
+;; Added dictionary definition lookup:
+;; Added: synonyms-dictionary(-alternate)-url, synonyms-definition*.
+;; Bound synonyms-definition-*.
+;; 2006/01/14 dadams
+;; Bug fixes -
+;; Make sure file name is expanded (thanks to Nikos Apostolakis):
+;; synonyms-search-(entries|synonyms): Expand file name.
+;; synonyms-define-*-file: Set variable after expanding file name.
+;; synonyms-format-entry, synonyms-history-*, synonyms-add-history-links:
+;; Raise error if search finds nothing.
+;; synonyms-hack-backslashes-if-cygwin: Don't double if spaces and not Emacs 20.
+;; Renamed synonyms-double-backslashes-if-cygwin to synonyms-hack-backslashes-if-cygwin.
+;; synonyms-mode-map: swapped bindings for C-mouse-2 and C-down-mouse-2, for Emacs 22.
+;; 2006/01/11 dadams
+;; Fixed typo: require 'synonyms. (Thanks to Nikos Apostolakis.)
+;; 2006/01/07 dadams
+;; Added :link.
+;; 2006/01/04 dadams
+;; synonyms-format-finish: Don't skip numbered header, so highlight multiple synonyms in entry.
+;; 2006/01/02 dadams
+;; Added: synonyms-define-cache-file, synonyms-define-synonyms-file,
+;; synonyms-file-readable-p, synonyms-file-writable-p.
+;; synonyms-make-obarray: Use synonyms-define-synonyms-file.
+;; Use synonyms-mode, to get modified syntax (bug fix).
+;; synonyms-write-synonyms-to-cache: Use synonyms-define-cache-file.
+;; synonyms-ensure-synonyms-read-from-cache: Use synonyms-file-readable-p.
+;; synonyms(-cache)-file: Use empty string as initial value.
+;; Thanks to Alex Schroeder [alexNOSPAMemacswiki.org] for suggestion to prompt for file names.
+;; 2005/12/31 dadams
+;; Added menu-bar Synonyms menu.
+;; Renamed synonyms-read-synonyms-from-cache to synonyms-ensure-synonyms-read-from-cache.
+;; Call it from synonyms, not from synonyms-mode.
+;; Defined synonyms-mode-map per convention.
+;; synonyms-match-more, synonyms-append-result, synonyms-match-more+append-result:
+;; Use synonyms, not synonyms-no-read.
+;; Added: synonyms-*-no-read. Bound those, not the new read versions.
+;; 2005/12/29 dadams
+;; Treat modifiers with clicks on [Back] and [Forward] links.
+;; synonyms-history-(backward|forward): Add prefix arg. Bind options.
+;; synonyms-mode, synonyms-lookup: Disable undo.
+;; 2005/12/28 dadams
+;; Added: synonyms-history-(backward|forward), synonyms-add-history-links, synonyms-link.
+;; Added: [Back] and [Forward] links.
+;; synonyms-show-synonyms: Put cursor on first synonym.
+;; synonyms-mouse, synonyms-lookup: Removed save-excursion.
+;; synonyms-mouse: Treat clicks on [Back] and [Forward] links too.
+;; synonyms-format-finish: Added save-excursion for last part: filling and adding mouse-face.
+;; synonyms-nearest-word: Remove text properties.
+;; synonyms: Use synonym-action.
+;; synonyms-lookup: When no synonyms found, remove search-text from history.
+;; Require cl.el when compile.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth
+;; ;; Floor, Boston, MA 02110-1301, USA.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Code:
+
+(eval-when-compile (when (< emacs-major-version 21) (require 'cl))) ;; push, pop
+
+(require 'thingatpt nil t) ;; (no error if not found): word-at-point
+(when (and (require 'thingatpt+ nil t);; (no error if not found): word-nearest-point
+ (fboundp 'tap-put-thing-at-point-props)) ; >= 2012-08-21
+ (tap-define-aliases-wo-prefix)
+ (tap-put-thing-at-point-props))
+
+;; Quiet the byte-compiler.
+(defvar appendp) ; Here.
+(defvar morep) ; Here.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+;;; Faces (alphabetical) -----------------------------------
+
+;;;###autoload
+(defgroup Synonyms nil
+ "Commands to look up synonyms in a thesaurus."
+ :prefix "synonyms-"
+ :group 'convenience :group 'help :group 'apropos :group 'matching
+ :link `(url-link :tag "Send Bug Report"
+ ,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\
+synonyms.el bug: \
+&body=Describe bug here, starting with `emacs -q'. \
+Don't forget to mention your Emacs and library versions."))
+ :link '(url-link :tag "Other Libraries by Drew"
+ "http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries")
+ :link '(url-link :tag "Download" "http://www.emacswiki.org/cgi-bin/wiki/synonyms.el")
+ :link '(url-link :tag "Description" "http://www.emacswiki.org/cgi-bin/wiki/Synonyms")
+ :link '(emacs-commentary-link :tag "Commentary" "synonyms"))
+
+;;;###autoload
+(defface synonyms-heading '((((background dark)) (:foreground "Yellow"))
+ (t (:foreground "Blue")))
+ "*Face for different synonym types."
+ :group 'Synonyms :group 'faces)
+
+;;;###autoload
+(defface synonyms-search-text '((t (:foreground "Red")))
+ "*Face for the term whose synonyms were sought."
+ :group 'Synonyms :group 'faces)
+
+;;;###autoload
+(defface synonyms-link '((((background dark)) (:foreground "Yellow" :underline t))
+ (t (:foreground "Blue" :underline t)))
+ "*Face for history links."
+ :group 'Synonyms :group 'faces)
+
+;;;###autoload
+(defface synonyms-mouse-face '((((background dark)) (:background "DarkCyan"))
+ (t (:background "Cyan")))
+ "*Mouse face for the term whose synonyms were sought."
+ :group 'Synonyms :group 'faces)
+
+
+
+
+;;; User Options (alphabetical) ----------------------------
+
+;;;###autoload
+(defcustom synonyms-append-result-flag nil
+ "*t means that `synonyms' appends search result to previous results.
+No other value, besides t, has this effect.
+
+This can be overridden by using a negative prefix argument,
+for example, `M--'. If you use `C-u C-u', then both this and
+`synonyms-match-more-flag' are overridden."
+ :type 'boolean :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-cache-file ""
+ "*Location to write cache file containing synonyms.
+Written to save the list of synonyms used for completion.
+This is an absolute (complete-path) location, including the file name."
+ :type '(file :must-match t) :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-file ""
+ "*Location of thesaurus file `mthesaur.txt'.
+This is an absolute (complete-path) location, including the file name."
+ :type '(file :must-match t) :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-fill-column 80
+ "*Synonyms* buffer text is wrapped (filled) to this many columns."
+ :type 'integer :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-match-more-flag nil
+ "*t means additional thesaurus entries can be matched by `synonyms'.
+No other value, besides t, has this effect.
+
+A value of t means two things:
+ 1) Input can match parts of synonyms, in addition to whole synonyms.
+ 2) All synonyms are shown, even if input matches a thesaurus entry.
+
+This can be overridden by using a positive prefix argument,
+ for example, `C-u'. If you use `C-u C-u', then both this and
+`synonyms-append-result-flag' are overridden."
+ :type 'boolean :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-mode-hook nil
+ "*Normal hook run when entering Thesaurus mode."
+ :type 'hook :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-use-cygwin-flag nil
+ "*Non-nil means to double backslashes in arguments to `call-process'.
+There is apparently a bug in the Emacs (at least versions 20-22) C
+code that implements function `call-process' on MS Windows. When
+using native Windows Emacs with Cygwin commands, such as `grep', the C
+code removes a level of backslashes, so string arguments supplied to
+`call-process' need to have twice as many backslashes as they should
+need. If you are using Emacs on Windows and Cygwin `grep', then you
+probably will want to use a non-nil value for
+`synonyms-use-cygwin-flag'."
+ :type 'boolean :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-dictionary-url "http://dictionary.reference.com/search?q="
+ "*URL of a Web dictionary lookup. Text to look up is appended to this.
+See also `synonyms-dictionaries-url'."
+ :type 'string :group 'Synonyms)
+
+;;;###autoload
+(defcustom synonyms-dictionary-alternate-url "http://www.onelook.com/?ls=b&w="
+ "*URL of a Web dictionary lookup. Text to look up is appended to this.
+The default value, \"http://www.onelook.com/?ls=b&w=\" lets you use `?'
+and `*' as wildcards in the terms you look up. These are not used as
+regexp wildcards, however. `?' stands for any single character, and
+`*' stands for any sequence of characters. In terms of regexp syntax,
+`?' here is equivalent to the regexp `.', and `*' is equivalent to the
+regexp `.*'. See http://www.onelook.com/?c=faq#patterns for more
+information on the allowed wildcard patterns.
+See also `synonyms-dictionary-url'."
+ :type 'string :group 'Synonyms)
+
+;;; Internal variables (alphabetical) ----------------------
+
+(defvar synonyms-history nil "Minibuffer history list for thesaurus lookup.")
+
+(defvar synonyms-history-forward nil
+ "Minibuffer history list for thesaurus lookup using `synonyms-history-backward'.")
+
+(defvar synonyms-list-for-obarray nil "List of synonyms to be used for completion")
+
+(defvar synonyms-mode-map nil "Keymap for `synonyms-mode'.")
+
+(unless synonyms-mode-map
+ (let ((map (make-sparse-keymap "Synonyms")))
+ (define-key map [(?d) (mouse-2)] 'synonyms-definition-mouse)
+ (define-key map "d\r" 'synonyms-definition-no-read)
+ (define-key map "s" 'synonyms)
+ (define-key map [S-return] 'synonyms)
+ (define-key map "\r" 'synonyms-no-read)
+ (define-key map [C-return] 'synonyms-match-more-no-read)
+ (define-key map [M-return] 'synonyms-append-result-no-read)
+ (define-key map [C-M-return] 'synonyms-match-more+append-result-no-read)
+ (define-key map [mouse-2] 'synonyms-mouse)
+ (define-key map [C-mouse-2] 'undefined)
+ (define-key map [C-down-mouse-2] 'synonyms-mouse-match-more) ; Get rid of `facemenu-mouse-menu'
+ (define-key map [M-mouse-2] 'synonyms-mouse-append-result)
+ (define-key map [C-M-mouse-2] 'synonyms-mouse-match-more+append-result)
+ (define-key map "l" 'synonyms-history-backward) ; As in Info
+ (define-key map "p" 'synonyms-history-backward) ; As in previous
+ (define-key map "r" 'synonyms-history-forward) ; As in Info
+ (define-key map "n" 'synonyms-history-forward) ; As in next
+ (define-key map [mouse-4] 'synonyms-history-backward)
+ (define-key map [mouse-5] 'synonyms-history-forward)
+ (define-key map " " 'scroll-up) ; SPC
+ (define-key map "\^?" 'scroll-down) ; DEL
+ (define-key map "?" 'describe-mode)
+ (define-key map "q" 'quit-window)
+ (define-key map [menu-bar] (make-sparse-keymap))
+ (define-key map [menu-bar synonyms] (cons "Synonyms" map))
+ (define-key map [synonyms-help] '("Help" . describe-mode))
+ (define-key map [synonyms-separator-2] '("--"))
+ (define-key map [synonyms-next] '("Show Next" . synonyms-history-forward))
+ (put 'synonyms-history-forward 'menu-enable 'synonyms-history-forward)
+ (define-key map [synonyms-previous] '("Show Previous" . synonyms-history-backward))
+ (put 'synonyms-history-backward 'menu-enable '(and synonyms-history (cdr synonyms-history)))
+ (define-key map [synonyms-separator] '("--"))
+ (define-key map [synonyms-more-append]
+ '("Find (Max), Append Results" . synonyms-match-more+append-result))
+ (define-key map [synonyms-append]
+ '("Find, Append Results" . synonyms-append-result))
+ (define-key map [synonyms-more] '("Find (Max)" . synonyms-match-more))
+ (define-key map [synonyms-synonyms] '("Find" . synonyms))
+ (setq synonyms-mode-map map)))
+
+;; 103307 is the smallest prime > 103304, which is the number of synonyms.
+(defvar synonyms-obarray (make-vector 103307 0)
+ "Obarray of synonyms. Used for completion.")
+
+(defvar synonyms-search-text nil "Current text being looked up (matched).")
+
+
+
+
+;;; Functions ----------------------------------------------
+
+;;;###autoload
+(define-derived-mode synonyms-mode text-mode "Synonyms"
+ "Major mode for browsing thesaurus entries (synonyms).
+Like Text mode but with these additional key bindings:
+
+ \\<synonyms-mode-map>\\[synonyms-mouse], \\[synonyms-no-read], \\[synonyms] - \
+Look up synonyms for a word or phrase
+ \\[synonyms-mouse-match-more], \\[synonyms-match-more] - Like \\[synonyms-no-read], but \
+try to match more terms
+ \\[synonyms-mouse-append-result], \\[synonyms-append-result] - Like \\[synonyms-no-read], but \
+add result to previous result
+ \\[synonyms-mouse-match-more+append-result], \\[synonyms-match-more+append-result] - Like \
+\\[synonyms-match-more] and \\[synonyms-append-result] combined
+
+ \\[scroll-up] - Scroll down through the buffer of synonyms
+ \\[scroll-down] - Scroll up through the buffer of synonyms
+ \\[describe-mode] - Display this help
+ \\[quit-window] - Quit Synonyms mode
+
+Of the various key bindings that look up synonyms, the most flexible
+is \\[synonyms] - it prompts you for the search string to match. This
+can be a regular expression (regexp). The other lookup bindings are
+for convenience - just click.
+
+In Synonyms mode, Transient Mark mode is enabled.
+
+Options `synonyms-match-more-flag' and `synonyms-append-result-flag'
+affect synonym matching and the results. For convenience, \\[synonyms-mouse-match-more],
+\\[synonyms-mouse-append-result], and \\[synonyms-mouse-match-more+append-result] \
+toggle the effect of those options for the
+duration of the command.
+
+Note that even though Synonyms mode is similar to Text mode, buffer
+`*Synonyms*' is read-only, by default - use `C-x C-q' to toggle.
+
+Turning on Synonyms mode runs the normal hooks `text-mode-hook' and
+`synonyms-mode-hook' (in that order)."
+
+ ;; Synonyms to account for:
+ ;; `$', `1', `0': $100-a-plate dinner; `2': catch-22, V-2; `3': 3-D; `9': strontium 90.
+ ;; To match `$', you will of course need to escape it: `\$'.
+ (modify-syntax-entry ?- "w" synonyms-mode-syntax-table) ; Make hyphen (-) a word character.
+ (modify-syntax-entry ?1 "w" synonyms-mode-syntax-table) ; Make numerals 1,2,3,9,0 word characters.
+ (modify-syntax-entry ?2 "w" synonyms-mode-syntax-table)
+ (modify-syntax-entry ?3 "w" synonyms-mode-syntax-table)
+ (modify-syntax-entry ?9 "w" synonyms-mode-syntax-table)
+ (modify-syntax-entry ?0 "w" synonyms-mode-syntax-table)
+ (modify-syntax-entry ?$ "w" synonyms-mode-syntax-table) ; Make dollar ($) a word character.
+ (buffer-disable-undo)
+ (setq fill-column synonyms-fill-column)
+ (set (make-local-variable 'transient-mark-mode) t))
+
+;;;###autoload
+(defun synonyms-ensure-synonyms-read-from-cache ()
+ "Ensure synonyms are in `synonyms-obarray', from `synonyms-cache-file'.
+If this file does not yet exist, then it and the obarray are created.
+Creating the obarray for the first time takes 2-3 minutes.
+This does nothing if the obarray is already complete."
+ (interactive)
+ (unless (intern-soft "synonym" synonyms-obarray) ; Do nothing if already complete.
+ (setq synonyms-list-for-obarray () ; Just to make sure.
+ synonyms-cache-file (expand-file-name synonyms-cache-file))
+ (if (synonyms-file-readable-p synonyms-cache-file)
+ (let ((list-buf (find-file-noselect synonyms-cache-file 'nowarn 'raw))
+ (obarray synonyms-obarray))
+ (unwind-protect
+ (setq synonyms-list-for-obarray (read list-buf))
+ (kill-buffer list-buf)))
+ (synonyms-make-obarray) ; Create obarray from scratch
+ (synonyms-write-synonyms-to-cache)))) ; and write it out, for next time.
+
+;;;###autoload
+(defun synonyms-make-obarray ()
+ "Fill `synonyms-obarray' with the available synonyms."
+ (interactive)
+ (unless (intern-soft "synonym" synonyms-obarray) ; Do nothing if already complete.
+ (synonyms-define-synonyms-file)
+ (with-temp-message "Building synonyms list for completion. This will take a few minutes..."
+ (let ((thesaurus-buf (find-file-noselect synonyms-file 'nowarn 'raw))
+ synonym)
+ (unwind-protect
+ (save-current-buffer
+ (set-buffer thesaurus-buf)
+ (goto-char (point-min))
+ (synonyms-mode) ; To use the modified syntax table.
+ (while (re-search-forward "\\(\\(\\w\\|[ ]\\)+\\)\\(,\\|$\\)" nil t)
+ (setq synonym (buffer-substring (match-beginning 1) (match-end 1)))
+ (intern synonym synonyms-obarray)))
+ (kill-buffer thesaurus-buf))))))
+
+(defun synonyms-define-synonyms-file ()
+ "Prompt user to define `synonyms-file', unless it is readable."
+ (setq synonyms-file (expand-file-name synonyms-file))
+ (unless (synonyms-file-readable-p synonyms-file)
+ (while (not (synonyms-file-readable-p synonyms-file))
+ (setq synonyms-file (read-file-name "Thesaurus file: " nil nil 'confirm "mthesaur.txt")))
+ (custom-set-variables (list 'synonyms-file
+ (setq synonyms-file (expand-file-name synonyms-file))
+ 'now))))
+
+;;;###autoload
+(defun synonyms-write-synonyms-to-cache ()
+ "Write synonyms in `synonyms-obarray' to file `synonyms-cache-file'."
+ (interactive)
+ (synonyms-define-cache-file)
+ (with-temp-message "Writing synonyms cache file..."
+ (with-temp-file synonyms-cache-file
+ (mapatoms (lambda (symb) (push symb synonyms-list-for-obarray)) synonyms-obarray)
+ (prin1 synonyms-list-for-obarray (current-buffer)))))
+
+(defun synonyms-define-cache-file ()
+ "Prompt user to define `synonyms-cache-file', unless it is writable."
+ (unless (synonyms-file-writable-p synonyms-cache-file)
+ (while (not (synonyms-file-writable-p synonyms-cache-file))
+ (setq synonyms-cache-file
+ (read-file-name "Cache file: "
+ (expand-file-name (file-name-directory synonyms-file)) nil nil
+ (concat (file-name-nondirectory synonyms-file) ".cache"))))
+ (custom-set-variables (list 'synonyms-cache-file
+ (setq synonyms-cache-file (expand-file-name synonyms-cache-file))
+ 'now))))
+
+(defun synonyms-file-readable-p (file)
+ "Return non-nil if FILE (a string) names a readable file."
+ (and (not (string= "" file)) (file-readable-p file) (not (file-directory-p file))))
+
+(defun synonyms-file-writable-p (file)
+ "Return non-nil if FILE (a string) names a writable file."
+ (and (not (string= "" file)) (file-writable-p file) (not (file-directory-p file))))
+
+(defun synonyms (&optional arg regexp)
+ "Show synonyms that match a regular expression (e.g. a word or phrase).
+You are prompted for the regexp. By default, it is the text
+of the region, if it is active and `transient-mark-mode' is enabled,
+or the nearest word to the cursor, if not.
+
+Option `synonyms-match-more-flag' non-nil means additional thesaurus
+ entries can be matched. This can be more time-consuming. It means
+ two things:
+
+ 1) Input can match parts of synonyms, in addition to whole synonyms.
+ 2) All synonyms are shown, even if input matches a thesaurus entry.
+
+Option `synonyms-append-result-flag' non-nil means to append search
+ result to previous results.
+
+A prefix argument toggles the meaning of each of those options for the
+duration of the command:
+
+ If `C-u' or `C-u C-u', then toggle `synonyms-match-more-flag'.
+ If negative or `C-u C-u', then toggle `synonyms-append-result-flag'.
+
+\(`C-u C-u' thus means toggle both options.)
+
+When called from Lisp, optional second argument REGEXP is the regexp
+to match (no prompting)."
+ (interactive "P")
+ (synonyms-ensure-synonyms-read-from-cache) ; Fill `synonyms-obarray', for use in completion.
+ (let* ((num-arg (prefix-numeric-value arg))
+ (morep (eq synonyms-match-more-flag (atom arg)))
+ (appendp (eq synonyms-append-result-flag (and (wholenump num-arg)
+ (/= 16 num-arg))))
+ (default-search-text (or regexp (synonyms-default-regexp)))
+ (search-text (or regexp
+ (let ((case-fold-search t)) ; Case-insensitive completion.
+ (completing-read
+ "Show synonyms for word or phrase (regexp): "
+ synonyms-obarray nil nil nil 'synonyms-history
+ default-search-text)))))
+ (synonyms-action search-text)))
+
+(defun synonyms-action (search-text)
+ "Helper function for command `synonyms'.
+APPENDP and MOREP are free here."
+ (setq synonyms-search-text search-text) ; Save it.
+ (when (string= "" search-text) (error "No text to look up"))
+ (unless (member search-text synonyms-history) (push search-text synonyms-history))
+ ;; Change `.' to `[^,]' in `search-text', so we don't mix terms.
+ (setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
+ (synonyms-lookup search-text (and (boundp 'appendp) appendp) (and (boundp 'morep) morep)))
+
+;;;###autoload
+(defun synonyms-no-read (arg)
+ "Same as command `synonyms', but uses the default input text (regexp)."
+ (interactive "P")
+ (let* ((num-arg (prefix-numeric-value arg))
+ (morep (eq synonyms-match-more-flag (atom arg)))
+ (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg))))
+ (search-text (synonyms-default-regexp)))
+ (setq synonyms-search-text search-text) ; Save it.
+ (when (string= "" search-text) (error "No text to look up"))
+ (unless (member search-text synonyms-history) (push search-text synonyms-history))
+ ;; Change `.' to `[^,]' in `search-text', so we don't mix terms.
+ (setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
+ (synonyms-lookup search-text appendp morep)))
+
+;;;###autoload
+(defun synonyms-match-more ()
+ "Same as using `synonyms' with `synonyms-match-more-flag' = t."
+ (interactive)
+ (let ((synonyms-match-more-flag t))
+ (synonyms)))
+
+;;;###autoload
+(defun synonyms-match-more-no-read (arg)
+ "Same as using `synonyms' with `synonyms-match-more-flag' = t."
+ (interactive "P")
+ (let ((synonyms-match-more-flag t))
+ (synonyms-no-read arg)))
+
+;;;###autoload
+(defun synonyms-append-result ()
+ "Same as using `synonyms' with `synonyms-append-result-flag' = t."
+ (interactive)
+ (let ((synonyms-append-result-flag t))
+ (synonyms)))
+
+;;;###autoload
+(defun synonyms-append-result-no-read (arg)
+ "Same as using `synonyms' with `synonyms-append-result-flag' = t."
+ (interactive "P")
+ (let ((synonyms-append-result-flag t))
+ (synonyms-no-read arg)))
+
+;;;###autoload
+(defun synonyms-match-more+append-result ()
+ "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
+ (interactive)
+ (let ((synonyms-match-more-flag t)
+ (synonyms-append-result-flag t))
+ (synonyms)))
+
+;;;###autoload
+(defun synonyms-match-more+append-result-no-read (arg)
+ "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
+ (interactive "P")
+ (let ((synonyms-match-more-flag t)
+ (synonyms-append-result-flag t))
+ (synonyms-no-read arg)))
+
+;;;###autoload
+(defun synonyms-mouse (event arg)
+ "Show synonyms that match a regular expression (e.g. a word or phrase).
+The regexp to match is the synonym or region clicked with mouse-2. If
+the region is active, but a synonym elsewhere is clicked, that synonym
+is used, not the selected text.
+
+You can either click a listed synonym, to see its synonyms, or select
+one or more words and click the selection, to see matching synonyms.
+To quickly select a series of words: double-click mouse-1 to select
+the first word, then click mouse-3 to extend the selection to the last
+word.
+
+Selection is useful when you want to see synonyms of a similar term.
+For example, instead of clicking the listed synonym `bleeding heart', you
+might select `heart' and click that.
+
+The prefix argument acts the same as for command `synonyms'.
+
+If you click a history link with mouse-2, previously retrieved search
+results are revisited."
+ (interactive "e\nP")
+ (set-buffer (window-buffer (posn-window (event-end event))))
+ (let ((beg (region-beginning))
+ (end (region-end))
+ (active mark-active))
+ (goto-char (posn-point (event-end event)))
+ (cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
+ ((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
+ (t (if (and active (> (point) beg) (< (point) end))
+ (goto-char end)
+ (deactivate-mark)) ; User did not click inside region, so deactivate it.
+ (synonyms-no-read arg)))))
+
+;;;###autoload
+(defun synonyms-mouse-match-more (event arg)
+ "Same as `synonyms-mouse' with `synonyms-match-more-flag' = t."
+ (interactive "e\nP")
+ (let ((synonyms-match-more-flag t))
+ (synonyms-mouse event arg)))
+
+;;;###autoload
+(defun synonyms-mouse-append-result (event arg)
+ "Same as `synonyms-mouse' with `synonyms-append-result-flag' = t."
+ (interactive "e\nP")
+ (let ((synonyms-append-result-flag t))
+ (synonyms-mouse event arg)))
+
+;;;###autoload
+(defun synonyms-mouse-match-more+append-result (event arg)
+ "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
+ (interactive "e\nP")
+ (let ((synonyms-match-more-flag t)
+ (synonyms-append-result-flag t))
+ (synonyms-mouse event arg)))
+
+(defun synonyms-default-regexp ()
+ "Return the default regexp for `synonym' and `synonyms-mouse'.
+If the region is active in `transient-mark-mode', use its text.
+Else, if this is *Synonyms* buffer, use the synonym under the cursor.
+Else use the word nearest the cursor.
+
+An active region has no effect except in `transient-mark-mode'."
+ (if (and mark-active transient-mark-mode) ; Use region text, if active.
+ (buffer-substring-no-properties (point) (mark))
+ (if (eq major-mode 'synonyms-mode) ; Use mouse-face text, if in synonyms-mode.
+ (let (beg end)
+ (when (and (not (eobp)) (get-text-property (point) 'mouse-face))
+ (setq end (point)
+ beg (1+ (point))))
+ (when (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
+ (setq end (1- (point))
+ beg (point)))
+ (if (null beg)
+ (synonyms-nearest-word) ; Punt - no mouse-face, for some reason.
+ (setq beg (previous-single-property-change beg 'mouse-face)
+ end (or (next-single-property-change end 'mouse-face) (point-max)))
+ (replace-regexp-in-string ; Replace newlines with spaces, except at the
+ "\\(^ \\| $\\)" "" ; beginning and end.
+ (replace-regexp-in-string "[\n]" " " (buffer-substring-no-properties beg end) nil t)
+ nil t)))
+ (synonyms-nearest-word))))
+
+(defun synonyms-nearest-word ()
+ "Word nearest the cursor."
+ (let ((word (if (fboundp 'word-nearest-point)
+ (word-nearest-point) ; In `thingatpt+.el'.
+ (word-at-point)))) ; In `thingatpt.el'.
+ (set-text-properties 0 (length word) nil word) ; Remove all text properties.
+ word))
+
+(defun synonyms-lookup (search-text appendp morep)
+ "Search the thesaurus for SEARCH-TEXT.
+APPEND-P non-nil means to append search result to previous results.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ (save-selected-window
+ (with-temp-message
+ (format "Looking up %s synonyms for \"%s\"%s..." (if morep "(max)" "")
+ (replace-regexp-in-string (regexp-quote "[^,]") "." search-text nil t)
+ (if appendp " (appending)" ""))
+ (let ((temp-buf (generate-new-buffer " *Temp*")))
+ (unwind-protect
+ (progn
+ (set-buffer temp-buf)
+ (buffer-disable-undo) ; Make sure (should already be, because of *Temp* name).
+ (erase-buffer)
+ (let ((entry-p (synonyms-search-entries search-text temp-buf morep)))
+ ;; For `morep' search, we don't stop even if we find an entry.
+ (unless (if morep
+ (or (synonyms-search-synonyms search-text temp-buf t) entry-p)
+ (or entry-p (synonyms-search-synonyms search-text temp-buf nil)))
+ (pop synonyms-history) ; Remove it from search history, so we don't try again.
+ (error "No synonyms found for `%s'" search-text))
+ (let ((results-buf (get-buffer-create "*Synonyms*")))
+ (synonyms-format-synonyms search-text morep)
+ (synonyms-show-synonyms temp-buf results-buf appendp)
+ (message nil))))
+ (kill-buffer temp-buf))))))
+
+(defun synonyms-search-entries (search-text buf morep)
+ "Search thesaurus entries (headings) for SEARCH-TEXT.
+Put result in buffer BUF.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ (call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
+ (if morep
+ (format "^\\w*%s\\w*," search-text)
+ (format "^%s," search-text)))
+ (expand-file-name synonyms-file))
+ (not (zerop (count-lines (point-min) (point-max)))))
+
+(defun synonyms-search-synonyms (search-text buf morep)
+ "Search thesaurus body for SEARCH-TEXT.
+SEARCH-TEXT is a regexp that can match any part of a thesaurus term.
+Put result in buffer BUF.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ (call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
+ (if morep
+ (format ",\\w*%s\\w*\\(,\\|$\\)" search-text)
+ (format ",%s\\(,\\|$\\)" search-text)))
+ (expand-file-name synonyms-file))
+ (not (zerop (count-lines (point-min) (point-max)))))
+
+(defun synonyms-hack-backslashes-if-cygwin (string)
+ "Double each backslash in STRING, unless it contains SPC characters.
+More precisely, if `synonyms-use-cygwin-flag' is non-nil and this is
+Emacs 20 or there are no spaces in STRING, then double any backslashes
+in STRING.
+
+This is an ugly hack made necessary because of bugs in Emacs C code."
+ (when (and synonyms-use-cygwin-flag
+ (or (= emacs-major-version 20) (not (string-match " " string))))
+ (setq string (replace-regexp-in-string "[\\]" "\\\\" string nil t)))
+ string)
+
+(defun synonyms-format-synonyms (search-text morep)
+ "Format synonyms that match SEARCH-TEXT.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ (goto-char (point-min))
+ (let ((entries-count (count-lines (point-min) (point-max))))
+ (if (= entries-count 1)
+ (synonyms-format-entry search-text t morep)
+ (synonyms-format-entries search-text entries-count morep))
+ (synonyms-format-finish search-text morep)))
+
+(defun synonyms-format-entry (search-text single-p morep)
+ "Format a single thesaurus entry that matches SEARCH-TEXT.
+SINGLE-P non-nil means there is only one entry."
+ (beginning-of-line)
+ (let ((beg (point))
+ (orig (if morep ; Use saved search text.
+ (format "\\w*\\(%s\\)\\w*" synonyms-search-text)
+ (format "\\(%s\\)" synonyms-search-text)))
+ (entry-p nil)
+ term end)
+ (when single-p (insert "Synonyms for "))
+ (setq term (point))
+ (when (looking-at orig) (setq entry-p t))
+ (unless (search-forward "," nil t) (error "Bad thesaurus file - no commas"))
+ (setq end (match-beginning 0))
+ (replace-match ":\n\n" nil t)
+ (cond (single-p
+ (add-text-properties beg term '(face synonyms-heading))
+ (add-text-properties term end (if entry-p
+ '(face synonyms-search-text
+ mouse-face synonyms-mouse-face)
+ '(face synonyms-heading)))
+ (add-text-properties end (+ 2 end) '(face synonyms-heading)))
+ (t
+ (add-text-properties beg (1+ end) '(face synonyms-heading))
+ (save-excursion
+ (forward-line -2)
+ (save-restriction
+ (narrow-to-region (point) (save-excursion (end-of-line) (backward-char) (point)))
+ (unless (search-forward ". " nil t)
+ (error "Badly formatted numeric entry - no period"))
+ (add-text-properties (point) (point-max) '(mouse-face synonyms-mouse-face))
+ (when (looking-at orig)
+ (add-text-properties (match-beginning 1) (match-end 1)
+ '(face synonyms-search-text)))))))
+ (forward-line)))
+
+(defun synonyms-format-entries (search-text entries-count morep)
+ "Format thesaurus entries that have synonyms matching SEARCH TEXT.
+ENTRIES-COUNT is the number of entries.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ (let ((countdown entries-count)
+ (beg (point))
+ (part1 "Synonyms for ")
+ (part2 ":\n"))
+ (insert part1 synonyms-search-text part2)
+ (add-text-properties beg (setq beg (+ beg (length part1))) '(face synonyms-heading))
+ (add-text-properties beg (setq beg (+ beg (length synonyms-search-text)))
+ '(face synonyms-search-text mouse-face synonyms-mouse-face))
+ (add-text-properties beg (+ beg (length part2)) '(face synonyms-heading))
+ (while (> countdown 0)
+ (setq countdown (1- countdown))
+ (insert (format "\n\%s. " (- entries-count countdown)))
+ (synonyms-format-entry search-text nil morep))))
+
+(defun synonyms-format-finish (search-text morep)
+ "Finish formatting synonyms matching SEARCH-TEXT.
+MORE-P non-nil means additional thesaurus entries can be matched."
+ ;; Put a space after each comma.
+ (goto-char (point-min))
+ (forward-line) ; First line might have [^,] in it.
+ (while (search-forward "," nil t) (replace-match ", " nil t))
+ (goto-char (point-min))
+ (let ((case-fold-search t)
+ (new-search-text (if morep
+ (format "\\(^\\|, \\)\\w*\\(%s\\)\\w*\\($\\|,\\)" search-text)
+ (format "\\(^\\|, \\)\\(%s\\)\\($\\|,\\)" search-text)))
+ (no-numbered-headers-p (not (re-search-forward "^[0-9]+[.]" nil t))))
+ (goto-char (point-min))
+ (forward-line)
+ (while (re-search-forward new-search-text nil t)
+ (add-text-properties (match-beginning 2) (match-end 2) '(face synonyms-search-text))
+ (goto-char (match-end 2)))
+ ;; Do `synonyms-mode' here too, so hyphen will be a word char.
+ ;; IS THERE A WAY TO DO A LET to change the syntax of hyphen, instead of entering mode?
+ (synonyms-mode)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line)
+ (while (re-search-forward "\\(^\\|, \\)\\(\\(\\w\\|[\\t ]\\)+\\)\\($\\|,\\)" nil t)
+ (add-text-properties (match-beginning 2) (match-end 2) '(mouse-face synonyms-mouse-face))
+ (goto-char (match-end 2)))
+ (fill-region (point-min) (point-max)))
+ (synonyms-add-history-links)))
+
+(defun synonyms-add-history-links ()
+ "Add Back and Forward chronological navigation links"
+ (save-excursion
+ (unless (re-search-backward "Synonyms for") (error "No \"Synonyms for\" text"))
+ (end-of-line)
+ (insert (make-string (- fill-column 16 (point)) ?\ ) "[")
+ (let ((beg (point))
+ (Back "Back")
+ (spacer "] [")
+ (Forward "Forward"))
+ (insert Back)
+ (add-text-properties beg (point)
+ '(face synonyms-link mouse-face synonyms-mouse-face back-link t
+ help-echo "mouse-2, RET: Go backward in synonyms search history"))
+ (insert spacer Forward)
+ (add-text-properties (+ beg (length Back) (length spacer)) (point)
+ '(face synonyms-link mouse-face synonyms-mouse-face forward-link t
+ help-echo "mouse-2, RET: Go forward in synonyms search history"))
+ (insert "]"))))
+
+(defun synonyms-show-synonyms (temp-buf results-buf appendp)
+ "Display search results from buffer TEMP-BUF in buffer RESULTS-BUF.
+If APPEND-P is non-nil and RESULTS-BUF is not empty, then insert a
+separator line between previous search results and the current results."
+ (set-buffer results-buf)
+ (setq buffer-read-only nil)
+ (unless (= (point-min) (point-max))
+ (if (not appendp)
+ (erase-buffer)
+ (goto-char (point-max))
+ (let ((beg (point)))
+ (insert "\n" (make-string (1- (window-width)) ?_) "\n\n\n")
+ (add-text-properties beg (point) '(face synonyms-heading)))))
+ (let ((start-result (point)))
+ (insert-buffer temp-buf)
+ (select-window (display-buffer results-buf))
+ (goto-char start-result)
+ (forward-line 2) ; Put cursor on first synonym.
+ (when (looking-at "^[0-9]. ") (goto-char (match-end 0)))
+ (recenter 2)
+ (synonyms-mode)
+ (setq buffer-read-only t)))
+
+;;;###autoload
+(defun synonyms-history-backward (arg)
+ "Run `synonyms' on a previous argument, moving backward in the history.
+A prefix argument has the same meaning as for command `synonyms'."
+ (interactive "P")
+ (unless (cdr synonyms-history) (error "Cannot move backward in history"))
+ (push (pop synonyms-history) synonyms-history-forward) ; Put current on forward list.
+ (let* ((num-arg (prefix-numeric-value arg))
+ (morep (eq synonyms-match-more-flag (atom arg)))
+ (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
+
+ ;; Visit last. If *Synonyms* has appended search results, go to the previous one, from (point).
+ (if (not (get-buffer "*Synonyms*"))
+ (synonyms-action (car synonyms-history))
+ (let ((divider (with-current-buffer "*Synonyms*" (re-search-backward "^___" nil t))))
+ (if (not divider)
+ (synonyms-action (car synonyms-history))
+ (set-buffer "*Synonyms*")
+ (goto-char divider)
+ (unless (re-search-backward "^Synonyms for \\([^:]+\\):" nil t)
+ (error "Cannot find previous synonyms page"))
+ (goto-char (match-beginning 1))
+ (recenter 0)
+ (message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
+
+;;;###autoload
+(defun synonyms-history-forward (arg)
+ "Run `synonyms' on a previous argument, moving forward in the history.
+A prefix argument has the same meaning as for command `synonyms'."
+ (interactive "P")
+ (unless synonyms-history-forward (error "Cannot move forward in history"))
+ (push (pop synonyms-history-forward) synonyms-history) ; Put current on backward list.
+ (let* ((num-arg (prefix-numeric-value arg))
+ (morep (eq synonyms-match-more-flag (atom arg)))
+ (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
+
+ ;; Visit current. If *Synonyms* has appended search results, go to the next one, from (point).
+ (if (not (get-buffer "*Synonyms*"))
+ (synonyms-action (car synonyms-history))
+ (let ((divider (with-current-buffer "*Synonyms*" (re-search-forward "^___" nil t))))
+ (if (not divider)
+ (synonyms-action (car synonyms-history))
+ (set-buffer "*Synonyms*")
+ (goto-char divider)
+ (unless (re-search-forward "^Synonyms for \\([^:]+\\):" nil t)
+ (error "Cannot find next synonyms page"))
+ (goto-char (match-beginning 1))
+ (recenter 0)
+ (message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
+
+;;;###autoload
+(defalias 'dictionary-definition 'synonyms-definition)
+;;;###autoload
+(defun synonyms-definition (search-text alternate-p)
+ "Look up the definition of a word or phrase using online dictionaries.
+The dictionary used is `synonyms-dictionary-url'.
+With prefix arg, look up the definition in the alternate dictionary,
+`synonyms-dictionary-alternate-url'."
+ (interactive (list (completing-read "Look up definition of word or phrase (regexp): "
+ synonyms-obarray nil nil nil 'synonyms-history
+ (synonyms-default-regexp))
+ current-prefix-arg))
+ (synonyms-ensure-synonyms-read-from-cache) ; Fill `synonyms-obarray', for use in completion.
+ (browse-url (concat (if alternate-p synonyms-dictionary-alternate-url synonyms-dictionary-url)
+ search-text)))
+
+;;;###autoload
+(defun synonyms-definition-no-read (alternate-p)
+ "Look up the definition of a word or phrase using online dictionaries.
+The dictionary used is `synonyms-dictionary-url'.
+With prefix arg, look up the definition in the alternate dictionary,
+`synonyms-dictionary-alternate-url'."
+ (interactive "P")
+ (synonyms-definition (synonyms-default-regexp) alternate-p))
+
+;;;###autoload
+(defun synonyms-definition-mouse (event alternate-p)
+ "Look up the definition of a word or phrase using online dictionaries.
+The dictionary used is `synonyms-dictionary-url'.
+With prefix arg, look up the definition in the alternate dictionary,
+`synonyms-dictionary-alternate-url'."
+ (interactive "e\nP")
+ (set-buffer (window-buffer (posn-window (event-end event))))
+ (let ((beg (region-beginning))
+ (end (region-end))
+ (active mark-active))
+ (goto-char (posn-point (event-end event)))
+ (cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
+ ((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
+ (t (if (and active (> (point) beg) (< (point) end))
+ (goto-char end)
+ (deactivate-mark)) ; User did not click inside region, so deactivate it.
+ (synonyms-definition (synonyms-default-regexp) alternate-p)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'synonyms)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; synonyms.el ends here
--- /dev/null
+;;; template.el --- use templates, decorate comments, auto-update buffers
+
+;; Copyright (C) 1995-2003 Free Software Foundation, Inc.
+;;
+;; Author: Christoph Wedler <wedlerNOSPAMusers.sourceforge.net>
+;; Version: (see `template-version' below)
+;; Keywords: template, comment decoration, auto-updating, data, tools
+;; X-URL: http://emacs-template.sourceforge.net/
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; When you create a new file with Emacs, package Template supplies an initial
+;; buffer content via a template: a file with normal text and expansion
+;; forms. There is a menu to easily create such templates. You can also use new
+;; commands to decorate comments and update the buffer contents.
+
+;; The main difference between Template and other similar packages is that you
+;; can define very flexible templates without having to learn Lisp or changing
+;; your Emacs init file. This package does not help Lisp programmers to define
+;; complex macros.
+
+;; For details, check <http://emacs-template.sourceforge.net/> or, if you
+;; prefer the manual style, the documentation of the following commands and
+;; variables:
+;;
+;; * for templates: \\[template-new-file], `template-auto-insert',
+;; `template-derivation-alist', `template-default-expansion-alist' and
+;; `template-definition-start',
+;; * for comment decoration: \\[template-single-comment] and
+;; \\[template-block-comment], `template-comment-specification-alist'
+;; * for updating: \\[template-update-buffer], `template-auto-update',
+;; `template-update-buffer-alist' and `template-header-regexp-alist'.
+
+;; Bug fixes, bug reports, improvements, and suggestions for the newest version
+;; are strongly appreciated.
+
+;;; Installation:
+
+;; This file requires Emacs-20.2, XEmacs-20.2 or higher.
+
+;; Put this file into your load-path and the following into your ~/.emacs:
+;; (require 'template)
+;; (template-initialize)
+
+;; You might want to add another item to the "File" menu by (in XEmacs):
+;; (add-menu-button '("File")
+;; ["Insert and Expand Template..."
+;; template-expand-template
+;; :active (not buffer-read-only)]
+;; "Insert File...")
+
+;; To customize, use `M-x customize-group RET template RET' or the customize
+;; entry in menu Options.
+
+;;; Code:
+
+(provide 'template)
+(require 'custom)
+
+;; General Emacs/XEmacs-compatibility compile-time macros
+(eval-when-compile
+ (require 'cl)
+ (defmacro cond-emacs-xemacs (&rest args)
+ (cond-emacs-xemacs-macfn
+ args "`cond-emacs-xemacs' must return exactly one element"))
+ (defun cond-emacs-xemacs-macfn (args &optional msg)
+ (if (atom args) args
+ (and (eq (car args) :@) (null msg) ; (:@ ...spliced...)
+ (setq args (cdr args)
+ msg "(:@ ....) must return exactly one element"))
+ (let ((ignore (if (string-match "XEmacs" emacs-version) :EMACS :XEMACS))
+ (mode :BOTH) code)
+ (while (consp args)
+ (if (memq (car args) '(:EMACS :XEMACS :BOTH)) (setq mode (pop args)))
+ (if (atom args)
+ (or args (error "Used selector %s without elements" mode))
+ (or (eq ignore mode)
+ (push (cond-emacs-xemacs-macfn (car args)) code))
+ (pop args)))
+ (cond (msg (if (or args (cdr code)) (error msg) (car code)))
+ ((or (null args) (eq ignore mode)) (nreverse code))
+ (t (nconc (nreverse code) args))))))
+ ;; Emacs/XEmacs-compatibility `defun': remove interactive "_" for Emacs, use
+ ;; existing functions when they are `fboundp', provide shortcuts if they are
+ ;; known to be defined in a specific Emacs branch (for short .elc)
+ (defmacro defunx (name arglist &rest definition)
+ (let ((xemacsp (string-match "XEmacs" emacs-version)) reuses first)
+ (while (memq (setq first (car definition))
+ '(:try :emacs-and-try :xemacs-and-try
+ :emacs-only :xemacs-only))
+ (if (memq first (if xemacsp
+ '(:xemacs-and-try :xemacs-only)
+ '(:emacs-and-try :emacs-only)))
+ (setq reuses (cadr definition)
+ definition nil)
+ (unless (memq first '(:emacs-only :xemacs-only))
+ (push (cadr definition) reuses)))
+ (setq definition (cddr definition)))
+ (if (and reuses (symbolp reuses))
+ `(defalias ',name ',reuses)
+ (let* ((docstring (if (stringp (car definition)) (pop definition)))
+ (spec (and (not xemacsp)
+ (eq (car-safe (car definition)) 'interactive)
+ (null (cddar definition))
+ (cadar definition))))
+ (if (and (stringp spec)
+ (not (string-equal spec ""))
+ (eq (aref spec 0) ?_))
+ (setq definition
+ (cons (if (string-equal spec "_")
+ '(interactive)
+ `(interactive ,(substring spec 1)))
+ (cdr definition))))
+ (if (null reuses)
+ `(defun ,name ,arglist ,docstring
+ ,@(cond-emacs-xemacs-macfn definition))
+ ;; no dynamic docstring in this case
+ `(eval-and-compile ; no warnings in Emacs
+ (defalias ',name
+ (cond ,@(mapcar (lambda (func) `((fboundp ',func) ',func))
+ (nreverse reuses))
+ (t ,(if definition
+ `(lambda ,arglist ,docstring
+ ,@(cond-emacs-xemacs-macfn definition))
+ 'ignore)))))))))))
+
+(eval-when-compile
+ (require 'cl)
+ (defvar init-file-loaded) ; would be useful in Emacs, too...
+ (defvar file-name-buffer-file-type-alist))
+
+
+\f
+;;;;##########################################################################
+;;;; User Options, Variables
+;;;;##########################################################################
+
+
+(defconst template-version "3.1c"
+ "Current version of package template.
+Check <http://emacs-template.sourceforge.net/> for the newest.")
+
+
+;;;===========================================================================
+;;; Customization and initialization
+;;;===========================================================================
+
+(defgroup template nil
+ "Use templates, decorate comments, auto-update buffers."
+ :group 'data
+ :link '(emacs-commentary-link "template.el")
+ :link '(url-link "http://emacs-template.sourceforge.net/")
+ :prefix "template-")
+
+(defgroup template-comments nil
+ "Comment decorations in package template."
+ :group 'template
+ :prefix "template-")
+
+(defgroup template-updating nil
+ "Updating with package template."
+ :group 'template
+ :prefix "template-")
+
+(defgroup template-derivation nil
+ "Deriving templates for new files."
+ :group 'template
+ :prefix "template-")
+
+(defgroup template-expansion nil
+ "Expanding the expansion forms in templates."
+ :group 'template
+ :prefix "template-")
+
+(defgroup template-miscellaneous nil
+ "Miscellaneous configurations of package template."
+ :group 'template
+ :prefix "template-")
+
+;; I could imagine that a future version of package custom could make this
+;; `PACKAGE-initialize' stuff easier
+(defcustom template-use-package nil
+ "Pseudo variable. Used to initialize template in custom buffer.
+Put `(template-initialize)' into your ~/.emacs to initialize package
+template in future sessions. See variable `template-initialize'."
+ :group 'template
+ :type '(boolean :format "%{%t%}: %[(template-initialize)%], %v\n"
+ :on "in use" :off "not yet initialized"
+ :help-echo "Initialize package Template."
+ :action template-initialize))
+
+(defcustom template-initialize t
+ "Whether/what to initialize with `template-initialize'.
+If t, do full initialization. Otherwise, the value should be a list
+with elements. To enable, include
+
+ * `auto' to enable `template-auto-update' and `template-auto-insert',
+ * `ffap' to make sure that `auto' works with `find-file-at-point',
+ * `cc-mode' to enable correct C/C++/Java/Antlr comment filling, i.e.,
+ to add `template-c-init-fill-function' to `c-mode-common-hook',
+ * `de-html-helper' to disable `html-helper's template and time-stamps,
+ * `keys' to setup the default key bindings,
+ * `menus' to setup the menus."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "All" t)
+ (set :value (auto cc-mode keys menus)
+ (const :tag "Auto Updating/Inserting" auto)
+ (const :tag "Correct Auto Inserting with Ffap" ffap)
+ (const :tag "Correct C Comment Filling" cc-mode)
+ (const :tag "Deactivate html-helper" de-html-helper)
+ (const :tag "Setup Key Bindings" keys)
+ (const :tag "Setup Menus" menus))))
+
+
+;;;===========================================================================
+;;; Menu
+;;;===========================================================================
+
+(defvar template-comment-menu
+ '("Comment"
+ ["Decorate Comment Line" template-single-comment
+ :active (and (not buffer-read-only)
+ (memq (template-comment-at-point)
+ '(none delimited single cont)))]
+ ["Decorate Comment Block" template-block-comment
+ :active (and (not buffer-read-only)
+ (memq (template-comment-at-point)
+ '(single block)))]
+ "---"
+ ["Indent for Comment" indent-for-comment
+ :active (and comment-start (not buffer-read-only))]
+ ["Continue Comment" indent-new-comment-line
+ :active (and comment-start (not buffer-read-only))]
+ ["Comment Region" comment-region
+ :active (and comment-start (not buffer-read-only) (mark))]
+ ["Comment Region 2" (comment-region 2)
+ :active (and comment-start (not buffer-read-only) (mark))]
+ ["Comment Region 3" (comment-region 3)
+ :active (and comment-start (not buffer-read-only) (mark))]
+ "---"
+ ["Update Buffer" template-update-buffer
+ :active (and template-update-buffer-alist (not buffer-read-only))])
+ "Menu for comment functions.")
+
+(defvar template-creation-menu
+ '("Template Creation"
+ :filter template-menu-filter
+ ["Open Template" template-open-template
+ :active (null (template-buffer-template-p))]
+ "--"
+ ["Define User Input" template-define-prompt t]
+ ["Define Text Register" template-define-register t]
+ ["Define Message" template-define-message t]
+ "---"
+ ["Insert Expansion Form" template-insert-form t])
+ "Menu for template creation.")
+
+
+;;;===========================================================================
+;;; Commenting
+;;;===========================================================================
+
+(defcustom template-max-column -1
+ "*Width of the separator line, to use with an empty `comment-end'.
+If the value is zero or negative, it is added to `fill-column'. See
+also `template-max-column-with-end'."
+ :group 'template-comments
+ :type 'integer)
+
+(defcustom template-max-column-with-end 0
+ "*Width of the separator line including a non-empty `comment-end'.
+If the value is zero or negative, it is added to `fill-column'. See
+also `template-max-column'."
+ :group 'template-comments
+ :type 'integer)
+
+(defcustom template-alt-comment-syntax-alist
+ '((t "/* " " */"))
+ "Alternative comment syntax for languages with \"mixed\" comments.
+Used by function `template-comment-syntax'. Elements look like
+ (MODES-OR-REGEXP COMMENT-START COMMENT-END)
+
+If the current `major-mode' has a empty `comment-end' and a commenting
+command does not work at `point' with the usual `comment-start', we
+search for the first matching alternative comment syntax in this alist.
+
+Each element must \"pass\" MODES-OR-REGEXP. If this is a list, it must
+include the current major-mode, if this is a regexp, it must match the
+`buffer-file-name' without version, otherwise it must be non-nil.
+
+Then, COMMENT-START and COMMENT-END is used as the alternative comment
+syntax if `comment-start-skip' matches COMMENT-START."
+ :group 'template-comments
+ :type '(repeat (group (choice (repeat :tag "In major modes" :value nil
+ function)
+ (regexp :tag "Buffer matching" :value "")
+ (sexp :tag "Always" :value t))
+ (string :tag "Alt comment start" :value "/* ")
+ (string :tag "Alt comment end" :value " */"))))
+
+(defcustom template-comment-indent t
+ "Non-nil means, indent single-line/block comments.
+Commands \\[template-single-comment] and \\[template-block-comment]
+indent the comment lines if this value is non-nil and the current major
+mode is not a member of `template-indent-mode-disable-list' or if this
+value is nil and the current major mode is a member of
+`template-indent-mode-enable-list'."
+ :group 'template-comments
+ :type 'boolean)
+
+(defcustom template-indent-mode-disable-list '(sh-mode makefile-mode)
+ "Major modes not having indented single-line/block comments.
+Used if `template-comment-indent' is non-nil. Major modes in which
+pressing TAB twice is different from pressing TAB once are good
+candidates for this list."
+ :group 'template-comments
+ :type '(repeat (function :tag "Major mode")))
+
+(defcustom template-indent-mode-enable-list nil
+ "Major modes having indented single-line/block comments.
+Used if `template-comment-indent' is nil."
+ :group 'template-comments
+ :type '(repeat (function :tag "Major mode")))
+
+(defcustom template-comment-specification-alist
+ '(("-" "" "" 0)
+ ("-" "" "" 0)
+ ("=" "\n\n" "\n" 1)
+ ("#" "\n\n\f\n" "\n\n" 2))
+ "List of specifications for comment functions.
+Each specification at LEVEL, starting at 1, is a list
+ (SEPARATOR BEFORE-BLOCK AFTER-BLOCK DELETE-LINES)
+
+SEPARATOR is the string which is inserted repeatedly by commands
+\\[template-single-comment] and \\[template-block-comment] up to
+`template-max-column'.
+
+After that, \\[template-block-comment] deletes DELETE-LINES after the
+comment block and inserts string AFTER-BLOCK at the end of the block and
+BEFORE-BLOCK at the front of the block.
+
+The specification LEVEL to use is determined by:
+ (1) If the prefix argument is non-nil and its numeric value is > 0,
+ this value is the LEVEL.
+ (2) If the prefix argument is nil, and there is an old comment style,
+ use old comment style.
+ (3) If `template-comment-specification-special' is a function or the
+ current major mode has a property with this name and its value is a
+ function, this function returns the specification.
+ (4) If `comment-end' is empty and `comment-start' is a string of length
+ 1: LEVEL is number of repetitions of `comment-start' at the
+ beginning of the line. Otherwise, if the correctly indented line
+ starts at the beginning of the line, LEVEL=3, else LEVEL=2."
+ :group 'template-comments
+ :type '(repeat (group (string :tag "Separator" :value "-")
+ (string :tag "Before block" :value "")
+ (string :tag "After block" :value "")
+ (integer :tag "Delete lines" :value 0))))
+
+(defcustom template-comment-specification-special nil
+ "Function used for special commenting styles or nil.
+See `template-comment-specification-alist' for details."
+ :group 'template-comments
+ :type '(choice (const nil) function))
+
+
+;;;===========================================================================
+;;; Auto updating
+;;;===========================================================================
+
+(defcustom template-auto-update 'query
+ "*Whether to update parts of the file when saving the buffer.
+When non-nil and `template-auto-update-disable-regexp' does not match
+the file name, automatically updates parts of the buffer, see
+`template-update-buffer-alist'. With value t or if the entry in the
+alist has no prompt, do not ask for confirmation.
+
+You should have called `template-initialize' to enable this feature."
+ :group 'template-updating
+ :type '(radio (const :tag "No" nil)
+ (const :tag "Without confirmation" t)
+ (sexp :tag "With confirmation" :format "%t" :value query)))
+
+(defcustom template-auto-update-disable-regexp nil
+ "*Regexp matching files not to automatically update.
+Value nil matches no file. See `template-auto-update'."
+ :group 'template-updating
+ :type '(choice (const :tag "none" nil) regexp))
+
+(defcustom template-update-buffer-alist
+ '((t "Update header in %s? "
+ (template-update-header t)
+ (file-name-sans-versions (file-name-nondirectory buffer-file-name)))
+ ((html-mode) "Update date inside <address> in %s? "
+ (-2000
+ "\\([0-9]+[ \t]+[A-Za-z][A-Za-z][A-Za-z][ \t]+[0-9]+\\)[ \t\n]*</address>"
+ 1)
+ (format-time-string "%d %b %Y")))
+ "Alist used how to update parts of the buffer.
+Used by function `template-update-buffer'. Elements look like
+ (MODES-OR-REGEXP PROMPT TEST NEW REPLACEMENT-FUN)
+
+Each element must \"pass\" MODES-OR-REGEXP. If this is a list, it must
+include the current major-mode, if this is a regexp, it must match the
+`buffer-file-name' without version, otherwise it must be non-nil.
+
+Then, TEST is `eval'd and must return the region = (BEG . END) to be
+replaced or nil if nothing should be updated according to the current
+element. If TEST is a list and the `car' of TEST is not a function,
+`template-update-buffer-region' is used as the default function, i.e.,
+REPLACEMENT-FUN looks like (LIMIT REGEXP GROUP). Then, check first/last
+LIMIT characters in buffer and return region according to GROUP's regexp
+group in REGEXP.
+
+Then, NEW is `eval'd. If it is a string, it is considered as
+replacement for the region, otherwise REPLACE-FUN must be non-nil.
+
+Then, ask user for confirmation with PROMPT where %s is substituted by
+the buffer name if PROMPT is a string and `template-auto-update' is not
+t.
+
+Finally, REPLACEMENT-FUN is called the `eval'd NEW and the beginning and
+the end of the region returned by TEST. If REPLACEMENT-FUN is nil, just
+replace the region by the `eval'd NEW."
+ :group 'template-updating
+ :type '(repeat (group (choice (repeat :tag "In major modes" :value nil
+ function)
+ (regexp :tag "Buffer matching" :value "")
+ (sexp :tag "Always" :value t))
+ (string :tag "Prompt" :value "Update in %s? ")
+ (choice (list :tag "Default test"
+ (choice (const :tag "No limit" nil)
+ (integer :tag "Limit" -1000))
+ regexp
+ (integer :tag "Regexp group" :value 0))
+ (sexp :tag "Eval sexp"))
+ (sexp :tag "Eval New string")
+ (option (function :tag "Replacement function")))))
+
+(defcustom template-header-lines 3
+ "*Last line number which is checked by \\[template-update-header]."
+ :group 'template-updating
+ :type 'integer)
+
+(put 'template-header-lines 'template-secure-value #'integerp)
+
+(defcustom template-header-regexp-alist
+ '(("@(#)\\([^ \t\n]+\\)" . 1)
+ ("^%s[ \t]*\\([^ \t\n%s][^ \t\n]*\\)[ \t]+--" . 1))
+ "Alist of regexps matching the file name in the header.
+The `car' of each element is the REGEXP with %s, if present, substituted
+by the comment start. A second %s, if present, is substitud by a single
+letter non-alpha comment start, or the empty string otherwise.
+
+The `cdr' is the regexp group to be replaced. Used by
+\\[template-update-header].
+
+The comment start is evaluated from `comment-start', the first character
+in the buffer or \"#\". It is assumed that a non-alpha single character
+comment start may be repeated. For example, the substituted regexp in
+`emacs-lisp-mode' is \"\;+\", in `c++-mode' \"//\"."
+ :group 'template-updating
+ :type '(repeat (cons :format "%v"
+ regexp
+ (integer :tag "Regexp group" :value 0))))
+
+
+;;;===========================================================================
+;;; Templates: finding templates
+;;;===========================================================================
+
+(defcustom template-auto-insert 'query
+ "*Whether to automatically use template files for new files.
+Used if the user gave a non-existent file as argument to a command in
+`template-find-file-commands'. When non-nil and a matching template
+file can be found, use a template like in `template-new-file'. File
+name refinement is never performed, see `template-derivation-alist'.
+
+With value t, do not ask for confirmation.
+
+You should have called `template-initialize' to enable this feature."
+ :group 'template-derivation
+ :type '(radio (const :tag "No" nil)
+ (const :tag "Without confirmation" t)
+ (sexp :tag "With confirmation" :format "%t" :value query)))
+
+(defcustom template-find-file-commands
+ '(find-file find-file-other-frame find-file-other-screen
+ find-file-other-window find-file-at-point ffap nil)
+ "*Commands which use templates as last resort, see `template-auto-insert'.
+See also `template-file-select-commands'.
+
+Include nil if you want to use templates for non-existing files as
+command line arguments when starting Emacs."
+ :group 'template-derivation
+ :type '(repeat (function :tag "Command")))
+
+(defcustom template-file-select-commands
+ '(exit-minibuffer minibuffer-complete-and-exit
+ list-mode-item-mouse-selected
+ list-mode-item-keyboard-selected)
+ "*Commands which select the file name via minibuffer/completions.
+Checked with commands in `template-find-file-commands'."
+ :group 'template-derivation
+ :type '(repeat (function :tag "Command")))
+
+(defface template-message-face
+ '((((class color) (background light)) (:background "pink"))
+ (t (:bold t)))
+ "Face for temporary message at point. This only works with XEmacs."
+ :group 'template-miscellaneous)
+
+(defcustom template-extension ".tpl"
+ "*Extension used for template files."
+ :group 'template-derivation
+ :type 'string)
+
+(defcustom template-subdirectories '("./" "Templates/")
+ "*List of subdirectories for template files.
+See `template-derivation-alist' for details."
+ :group 'template-derivation
+ :type '(repeat directory))
+
+(defcustom template-stop-derivation
+ (cond ((fboundp 'file-remote-p) 'file-remote-p)
+ ((fboundp 'efs-ftp-path) 'efs-ftp-path)
+ ((fboundp 'ange-ftp-ftp-path) 'ange-ftp-ftp-path))
+ "If non-nil, function used to determine whether to stop derivation.
+If non-nil, function is called with argument DIR. If it returns t,
+`template-derivation' stops to search for more project specific
+templates, i\.e\., just searches in `template-default-directories'."
+ :group 'template-derivation
+ :type '(choice (const :tag "Never" nil)
+ function))
+
+(defcustom template-default-directories
+ (cons (if (and (not (file-directory-p "~/.templates/"))
+ (file-directory-p "~/lib/templates"))
+ (expand-file-name "~/lib/templates/")
+ (expand-file-name "~/.templates/"))
+ (and (fboundp 'locate-data-directory)
+ (let ((dir (locate-data-directory "template")))
+ (and dir (list dir)))))
+ "*List of default directories for template files.
+See `template-derivation-alist' for details."
+ :group 'template-derivation
+ :type '(repeat directory))
+
+(defcustom template-derivation-alist
+ '(;;(("00readme" "" ".txt" "\\`00") . ("00readme" "" ".txt"))
+ ((t "" t))
+ ((t nil null) . (nil nil t 1))
+ (("TEMPLATE" "" t)))
+ "Alist for template file name derivation and file name refinement.
+Template derivation searches for the most specific readable template
+file. By default, files with the same RAW part as the name of the new
+file are considered to be more specific than files with just the same
+EXT part. Also files in the same directory are considered to be more
+specific than files in their parent directory or any default template
+directory. This behavior can be changed by this alist.
+
+Each FORM in this alist has the form (TEMPLATE . REFINEMENT). If
+TEMPLATE matches, we have found a valid template file and the
+corresponding REFINEMENT is used for the file name refinement.
+
+Before the derivation, the given file name is split into the directory
+part DIR, the file name without directory FILE, and the raw part RAW of
+FILE, the numbering NUM and the extension EXT. The result is stored in
+`template-file'.
+
+TEMPLATE can have the form (FUNCTION ARG...). If TEMPLATE matches,
+FUNCTION, called with arguments ARGs, should return the split template
+file name, see `template-split-filename'.
+
+TEMPLATE can also have the form (T-RAW T-NUM T-EXT F-REGEXP) where all
+elements are optional, i.e., have value nil as default. For TEMPLATE to
+match, all conditions T-RAW, T-NUM and T-EXT must be met and F-REGEXP,
+if non-nil, should match FILE, the non-directory part of the given file
+name. If a condition is a string, the corresponding part of the
+template file must be equal to it. If t, the part must be equal to
+RAW/NUM/EXT of the given file name. If nil, any value will do it. Any
+other value acts like t when the part of the given file name is
+non-empty, as nil otherwise.
+
+REFINEMENT can have the form (FUNCTION ARG...). FUNCTION, called with
+the list of the split template filename and ARGs as arguments, should
+set `template-file' if the file name should be refined.
+
+REFINEMENT can also have the form (F-RAW F-NUM F-EXT AUTO-NUM) where all
+elements are optional, i.e., have value nil as default. If F-RAW, F-NUM
+and F-EXT are non-nil, they change RAW/NUM/EXT of `template-file'. A
+string will be used as the new part. If t, the corresponding part of
+the template name will be used.
+
+We will use auto numbering in the following two cases: if NUM is
+non-empty and the file exists already, or if NUM is empty and AUTO-NUM
+is non-nil. Auto numbering looks at the file names in DIR to generate
+the next unique number which is at least as high as NUM in the first
+case and AUTO-NUM in the second.
+
+Let us use parts of the default value as examples:
+
+Use a template with the same RAW part of the given file name and the
+same EXT part if provided, e.g., for \"exercise2\" use template
+\"exercise.tex.tpl\". Refine file name to use the extension of the
+template file, also use auto numbering, e.g., if files \"exercise2.tex\"
+and \"exercise3.tex\" exist, refine name to \"exercise4.tex\":
+ ((t nil null) \. (nil nil t 1))
+
+For a file with extension EXT, use TEMPLATE.EXT:
+ ((\"TEMPLATE\" \"\" t))
+
+We could define: If the given file name starts with \"00\", use template
+\"00readme.txt.tpl\". Refine file name to \"00readme.txt\":
+ ((\"00readme\" \"\" \".txt\" \"\\\\`00\") \. (\"00readme\" \"\" \".txt\"))
+
+Since more than one template file could meet this conditions, the
+template derivation searches for first readable file with extension
+`template-extension' which is found by the following algorithm:
+
+ forall FORMs in `template-derivation-alist' do
+ for directory BASE from DIR
+ while not stopped according to `template-stop-derivation' do
+ forall subdirectories DIRs in `template-subdirectories'
+ relative to BASE do
+ forall TEMPLATEs in DIR do
+ if check_form (FORM, FULL, TEMPLATE) return TEMPLATE
+ forall directories DIRs in `template-default-directories' do
+ forall TEMPLATEs in DIR do
+ if check_form (FORM, FULL, TEMPLATE) return TEMPLATE
+ if not used via `template-auto-insert'
+ forall TEMPLATEs in `template-default-directories'
+ where name_nondir (TEMPLATE) = \"DEFAULT.tpl\" do
+ if readable (TEMPLATE) return TEMPLATE
+ return TEMPLATE in first (`template-default-directories')
+ where name_nondir (TEMPLATE) = \"DEFAULT.tpl\""
+ :group 'template-derivation
+ :type '(repeat (cons :format "%v"
+ (sexp :tag "Derivation" :value ("TEMPLATE" nil t))
+ (sexp :tag "Refinement" :value nil))))
+
+
+;;;===========================================================================
+;;; Templates: expanding templates
+;;;===========================================================================
+
+(defcustom template-confirm-insecure t
+ "*Non-nil means, ask whether to use insecure template expansions.
+Only set this to nil if you ALWAYS check template files before using
+it!"
+ :group 'template-expansion
+ :type 'boolean)
+
+(put 'template-confirm-insecure 'risky-local-variable t)
+
+(defcustom template-message-buffer "*Template Message*"
+ "If non-nil, name of buffer where messages are shown.
+The following messages will be displayed in definition sequence before
+the expansion has taken place:
+ - :before messages, see `template-definition-start',
+ - user defined prompts if `template-message-prompt-format' is non-nil,
+ - user defined registers when there has been a :before message before,
+ see `template-message-register-format'.
+
+The following messages will be displayed in definition sequence after
+the expansion has taken place:
+ - :after messages, see `template-definition-start',
+ - user defined registers, display them at point if the value of this
+ variable is nil, see `template-message-register-format'."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Buffer Name")))
+
+(defcustom template-message-prompt-intro
+ "Template expansion will ask for input with the following prompts:"
+ "Default intro message used before listing user defined prompts.
+Used with :before messages, see `template-message-prompt-format'."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Intro text")))
+
+(defcustom template-message-prompt-format " %s"
+ "If non-nil, format string for user defined prompts.
+If non-nil and `template-message-buffer' is non-nil, user defined
+prompts will be listed before starting the expansions. Prompts can be
+defined as specified in the docstring of `template-definition-start'.
+For each PROMPT, this format string will be used with substitution
+PROMPT/%s.
+
+If no :before message has been defined before, use, if non-nil,
+`template-message-prompt-intro' as the first :before message."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "No prompt" nil)
+ (string :tag "Format string")))
+
+(defcustom template-message-register-intro
+ "Template has defined the following registers:"
+ "Default intro message used before listing user defined prompts.
+Used with :after messages, see `template-message-register-format'."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Intro text")))
+
+(defcustom template-message-register-format " %c:\t\"%s\"\t%s"
+ "If non-nil, format string for user defined registers.
+If non-nil, user defined text registers will be listed. Registers can
+be defined as specified in the docstring of `template-definition-start'.
+For each register CHAR with contents CONTENTS and optional comment
+COMMENT, this format string will be used with substitution CHAR/%c,
+CONTENT/%s and \(COMMENT/%s or \"\"/%s).
+
+The list of register definitions will be displayed:
+ - at point if `template-message-buffer' is nil,
+ - with :before messages if there has been at least one :before message
+ defined before and if `template-message-buffer' is non-nil,
+ - with :after messages if `template-message-buffer' is non-nil.
+ If no :after message has been defined before, use, if non-nil,
+ `template-message-register-intro' as the first :after message."
+ :group 'template-miscellaneous
+ :type '(choice (const :tag "No register content" nil)
+ (string :tag "Format string")))
+
+(defcustom template-message-timeout 600
+ "*Maximum duration the temporary message will be displayed at point.
+Any user event will also make the temporary message disappear. The
+temporary message uses face in `template-message-face'."
+ :group 'template-miscellaneous
+ :type 'integer)
+
+(put 'template-message-timeout 'template-secure-value #'integerp)
+
+(defcustom template-date-format "%d %b %Y"
+ "*Date/time format used with the expansion form (>>>DATE<<<).
+See `template-default-expansion-alist' and `format-time-string'. See
+also `template-time-format'."
+ :group 'template-expansion
+ :type 'string)
+
+(put 'template-date-format 'template-secure-value #'stringp)
+
+(defcustom template-time-format "%T"
+ "*Date/time format used with the expansion form (>>>TIME<<<).
+See `template-default-expansion-alist' and `format-time-string'. See
+also `template-date-format'."
+ :group 'template-expansion
+ :type 'string)
+
+(put 'template-time-format 'template-secure-value #'stringp)
+
+(defcustom template-string-default "%0.0S"
+ "*Format string used for non-string variable extensions.
+If SYMBOL in (\"KEY\" \. SYMBOL) is not a string, use string with
+substitution SYMBOL/%S. Default value \"%0.0S\" causes to print
+nothing. See `template-definition-start'."
+ :group 'template-expansion
+ :type 'string)
+
+(put 'template-string-default 'template-secure-value #'stringp)
+
+(defcustom template-expansion-format "(>>>%s<<<)"
+ "Format string for expansion forms.
+Is a expansion form with substitution KEY/%s. The value should
+correspond with `template-expansion-regexp'. Used by
+`template-insert-form'."
+ :group 'template-expansion
+ :type 'string)
+
+(put 'template-expansion-format 'template-secure-value #'stringp)
+
+(defcustom template-expansion-regexp "(>>>\\([-A-Za-z0-9_]+\\)<<<)"
+ "Regexp matching strings which are replaced by their expansions.
+The first regexp group contains the KEY used by the per-template
+expansion, see `template-definition-start' and the global expansions in
+`template-expansion-alist' and `template-default-expansion-alist'. The
+value should correspond with `template-expansion-alist'.
+
+If there is no defined expansion for the key, ask the user for a
+replacement, see `template-read'. If the key is matched by
+`template-register-regexp', store buffer position in register, see
+`template-register', .
+
+If you want to use a text literally which is matched by this regexp, use
+the zero expansion form (>>>ZERO_FORM<<<)."
+ :group 'template-expansion
+ :type 'regexp)
+
+(put 'template-expansion-regexp 'template-secure-value #'stringp)
+
+(defcustom template-literal-environment '("LITERAL" . "/LITERAL")
+ "Environment for literal text in template.
+Looks like (OPEN . CLOSE). Text between expansion forms with keys OPEN
+and CLOSE is not expanded. If you change OPEN, you should change key
+\"LITERAL\" in `template-default-expansion-alist' accordingly."
+ :group 'template-expansion
+ :type '(cons (string :tag "Open tag") (string :tag "Close tag")))
+
+(defcustom template-register-regexp "\\`[0-9]\\'"
+ "*Regexp matching keys for storing point positions in registers.
+These keys use `template-register' as the default expansion instead of
+`template-read'. See `template-expansion-regexp'. If a register is used
+twice, it is marked by a \"*\" in the echo area after the expansion."
+ :group 'template-expansion
+ :type 'regexp)
+
+(put 'template-register-regexp 'template-secure-value #'stringp)
+
+(defcustom template-expansion-alist nil
+ "User defined expansions forms.
+Predefined expansion forms for `template-expansion-regexp'. Each entry
+has the form (KEY . SEXP). These expansion forms shadow those in
+`template-default-expansion-alist' and are shadowed by those in the
+per-template definition section. See `template-definition-start'."
+ :group 'template-expansion
+ :type '(repeat (cons :format "%v"
+ (string :tag "Key" :value "")
+ (repeat :tag "Evaluate all" sexp))))
+
+(put 'template-expansion-alist 'risky-local-variable t)
+
+(defvar template-default-expansion-alist
+ '(("POINT" (setq template-point (point-marker))) ; point
+ ("MARK" (setq template-mark (point-marker))) ; mark
+ ("DIR" (insert (car template-file))) ; directory
+ ("FILE" (insert (cadr template-file))) ; file name without directory
+ ("FILE_SANS" (insert (nth 2 template-file)
+ (nth 3 template-file)))
+ ("FILE_RAW" (insert (nth 2 template-file))) ; raw file name without number
+ ("FILE_NUM" (insert (nth 3 template-file))) ; number
+ ("FILE_UPCASE" (insert (upcase (nth 2 template-file))
+ (nth 3 template-file)))
+ ("FILE_EXT" (or (string= (nth 4 template-file) "") ; extension
+ (insert (substring (nth 4 template-file) 1))))
+ ("DATE" (template-insert-time template-date-format))
+ ("TIME" (template-insert-time template-time-format))
+ ("VC_DATE" (set-time-zone-rule "UTC")
+ (template-insert-time "%Y/%m/%d %T" "0000/00/00 00:00:00")
+ ;; using saved `current-time-zone' doesn't work, but nil does
+ (set-time-zone-rule nil))
+ ("YEAR" (template-insert-time "%Y" "0000"))
+ ("ISO_DATE" (template-insert-time "%Y-%m-%d" "0000-00-00"))
+ ("COMMENT" (template-read "Initial comment: ")) ; comment
+ ("AUTHOR" (insert (or user-mail-address ; author
+ (and (fboundp 'user-mail-address)
+ (user-mail-address))
+ (concat (user-login-name) "@" (system-name)))))
+ ("USER_NAME" (insert (or (and (boundp 'user-full-name) ; user name
+ user-full-name)
+ (user-full-name))))
+ ("LOGIN_NAME" (insert (user-login-name))) ; login name
+ ("HOST_ADDR" (insert (or (and (boundp 'mail-host-address) ; host address
+ (stringp mail-host-address)
+ mail-host-address)
+ (system-name))))
+ ("LITERAL" (if (search-forward (format template-expansion-format
+ (cdr template-literal-environment))
+ nil 'limit)
+ (delete-region (match-beginning 0) (match-end 0))))
+ ("ZERO_FORM")) ; zero form
+ "Predefined default expansions forms.
+Predefined expansion forms for `template-expansion-regexp'. Each entry
+has the form (KEY . SEXP). These expansion forms are shadowed by those
+in `template-expansion-alist' and by those in the per-template
+definition section. See `template-definition-start'.
+
+The default predefined expansion forms are --default is inserting--:
+ (>>>POINT<<<) set point
+ (>>>MARK<<<) set mark, jump to it with \\[exchange-point-and-mark]
+ (>>>DIR<<<) directory: /home/clstaff/wedler/lib/
+ (>>>FILE<<<) file w/o directory: text1.txt
+ (>>>FILE_SANS<<<) file name w/o extension: text1
+ (>>>FILE_RAW<<<) raw file name: text
+ (>>>FILE_NUM<<<) number in name: 1
+ (>>>FILE_EXT<<<) extension: txt
+ (>>>FILE_UPCASE<<<) upcase file name w/o extension: TEXT1
+ (>>>DATE<<<) date using `template-date-format': 11 Jan 1999
+ (>>>TIME<<<) time using `template-time-format': 11:58:49
+ (>>>YEAR<<<) the year: 1999
+ (>>>ISO_DATE<<<) ISO 8601 date: 1999-01-11
+ (>>>VC_DATE<<<) UTC date/time for vc: 1999/01/11 10:58:49
+ (>>>COMMENT<<<) ask user for initial comment
+ (>>>AUTHOR<<<) author, i.e., `user-mail-address'
+ (>>>USER_NAME<<<) user name: Christoph Wedler
+ (>>>LOGIN_NAME<<<) login name: wedler
+ (>>>HOST_ADDR<<<) Host address: fmi.uni-passau.de
+ (>>>LITERAL<<<) literal text up to (>>>/LITERAL<<<)
+ (>>>ZERO_FORM<<<) zero form, i.e., insert nothing. Useful to insert
+ a text part matched by `template-expansion-regexp' literally.
+
+There are aliases with one-letter keys, see `template-key-alias-alist'.
+
+It is useful to follow the following conventions: upper case keys for
+predefined extensions, lower case and digits for per-template and the
+following default expansions:
+ (>>>0<<<) to (>>>9<<<) set registers 0 to 9, jump to it with
+ \\[jump-to-register] 0 etc., see `template-register-regexp'
+ (>>>x<<<) where x is any unused letter sequence: ask user.")
+
+(put 'template-default-expansion-alist 'risky-local-variable t)
+
+(defvar template-key-alias-alist
+ '(("P" . "POINT")
+ ("M" . "MARK")
+ ("D" . "DIR")
+ ("F" . "FILE")
+ ("R" . "FILE_RAW")
+ ("N" . "FILE_NUM")
+ ("B" . "FILE_UPCASE")
+ ("E" . "FILE_EXT")
+ ("T" . "DATE")
+ ("V" . "VC_DATE")
+ ("Y" . "YEAR")
+ ("I" . "ISO_DATE")
+ ("C" . "COMMENT")
+ ("A" . "AUTHOR")
+ ("U" . "USER_NAME")
+ ("L" . "LOGIN_NAME")
+ ("H" . "HOST_ADDR")
+ ("Z" . "ZERO_FORM"))
+ "Alist to support the old one-letter predefined expansion forms.
+Used for `template-expansion-alist' and
+`template-default-expansion-alist'.")
+
+(defcustom template-definition-start
+ ">>>TEMPLATE-DEFINITION-SECTION<<<"
+ "Header for the per-template definition section.
+The region following the the first match of this regexp defines the
+per-template definition section. The region will be deleted before the
+actual expansion, see `template-new-file'. If you use the \"Local
+Variables:\" section, define it before this region.
+
+The definition section defines expansion forms for strings KEYs matched
+by `template-expansion-regexp' which might shadow those in
+`template-expansion-alist' and `template-default-expansion-alist':
+
+ (\"KEY\"): zero form, same as (>>>ZERO_FORM<<<) in default value of
+`template-default-expansion-alist', useful for inserting text matched by
+`template-expansion-regexp' literally.
+
+ (\"KEY\". CHAR): CHAR is the register where the current buffer
+position is stored, see `template-register-regexp'.
+
+ (\"KEY\" \"PROMPT\" \"PREFIX\" \"SUFFIX\" \"DEFAULT\" AGAIN-P) where
+the last four arguments are optional: ask user with PROMPT for a STRING.
+If STRING is not \"\", insert PREFIX STRING SUFFIX, otherwise DEFAULT.
+For AGAIN-P, see `template-read'. To define, use
+\\[template-define-prompt].
+
+ (\"KEY\" \"PROMPT\" (\"ANSWER\" \. \"TEXT\")...): ask user with PROMPT
+for an input with completion over all ANSWERs and insert corresponding
+TEXT. Expansion forms in TEXT will be expanded.
+
+ (\"KEY\" \"PROMPT\" (t \. \"TEXT-y\") (nil \. \"TEXT-n\")): ask user
+with PROMPT a \"y or n\" question with `y-or-n-p' and insert TEXT-y or
+TEXT-n, correspondingly. Expansion forms in TEXT-X will be expanded.
+The y-case and the n-case are optional and can be exchanged.
+
+ (\"KEY\" \. SYMBOL): insert value of SYMBOL; if value is no string at
+the time of the replacement, use `template-string-default' as format
+string for SYMBOL.
+
+ (\"KEY\" COMMAND \. PREFIX): COMMAND is a symbol or a vector and is
+called with `command-execute' after setting `prefix-arg' to PREFIX, not
+evaluated. If COMMANDs symbol property `template-secure-command' is
+nil, the form is insecure. If that symbol property is a function, it is
+called with PREFIX to check whether COMMAND could be called directly
+with PREFIX as remaining arguments.
+
+ (\"KEY\" SEXPR...): evaluate SEXPR during the expansion, see
+`template-expansion-alist' for examples. This form is insecure.
+
+There are other per-template definitions:
+
+ \"MESSAGE\": additional line displayed at point until first user event
+or after `template-message-timeout' seconds. The lines are displayed
+with face in `template-message-face'. With active form selector
+:before, define a message which is displayed in
+`template-message-buffer' before the exansion has started. With active
+form selector :after, define a message which is displayed in
+`template-message-buffer' after the exansion has taken place. To
+define interactively, use \\[template-define-message].
+
+ (CHAR \. \"CONTENTS\"): Set register CHAR to have contents CONTENTS.
+CONTENTS can then be inserted into a buffer with \\[insert-register] CHAR.
+
+ (CHAR \"CONTENTS\" COMMENT) where COMMENT is optional: Set register
+CHAR to have contents CONTENTS. CONTENTS can then be inserted into a
+buffer with \\[insert-register] CHAR. Also display an additional line
+at point to show the contents with COMMENT. To define, use
+\\[template-define-register].
+
+The following forms depend on the active form selector which is the last
+of the following expansion forms:
+ - :before: \"MESSAGE\" will be displayed before the expansion
+ - :after: \"MESSAGE\" will be displayed after the expansion
+ - :eval-before: execute COMMAND and SEXPR before expansion
+ - :eval-after: execute COMMAND and SEXPR after expansion
+ - nil, deprecated: with the first form, the active form selector is
+ :eval-before, with the second, it is :eval-after.
+
+ (VARIABLE . VALUE): set SYMBOL's local value to VALUE, not evaluated.
+This form is only secure if VARIABLE has a symbol property
+`template-secure-value' which returns non-nil when applied to VALUE, not
+evaluated. This form is useful for variables which determine the
+expansion, like `template-time-format' and `template-date-format'. For
+local variables in your new file, use the normal way via the \"Local
+Variables:\" section. The active form selector must not be :eval-before
+or :eval-after.
+
+ COMMAND: COMMAND is a symbol or a vector and is called with
+`command-execute' before the expansion with form selector :eval-before,
+and after the expansion with form selector :eval-after. If COMMANDs
+symbol property `template-secure-command' is nil, the form is insecure.
+You should use the safe command `normal-mode' in the pre-expansion forms
+if the expansion forms depend on the correct major mode.
+
+ SEXPR: evaluate SEXPR before the expansion with form selector
+:eval-before, and after the expansion with form selector :eval-after.
+This form is insecure.
+
+If any insecure forms have been used, the user of the template will be
+asked whether to use the template, see `template-confirm-insecure'."
+ :group 'template-expansion
+ :type 'string)
+
+
+\f
+;;;;##########################################################################
+;;;; Commenting
+;;;;##########################################################################
+
+
+(defunx template-point-at-bol (&optional count)
+ :emacs-only line-beginning-position
+ :xemacs-only point-at-bol)
+
+(defunx template-point-at-eol (&optional count)
+ :emacs-only line-end-position
+ :xemacs-only point-at-eol)
+
+(defunx template-char-or-char-int-p (object)
+ :emacs-only integerp
+ :xemacs-only char-or-char-int-p)
+
+(defunx template-char-or-int-to-char (object)
+ :emacs-only identity
+ "Convert character or integer OBJECT into the equivalent character."
+ (if (characterp object) object (int-to-char object)))
+
+
+;;;===========================================================================
+;;; Main functions
+;;;===========================================================================
+
+;;;###autoload
+(defun template-single-comment (&optional arg)
+ "Decorate the comment in the current line with dashes and alike.
+The line must be a comment-only line or must contain a comment ending by
+eol. That is, jump to the end of the current line and insert the dashes
+and the final comment end-string up-to the fill position. Prefix
+argument ARG and `template-comment-specification' determines the comment
+style to use. The length of the resulting line is determined by
+`template-max-column' and `template-max-column-with-end'."
+ (interactive "*P")
+ (let* ((orig (point-marker))
+ (syntax0 (and comment-start comment-start-skip
+ (condition-case nil
+ (template-comment-syntax orig 'boc)
+ (error nil))))
+ (syntax (cond ((cdr syntax0)
+ (template-comment-syntax orig))
+ (syntax0
+ (condition-case nil
+ (template-comment-syntax (point-marker))
+ (error syntax0)))
+ (t
+ (back-to-indentation)
+ nil)))
+ (sep (template-comment-separator-regexp syntax))
+ (end (template-point-at-eol))
+ old)
+ (save-excursion
+ (cond ((re-search-forward sep end t)
+ ;; with sep in current line
+ (setq old (buffer-substring (match-beginning 1) (match-end 1)))
+ (delete-region (match-beginning 0) (match-end 0)))
+ ((cdr syntax) ; with start-end comment
+ (if (looking-at (concat "[ \t]*\\(.+\\)?"
+ (regexp-quote (cadr syntax))
+ "[ \t]*\\(.+\\)?$"))
+ (if (or (match-beginning 1) (match-beginning 2))
+ (error "This line contains non-separator chars and %S"
+ (cadr syntax))
+ ;; Delete comment-end. Don't delete its first char if it is
+ ;; the same as the second of comment-start.
+ (delete-region (if (and (= (length (car syntax)) 2)
+ (= (length (cadr syntax)) 2)
+ (eq (aref (car syntax) 1)
+ (aref (cadr syntax) 0)))
+ (1+ (match-beginning 0))
+ (match-beginning 0))
+ (match-end 0))))
+ (goto-char (cddr syntax))
+ (if (re-search-forward sep end t)
+ ;; sep in line between comment-start and point-at-eol
+ (setq old (buffer-substring (match-beginning 1)
+ (match-end 1)))))))
+ (template-insert-separator
+ (car (template-comment-specification arg old syntax))
+ nil syntax)))
+(put 'template-single-comment 'template-secure-command t)
+
+;;;###autoload
+(defun template-block-comment (&optional arg)
+ "Decorate the current block of comment-only lines with dashes and alike.
+That is, surround the the contiguous comment-only lines around point
+with extra lines containing dashes and alike and to put the correct
+number of newlines around the block.
+
+Barf if the comment syntax at point has a non-empty `comment-end' or if
+point is not in a comment-only line.
+
+A block comment consists of all neighboring lines which start with
+spaces and `comment-start'. If `comment-start' is a string of length 1,
+the number of repetitions of `comment-start' must be the same or larger
+than in the line where the command is invoked from, too.
+
+Prefix argument ARG and `template-comment-specification' determines the
+comment style to use. The length of the separator line is determined by
+`template-max-column'.
+
+This command can also be used with point in an empty line after a block
+comment. A second invocation of this command directly after a
+successful invocation deletes the remaining empty lines from the current
+line on."
+ (interactive "*P")
+ (let* ((orig (point-marker))
+ (syntax (progn
+ (end-of-line)
+ (skip-chars-backward " \t\n\f")
+ (template-comment-syntax orig))))
+ (when (cdr syntax)
+ (goto-char orig)
+ (error "Command only works with comments terminated by end-of-line"))
+
+ (if (and (eq last-command 'template-block-comment-success)
+ (looking-at "[ \t]*$"))
+ (template-insert-newline "" nil (1- (template-point-at-bol)))
+ (let* ((prefix (concat "[ \t]*" (regexp-quote (car syntax))))
+ (sepline (concat prefix "[ \t]*"
+ (template-comment-separator-regexp syntax)))
+ old block-beg block-end def)
+ ;; go to the first line with same comment prefix ---------------------
+ (beginning-of-line)
+ (while (and (not (bobp)) (looking-at prefix))
+ (beginning-of-line 0))
+ (or (looking-at prefix) (beginning-of-line 2))
+ (while (looking-at sepline)
+ (setq old (buffer-substring (1- (match-end 0)) (match-end 0)))
+ (kill-line 1))
+ (setq block-beg (point-marker))
+ ;; go to the last line with same comment prefix ----------------------
+ (while (looking-at prefix)
+ (template-indent-according-to-mode)
+ (beginning-of-line 2))
+ (if (eobp) (newline))
+ (setq block-end (copy-marker (point) t))
+ (while (progn (forward-line -1) (looking-at sepline))
+ (setq old (buffer-substring (1- (match-end 0)) (match-end 0)))
+ (kill-line 1))
+ ;; insert separator lines --------------------------------------------
+ (goto-char block-beg)
+ (set-marker block-beg nil)
+ (back-to-indentation)
+ (setq def (template-comment-specification arg old syntax))
+ (beginning-of-line)
+ (template-insert-newline (cadr def))
+ (template-insert-separator (car def) (car syntax) syntax)
+ (goto-char block-end)
+ (set-marker block-end nil)
+ (template-insert-separator (car def) (car syntax) syntax)
+ (template-insert-newline (caddr def)
+ (and (cadddr def)
+ (save-excursion
+ (forward-line (cadddr def))
+ (point))))
+ (setq this-command 'template-block-comment-success)))
+ (template-indent-according-to-mode)
+ (back-to-indentation)))
+(put 'template-block-comment 'template-secure-command t)
+
+
+;;;===========================================================================
+;;; Check comment start, return specification
+;;;===========================================================================
+
+(defun template-indent-according-to-mode ()
+ "Indent line according to `template-comment-indent'."
+ (if (if template-comment-indent
+ (not (memq major-mode template-indent-mode-disable-list))
+ (memq major-mode template-indent-mode-enable-list))
+ (indent-according-to-mode)))
+
+(defun template-default-comment ()
+ "Return default comment according to current position."
+ (if comment-start
+ (substring comment-start 0 (string-match "[ \t]\\'" comment-start))
+ (if (eolp) "#"
+ (let ((default (buffer-substring (point) (1+ (point)))))
+ (if (string-match "[A-Za-z]" default) "#" default)))))
+
+(defun template-comment-at-point ()
+ "Return the comment syntax at the current position.
+Return nil, if no commenting command can be used, i.e., if point is not
+in a comment-only line. Return `none' if the `major-mode' doesn't
+define a comment syntax. Return `delimited' if point is between
+`comment-start' and a non-empty `comment-end'. Return `single' if point
+is in a comment line where the comment syntax has a empty `comment-end',
+return `block' if point is in an empty line after such a comment line."
+ (if (and comment-start comment-start-skip)
+ (save-excursion
+ (let ((orig (point)))
+ (condition-case nil
+ (progn
+ (end-of-line)
+ (skip-chars-backward " \t\n\f")
+ (if (cdr (template-comment-syntax orig t)) 'delimited
+ (if (< (template-point-at-eol) orig) 'block 'single)))
+ (error
+ (condition-case nil
+ (progn
+ (goto-char orig)
+ (beginning-of-line)
+ (when (re-search-forward comment-start-skip
+ (template-point-at-eol) t)
+ (goto-char (or (match-end 1) (match-beginning 0)))
+ (unless (or (cdr (template-comment-syntax orig 'boc))
+ (< (template-point-at-eol) orig))
+ 'cont)))
+ (error nil))))))
+ 'none))
+
+(defun template-comment-syntax (orig &optional no-indent)
+ "Return the comment syntax at ORIG. Signal error if not in comment.
+Return (COMMENT-START) if the comment syntax has an empty `comment-end'.
+Return (COMMENT-START COMMENT-END . START-POS) if the comment syntax has
+a non-empty `comment-end' where START-POS is the position of the first
+character inside the comment. Move point to first character after the
+comment start or the first non-whitespace character on this line.
+
+ORIG should be the same as `point' or in a empty line after `point'.
+
+If optional argument NO-INDENT is nil, indents the current line
+according to `template-comment-indent' and `indent-according-to-mode'.
+If NO-INDENT is `boc', move point to the beginning of the comment.
+
+COMMENT-START is stripped off its final spaces, COMMENT-END off its
+initial spaces."
+ (unless (and comment-start comment-start-skip)
+ (error "No comment syntax has been defined for %s" major-mode))
+ (if (eq no-indent 'boc)
+ (progn
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip (template-point-at-eol) t)
+ (goto-char (or (match-end 1) (match-beginning 0)))))
+ (or no-indent (template-indent-according-to-mode))
+ (back-to-indentation))
+ (let* ((string (template-default-comment)))
+ (if (string= comment-end "")
+ (if (looking-at (concat (regexp-quote string)
+ (and (= (length string) 1)
+ (not (eq no-indent 'boc))
+ "+")))
+ (progn
+ (goto-char (match-end 0))
+ (list (buffer-substring (match-beginning 0) (point))))
+ (let ((alist template-alt-comment-syntax-alist)
+ elem c-start c-end)
+ (while alist
+ (setq elem (pop alist))
+ (and (template-match-modes-or-regexp (car elem))
+ (string-match comment-start-skip (cadr elem))
+ (setq c-start (cadr elem)
+ c-end (caddr elem)
+ alist nil)))
+ (template-comment-syntax-0 orig c-start c-end string)))
+ (template-comment-syntax-0 orig comment-start comment-end))))
+
+(defun template-comment-syntax-0 (orig c-start c-end &optional single)
+ ;; checkdoc-params: (orig c-start c-end single)
+ "Internal function for `template-comment-syntax'."
+ (unless (and (stringp c-start) (stringp c-end) (not (string= c-end "")))
+ (goto-char orig)
+ (error "Line does not start with %S"
+ (or single (template-default-comment))))
+ (setq c-start (substring c-start 0 (string-match "[ \t]\\'" c-start))
+ c-end (if (string-match "\\`[ \t]+" c-end)
+ (substring c-end (match-end 0))
+ c-end))
+ (cond ((looking-at (regexp-quote c-start))
+ (goto-char (match-end 0))
+ (cons c-start (cons c-end (point))))
+ ((save-excursion
+ (when (re-search-backward (concat "^[ \t]*" (regexp-quote c-start))
+ nil t)
+ (goto-char (match-end 0))
+ (let ((match (point)))
+ (unless (when (search-forward c-end orig t)
+ (skip-chars-forward " \t")
+ (< (point) orig))
+ (cons c-start (cons c-end match)))))))
+ (t
+ (goto-char orig)
+ (if single
+ (error "Not inside a comment (%S or %S-%S) starting in new line"
+ single c-start c-end)
+ (error "Not inside a comment (%S-%S) starting in new line"
+ c-start c-end)))))
+
+
+;;;===========================================================================
+;;; Comment specification
+;;;===========================================================================
+
+;; A simple `mapconcat' is likely to slow down Emacs' regexp search algorithm
+;; considerably (backtracking => near-infloop).
+(defun template-comment-separator-regexp (syntax)
+ "Return regexp matching separator comment lines.
+The regexp also matches if the lines ends with parts of COMMENT-END in
+argument SYNTAX, see `template-comment-syntax'."
+ (let ((estring (cadr syntax))
+ (alist template-comment-specification-alist)
+ (chars nil)
+ str i c)
+ (while alist
+ (setq str (car (pop alist)))
+ (when str
+ (setq i (length str))
+ (while (>= (decf i) 0)
+ ;; (pushnew (aref str i) chars), but requires cl at runtime:
+ (or (memq (setq c (aref str i)) chars) (push c chars)))))
+ (concat "\\("
+ (mapconcat (lambda (c) (regexp-quote (char-to-string c)))
+ (or chars "#")
+ "\\|")
+ (if estring
+ (concat "\\)+[ \t]*"
+ (mapconcat (lambda (c)
+ (regexp-quote (char-to-string c)))
+ estring
+ "?")
+ "?[ \t]*$")
+ "\\)+[ \t]*$"))))
+
+(defun template-comment-specification (arg old syntax)
+ "Return the comment specification to use.
+See `template-comment-specification-alist' for details. ARG is the
+prefix argument, OLD the SEPARATOR of the old comment style and SYNTAX
+is the comment syntax returned by `template-comment-syntax'."
+ (and arg (setq arg (prefix-numeric-value arg)))
+ ;; assumes point-at-indentation
+ (or (and arg (> arg 0)
+ (if (< (length template-comment-specification-alist) arg)
+ (car (last template-comment-specification-alist))
+ (nth (1- arg) template-comment-specification-alist)))
+ (and (null arg) old
+ (assoc old template-comment-specification-alist))
+ (and (functionp template-comment-specification-special)
+ (funcall template-comment-specification-special))
+ (and (functionp (get major-mode 'template-comment-specification-special))
+ (funcall (get major-mode 'template-comment-specification-special)))
+ (and syntax
+ (template-comment-specification
+ (if (or (cdr syntax) (> (length comment-start) 1))
+ (save-excursion
+ (if (cddr syntax) (goto-char (cddr syntax)))
+ (beginning-of-line)
+ (if (looking-at "[ \t]") 2 3))
+ (length (car syntax)))
+ nil nil))
+ '("-" "" "" 0)))
+
+
+;;;===========================================================================
+;;; Inserting
+;;;===========================================================================
+
+(defun template-insert-newline (string &optional limit start-limit)
+ "Deletes blank lines around point and insert STRING.
+After optional LIMIT and before optional START-LIMIT, no character will
+be deleted."
+ (let ((start (save-excursion
+ (skip-chars-backward " \t\n\f" start-limit)
+ (or (bobp) (forward-line 1))
+ (point)))
+ (end (save-excursion
+ (skip-chars-forward " \t\n\f" limit)
+ (beginning-of-line)
+ (point))))
+ (if (> end start) (delete-region start end)))
+ (or (bobp) (insert string)))
+
+(defun template-insert-separator (separator &optional cstring syntax)
+ "Insert separator line at point.
+If CSTRING is not nil, insert in special line which starts with CSTRING.
+Insert SEPARATOR repeatedly. End the line with COMMENT-END as specified
+in `template-comment-syntax'."
+ (when separator
+ (when cstring
+ (open-line 1)
+ (insert cstring)
+ (template-indent-according-to-mode))
+ (end-of-line)
+ (let* ((estring (cadr syntax))
+ (max-column (if estring
+ template-max-column-with-end
+ template-max-column))
+ (max (- (if (> max-column 0) max-column (+ fill-column max-column))
+ (length separator)
+ (length estring))))
+ (while (<= (current-column) max) (insert separator))
+ (if (>= (length separator) (- (current-column) max))
+ (insert (substring separator 0 (- max (current-column)))))
+ (if estring (insert estring))
+ (if cstring (forward-line 1)))))
+
+
+;;;===========================================================================
+;;; Adaptations: cc-mode
+;;;===========================================================================
+
+;; There isn't really anything I can do against the filling of "/**" in C, C++
+;; and Antlr mode (it is correct in Java), it should be done in the cc-mode
+;; package. Similar for filling "*/" with the previous line...
+
+(defun template-c-fill-paragraph (&optional arg)
+ ;; checkdoc-params: (arg)
+ "Like \\[c-fill-paragraph] but handles comment separator lines."
+ (let* ((regexp (concat "\\|[ \t]*\\(/[*/]\\|\\*\\)[ \t]*"
+ (template-comment-separator-regexp '("/*" "*/"))))
+ (paragraph-start (concat paragraph-start regexp)) ;#dynamic
+ (paragraph-separate (concat paragraph-separate regexp)))
+ (c-fill-paragraph arg)))
+
+(defun template-c-init-fill-function ()
+ "Set `fill-paragraph-function' to use `template-c-fill-paragraph'."
+ (when (boundp 'fill-paragraph-function)
+ (make-local-variable 'fill-paragraph-function)
+ (setq fill-paragraph-function 'template-c-fill-paragraph)))
+
+
+\f
+;;;;##########################################################################
+;;;; Updating (File Name in Header)
+;;;;##########################################################################
+
+
+;;;===========================================================================
+;;; General updating
+;;;===========================================================================
+
+(defun template-update-buffer-region (limit regexp group)
+ "Return region = (BEG . END) in buffer to be updated.
+If LIMIT is positive, check first LIMIT characters in buffer, otherwise
+check last -LIMIT characters in buffer for a text to be matched by
+REGEXP. Return region according to GROUP's regexp group in REGEXP."
+ (let ((case-fold-search nil))
+ (goto-char (if limit
+ (if (natnump limit) (point-min) (+ (point-max) limit))
+ (point-min)))
+ (when (re-search-forward regexp
+ (if (natnump limit)
+ (+ (point-min) limit)
+ (point-max))
+ t)
+ (cons (match-beginning group) (match-end group)))))
+
+(defun template-match-modes-or-regexp (modes-or-regexp)
+ "Return non-nil, if the current buffer passes MODES-OR-REGEXP.
+If MODES-OR-REGEXP is a list, it must include the current `major-mode',
+if it is a regexp, it must match the `buffer-file-name' without version,
+otherwise it must be non-nil."
+ (if (stringp modes-or-regexp)
+ (and buffer-file-name
+ (string-match modes-or-regexp
+ (file-name-sans-versions buffer-file-name)))
+ (or (nlistp modes-or-regexp) (memq major-mode modes-or-regexp))))
+
+(defun template-update-buffer (&optional arg)
+ "Update buffer according to `template-update-buffer-alist'.
+Do not do anything if `template-auto-update-disable-regexp' matches the
+file name or if `template-auto-update' is nil. When optional ARG is
+non-nil, i.e., if called interactively *without* prefix arg, always
+update."
+ (interactive (list (null current-prefix-arg)))
+ (when (or arg
+ (and template-auto-update buffer-file-name
+ (null (and template-auto-update-disable-regexp
+ (string-match template-auto-update-disable-regexp
+ buffer-file-name)))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((alist template-update-buffer-alist)
+ (case-fold-search (memq system-type '(vax-vms ms-dos windows-nt)))
+ stamp prompt region new)
+ (while alist
+ (setq stamp (pop alist))
+ (condition-case nil
+ (and (template-match-modes-or-regexp (pop stamp))
+ ;; Run TEST ---------------------------------------------
+ (setq prompt (pop stamp)
+ region (pop stamp) ; TEST
+ region (eval (if (or (atom region)
+ (functionp (car region)))
+ region
+ (cons 'template-update-buffer-region
+ region))))
+ (if (stringp (setq new (eval (pop stamp))))
+ (null (string= (buffer-substring (car region)
+ (cdr region))
+ new))
+ (car stamp))
+ ;; user confirmation, replacement -----------------------
+ (or (null prompt)
+ arg
+ (eq template-auto-update t)
+ (y-or-n-p (format prompt (buffer-name))))
+ (progn
+ (goto-char (car region))
+ (if (car stamp)
+ (funcall (car stamp) new (car region) (cdr region))
+ (delete-region (car region) (cdr region))
+ (insert new))))
+ (error nil))))))))
+
+
+;;;===========================================================================
+;;; Update header
+;;;===========================================================================
+
+;;;###autoload
+(defun template-update-header (&optional show)
+ "Replace old file name in header with current file name.
+If SHOW is t, just return region of the filename or nil. Otherwise,
+replace filename if possible and signal an error if SHOW is nil and
+there is no filename in the header. See `template-header-lines' and
+`template-header-regexp-alist'."
+ (interactive "*P")
+ (if buffer-file-name
+ (save-excursion
+ (goto-char (point-min))
+ (let ((case-fold-search nil)
+ (comment-regexp (template-default-comment)) ; at `point-min'!
+ (end (progn (forward-line template-header-lines) (point)))
+ (alist template-header-regexp-alist)
+ (disallowed "")
+ group)
+ (if (string-match "[A-Za-z]\\|.." comment-regexp)
+ (setq comment-regexp (regexp-quote comment-regexp)
+ disallowed "")
+ (or (eq comment-regexp '(?\]))
+ (setq disallowed comment-regexp))
+ (setq comment-regexp (concat (regexp-quote comment-regexp) "+")))
+ (while alist
+ (goto-char (point-min))
+ (if (re-search-forward (format (caar alist)
+ comment-regexp disallowed)
+ end t)
+ (setq group (cdar alist)
+ alist nil)
+ (setq alist (cdr alist))))
+ (if (and group (match-beginning group))
+ (if (eq show t)
+ (cons (match-beginning group) (match-end group))
+ (goto-char (match-beginning group))
+ (delete-region (point) (match-end group))
+ (insert (file-name-sans-versions
+ (file-name-nondirectory buffer-file-name)))
+ t)
+ (if show nil (error "No file name in header")))))
+ (if show nil (error "Buffer is not visiting a file"))))
+
+
+\f
+;;;;##########################################################################
+;;;; Templates
+;;;;##########################################################################
+
+
+(defvar template-history nil
+ "History, used by `template-read'.")
+
+(defvar template-choice-history nil
+ "History, used by `template-choice'.")
+
+(put 'normal-mode 'template-secure-command t)
+
+(defvar template-all-templates nil
+ "Internal variable. Template files used for template derivation.")
+(defvar template-file nil
+ "Partitioned name of new file: (DIR FILE RAW NUMBER EXT).
+Internal variable. DIR is the directory part, FILE the file name
+without directory part. FILE consists of its extension EXT, RAW and a
+numbering NUMBER just in front of the extension. It is used by the
+expansions DIR, FILE, FILE_SANS, FILE_EXT and others in
+`template-expansion-alist'. Also useful for user defined functions in
+`template-derivation-alist' and the per-template definition section.")
+
+(defvar template-modified nil
+ "Internal variable. Whether user is asked during the expansion process.")
+(defvar template-secure t
+ "Internal variable. Whether all per-template definitions are secure.")
+(defvar template-point-messages nil
+ "Internal variable. List of lines for temporary message at point.")
+(defvar template-before-messages nil
+ "Internal variable. List of lines for temporary message before expansion.")
+(defvar template-after-messages nil
+ "Internal variable. List of lines for temporary message after expansion.")
+
+(defvar template-point nil
+ "Internal variable. Position of point. Set with expansion form P.")
+(defvar template-mark nil
+ "Internal variable. Position of mark. Set with expansion form M.")
+
+(defvar template-current nil
+ "Internal variable. Current key of expansion form.")
+(defvar template-string-alist nil
+ "Internal variable. Alist of user inputs for `template-read'.")
+(defvar template-register-alist nil
+ "Internal variable. Alist of used registers.")
+(defvar template-local-alist nil
+ "Internal variable. Alist of per-template defined expansions.")
+
+(defvar template-ffap-file-finder nil
+ "Value used inside `template-ffap-find-file'.
+If nil, initialize it to the value of `ffap-file-finder', i.e., this
+variable holds the original value of that variable which will be set to
+`template-ffap-find-file' in `template-initialize'.")
+
+
+;;;===========================================================================
+;;; Functions: `find-file'/`insert-file-contents', hooking into `find-file'
+;;;===========================================================================
+
+(defun template-find-template (filename &optional replace)
+ "Switch to a buffer visiting template file FILENAME.
+If optional REPLACE is non-nil, replace the current buffer contents with
+the contents of file FILENAME.
+
+This function always considers template files as text files."
+ (let ((file-name-buffer-file-type-alist nil)) ; Emacs on DOS/NT
+ (if replace
+ (insert-file-contents filename nil nil nil
+ ;; 5th arg not t with empty accessible part
+ ;; (XEmacs bug workaround: would infloop)
+ (> (point-max) (point-min)))
+ (let ((template-auto-insert nil))
+ (switch-to-buffer (find-file-noselect filename))))))
+
+(defun template-not-found-function ()
+ "Use a template when visiting a non-existent file.
+See `template-auto-insert' and `template-find-file-commands'. Function
+in `find-file-not-found-hooks'."
+ (and template-auto-insert (not buffer-read-only) (bobp) (eobp)
+ (or (memq this-command template-find-file-commands)
+ (and (memq this-command template-file-select-commands)
+ ;; thanks to Dave Love <d.loveNOSPAMdl.ac.uk>:
+ (memq (car-safe (car command-history))
+ ;; To always include `find-file-at-point', use ffap
+ ;; initialization (see `template-ffap-find-file')
+ template-find-file-commands)))
+ (let ((template (cdr (template-derivation buffer-file-name t t))))
+ (and template
+ (file-readable-p template)
+ (or (eq template-auto-insert t)
+ (y-or-n-p
+ (format "Use template %s? "
+ (cond-emacs-xemacs
+ (abbreviate-file-name template :XEMACS t)))))
+ (progn
+ (template-new-file nil template)
+ (setq this-command 'session-disable)
+ t)))))
+
+(defun template-ffap-find-file (filename)
+ "Function to use in `ffap-file-finder'.
+Add an entry to `command-history' if necessary and call function in
+`template-ffap-file-finder' with argument FILENAME."
+ (or (memq (car-safe (car command-history))
+ '(ffap find-file-at-point))
+ (setq command-history
+ (cons (list 'find-file-at-point filename) command-history)))
+ (if (eq template-ffap-file-finder 'template-ffap-find-file)
+ (find-file filename)
+ (funcall template-ffap-file-finder filename)))
+
+
+;;;===========================================================================
+;;; Main function
+;;;===========================================================================
+
+(defun template-expand-template-interactive ()
+ (let* ((use (template-derivation (expand-file-name
+ (or buffer-file-name "NONE"))
+ t))
+ (tpl (read-file-name "Insert and expand template: "
+ (file-name-directory (cdr use))
+ (file-name-nondirectory (cdr use))
+ t
+ (file-name-nondirectory (cdr use)))))
+ (if (string= tpl "")
+ (error "No template file provided"))
+ (list (expand-file-name tpl (file-name-directory (cdr use))))))
+
+;;;###autoload
+(defun template-expand-template (template)
+ "Expand template file TEMPLATE and insert result in current buffer.
+Using a template for inserting some text consists of:
+ 1. Template derivation: suggest a reasonable template file to the user
+ according to `buffer-file-name', see `template-derivation-alist'.
+ 2. Template insertion: insert the template file at point into the
+ current buffer.
+ 3.. as steps 6.. of `template-new-file'."
+ (interactive (template-expand-template-interactive))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (template-new-file nil template t)))
+
+(defun template-new-file-interactive ()
+ "Interactive specification for `template-new-file'.
+Return \(FILE TEMPLATE)."
+ (let* ((inp (read-file-name (if current-prefix-arg
+ "New file (+template, no name change): "
+ "New file (+template): ")
+ nil ""))
+ (use (cond ((equal inp "")
+ (error "Empty/no input"))
+ ((file-directory-p inp)
+ (error "%S is a directory" inp))
+ (t (template-derivation (expand-file-name inp)
+ current-prefix-arg))))
+ (tpl (read-file-name (format "File %s uses template: "
+ (file-name-nondirectory (car use)))
+ (file-name-directory (cdr use))
+ (file-name-nondirectory (cdr use))
+ t
+ (file-name-nondirectory (cdr use)))))
+ (list (car use)
+ (if (string= tpl "")
+ nil
+ (expand-file-name tpl (file-name-directory (cdr use)))))))
+
+;;;###autoload
+(defun template-new-file (file template &optional with-undo)
+ "Open a new file FILE by using a TEMPLATE.
+Using a template for creating a new file consists of, steps 1 to 3 are
+only executed when called interactively:
+ 1. Prompt for the name of the new file.
+ 2. Template derivation: suggest a reasonable template file to the user
+ see `template-derivation-alist'.
+ 3. File name refinement: e.g., if the given file name is \"exercise\"
+ and there are two files \"exercise1.tex\" and \"exercise2.tex\" in
+ the same directory and if we have a template \"exercise.tex.tpl\",
+ the file name is refined to \"exercise3.tex\". This is turned off
+ when \\[template-new-file] is called with a prefix argument.
+ 4. Template insertion: insert the template file into the empty buffer.
+ 5. Read per-template expansion definition section starting at
+ `template-definition-start' and delete it.
+ 6. Display :before message in `template-message-buffer'.
+ 7. Execute pre-expansion commands defined in the definition section.
+ 8. Set local variables defined in the definition section.
+ 9. Expansion: expand the expansion forms (text matched by
+ `template-expansion-regexp') They are defined in the definition
+ section, in `template-expansion-alist', or provided by default, see
+ `template-expansion-regexp' and `template-register-regexp'.
+ 10. Execute post-expansion commands defined in the definition section.
+ 11. Run `normal-mode' and functions in `find-file-hooks'.
+ 12. Update header according to `template-update-header' with argument
+ `if-exists'.
+ 13. Display :after message in `template-message-buffer'.
+ 14. Report: display a temporary message at point defined in the
+ definition section and an automatically generated message in the
+ minibuffer area, see `template-message-timeout'.
+
+If optional WITH-UNDO is non-nil, store corresponding changes in
+`buffer-undo-list'. If FILE is nil, the buffer for FILE has already
+been created and the accessible part will be replaced by the expanded
+template. If TEMPLATE is nil (empty input when called interactively),
+do not use a template."
+ (interactive (template-new-file-interactive))
+ ;; check template and file name --------------------------------------------
+ (if template
+ (if (file-readable-p template)
+ (if (file-directory-p template)
+ (error "Template %s is a directory" template))
+ (if (null (yes-or-no-p (format "Template %s does not exist. Create? "
+ template)))
+ (error "No template file to use")
+ (template-make-directory (file-name-directory template))
+ (template-find-template template)
+ (error "You should create this template first"))))
+ (if (not file)
+ (switch-to-buffer (current-buffer))
+ (and (or (get-file-buffer file) (file-exists-p file))
+ (null (yes-or-no-p (format "File %s exists. Delete contents? " file)))
+ (error "Cannot use templates for existing files"))
+ (let ((auto-mode-alist nil)
+ (enable-local-variables nil)
+ (find-file-not-found-hooks nil)
+ (enable-local-eval nil))
+ (switch-to-buffer (find-file-noselect file))))
+ (when template
+ (or with-undo (setq buffer-undo-list t))
+ (template-find-template template t)
+ (template-new-file-0 with-undo)))
+
+(defun template-new-file-0 (with-undo)
+ "Perform template replacements in current buffer.
+If WITH-UNDO is non-nil, store corresponding changes in
+`buffer-undo-list'."
+ ;; start replacement -------------------------------------------------------
+ (or with-undo (set-buffer-modified-p nil))
+ (goto-char (point-min))
+ (setq template-secure t
+ template-point nil
+ template-mark nil
+ template-modified nil
+ template-point-messages nil
+ template-before-messages nil
+ template-after-messages nil
+ template-local-alist nil
+ template-register-alist nil
+ template-string-alist nil)
+ (let ((form-selector nil)
+ (pre-command-list nil)
+ (post-command-list nil)
+ (local-variable-list nil)
+ val)
+ ;; read per-template definition section ----------------------------------
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^[ \t]*" template-definition-start "[ \t]*$") nil t)
+ (condition-case ()
+ (while t
+ (setq val (read (current-buffer)))
+ (cond (;; ("KEY" . xxx): ask user --------------------------------
+ (and (consp val) (stringp (car val)))
+ (let* ((def (cdr val)) ; expansion forms
+ (msg (cond ((null template-message-prompt-format)
+ nil)
+ ((stringp def) def)
+ ((and (consp def) (stringp (car def)))
+ (car def)))))
+ (when msg ; list prompts in before-messages
+ (or template-before-messages
+ (null template-message-prompt-intro)
+ (push template-message-prompt-intro
+ template-before-messages))
+ (push (format template-message-prompt-format msg)
+ template-before-messages))
+ (push (cons (car val) (template-translate-definition def))
+ template-local-alist)))
+ ;; :before, :after, :eval-before, :eval-after --------------
+ ((null val) ; nil is deprecated
+ (setq form-selector
+ (cond ((null form-selector) :old-before)
+ ((eq form-selector :old-before) :old-after)
+ ((eq form-selector :old-after)
+ (error "More than two (obsolete) nil forms"))
+ (t
+ (error "Used obsolete nil form with new form selectors")))))
+ ((memq val '(:before :after :eval-before :eval-after))
+ (setq form-selector val))
+ ;; "MESSAGE" -----------------------------------------------
+ ((stringp val)
+ (cond ((eq form-selector :before)
+ (push val template-before-messages))
+ ((eq form-selector :after)
+ (push val template-after-messages))
+ (t
+ (push val template-point-messages))))
+ ;; (CHAR . xxx): set register ------------------------------
+ ((and (consp val) (template-char-or-char-int-p (car val)))
+ (let ((reg (template-char-or-int-to-char (car val))))
+ (if (atom (cdr val))
+ (set-register reg (cdr val))
+ (set-register reg (cadr val))
+ (when template-message-register-format
+ (let ((msg (format template-message-register-format
+ reg (cadr val)
+ (or (caddr val) ""))))
+ (if template-message-buffer
+ (progn
+ (if template-before-messages
+ (push msg template-before-messages))
+ (or template-after-messages
+ (null template-message-register-intro)
+ (push template-message-register-intro
+ template-after-messages))
+ (push msg template-after-messages))
+ (push msg template-point-messages)))))))
+ ;; set var, execute command and sexpr ----------------------
+ ((and (memq form-selector '(nil :before :after))
+ (consp val)
+ (symbolp (car val)))
+ (or (and (functionp (get (car val) 'template-secure-value))
+ (funcall (get (car val) 'template-secure-value)
+ (cdr val)))
+ (setq template-secure nil))
+ (push val local-variable-list))
+ ((memq form-selector '(:eval-before :old-before))
+ (push (template-elisp-in-definition val)
+ pre-command-list))
+ ((memq form-selector '(:eval-after :old-after))
+ (push (template-elisp-in-definition val)
+ post-command-list))
+ (t
+ (error "Illegal form"))))
+ (error nil))
+ (skip-chars-forward " \t\n\f")
+ (or (eobp)
+ (error "Invalid definition in line %d (pos %d) of the template file"
+ (count-lines 1 (point)) (point)))
+ (or template-secure
+ (null (default-value template-confirm-insecure))
+ (y-or-n-p "Have you checked the template functions? ")
+ (error "Failed security check"))
+ (delete-region (match-beginning 0) (point-max)))
+ ;; expand ----------------------------------------------------------------
+ (template-display-messages template-before-messages)
+ (eval (cons 'progn (nreverse pre-command-list)))
+ (while local-variable-list
+ (make-local-variable (caar local-variable-list))
+ (set (caar local-variable-list) (cdar local-variable-list))
+ (setq local-variable-list (cdr local-variable-list)))
+ (goto-char (point-min))
+ (while (re-search-forward template-expansion-regexp nil t)
+ (setq template-current (buffer-substring (match-beginning 1)
+ (match-end 1))
+ val (assoc template-current template-local-alist))
+ (unless val
+ (if (setq val (assoc template-current template-key-alias-alist))
+ (setq template-current (cdr val)))
+ (setq val (or (assoc template-current template-expansion-alist)
+ (assoc template-current
+ template-default-expansion-alist))))
+ (delete-region (match-beginning 0) (match-end 0))
+ (cond (val
+ (eval (cons 'progn (cdr val))))
+ ((string-match template-register-regexp template-current)
+ (template-register))
+ (t
+ (template-read (format "Replacement for `%s': "
+ template-current)))))
+ (eval (cons 'progn (nreverse post-command-list)))
+ (save-restriction
+ (widen)
+ (normal-mode t)
+ (or with-undo (template-update-header 'if-exists))
+ (run-hooks 'find-file-hooks))
+ ;; message ---------------------------------------------------------------
+ (template-display-messages template-after-messages)
+ (cond ((null template-register-alist)
+ (message "%s, no buffer location in register"
+ (if template-mark "Mark set" "No mark")))
+ (t (message "%s, buffer location in register: %s"
+ (if template-mark "Mark set" "No mark")
+ (mapconcat (function
+ (lambda (x)
+ (if (cdr x)
+ (concat (char-to-string (car x)) "*")
+ (char-to-string (car x)))))
+ (nreverse template-register-alist)
+ ", "))))
+ (or with-undo (set-buffer-modified-p template-modified))
+ (goto-char (point-min))
+ (when template-point
+ (goto-char template-point)
+ (set-marker template-point nil))
+ (when template-mark
+ (push-mark template-mark)
+ (set-marker template-mark nil)
+ (if (fboundp 'zmacs-activate-region) (zmacs-activate-region)))
+ (when (and template-point-messages
+ (or (cdr template-point-messages)
+ (not (string-equal (car template-point-messages) ""))))
+ (let ((beg (point))
+ end)
+ (if (cdr template-point-messages)
+ (insert (mapconcat 'identity
+ (nreverse template-point-messages)
+ "\n")
+ "\n")
+ (insert (car template-point-messages)))
+ (setq end (point))
+ (goto-char beg)
+ (and (fboundp 'make-extent) (fboundp 'set-extent-face)
+ (set-extent-face (make-extent beg end) 'template-message-face))
+ (recenter)
+ (sit-for template-message-timeout)
+ (delete-region beg end))))
+ (recenter)
+ (unless with-undo
+ (setq buffer-undo-list nil)
+ (set-buffer-modified-p template-modified)))
+
+(defun template-display-messages (messages)
+ (when (and messages template-message-buffer)
+ (setq messages (nreverse messages))
+ (with-output-to-temp-buffer template-message-buffer
+ (while messages
+ (princ (pop messages))
+ (if messages (princ "\n"))))))
+
+
+;;;===========================================================================
+;;; Determine name of the new file and the template
+;;;===========================================================================
+
+(defun template-derivation (full arg &optional no-default)
+ "Derive template file name and do file name refinement.
+Return (REFINED . TEMPLATE) where REFINED is the refined version of FULL
+and TEMPLATE and template file name, see `template-derivation-alist'.
+FULL is the initial file name given by the user. File name refinement
+is turned off when ARG is non-nil. If optional argument NO-DEFAULT is
+non-nil, return nil instead (FULL \. \"~/.templates/DEFAULT.tpl\") if no
+matching entry can be found in `template-derivation-alist'."
+ ;; Get all templates -------------------------------------------------------
+ (setq template-all-templates nil)
+ (let* ((dir (file-name-directory full))
+ (len (length dir))
+ (case-fold-search (memq system-type '(vax-vms ms-dos windows-nt))))
+ (while (and dir
+ (not (and template-stop-derivation
+ (fboundp template-stop-derivation)
+ (funcall template-stop-derivation dir))))
+ (template-all-templates template-subdirectories dir)
+ (setq dir (file-name-directory (directory-file-name dir)))
+ (or (> len (setq len (length dir)))
+ (setq dir nil)))
+ (template-all-templates template-default-directories)
+ (setq template-all-templates (nreverse template-all-templates)))
+ ;; Get template file -------------------------------------------------------
+ (if (string= (file-name-nondirectory full) "")
+ (error "You cannot use templates for directories"))
+ (setq template-file (template-split-filename full))
+ (let ((tests template-derivation-alist)
+ test template file)
+ (while tests
+ (setq test (caar tests)
+ file (cdar tests))
+ (if (setq template
+ (if (functionp (car test))
+ (apply (car test) (cdr test))
+ (apply 'template-default-template test)))
+ (setq tests nil)
+ (setq tests (cdr tests))))
+ (if template
+ (or arg
+ (if (functionp (car file))
+ (apply (car file) template (cdr file))
+ (apply 'template-unique-file template file)))
+ (or no-default
+ (setq template (template-split-filename
+ "DEFAULT"
+ (template-default-directory)))))
+ (if template
+ (cons (expand-file-name (cadr template-file) (car template-file))
+ (expand-file-name (concat (cadr template) template-extension)
+ (car template))))))
+
+(defun template-default-directory ()
+ "Return directory of file \"DEFAULT.tpl\"."
+ (let ((dirs template-default-directories)
+ (name (concat "DEFAULT" template-extension))
+ dir)
+ (while dirs
+ (setq dir (pop dirs))
+ (if (file-readable-p (expand-file-name name dir))
+ (setq dirs nil)
+ (setq dir nil)))
+ (or dir
+ (car template-default-directories)
+ (expand-file-name "~/.templates/"))))
+
+
+;;;===========================================================================
+;;; Small functions
+;;;===========================================================================
+
+(defun template-make-directory (dir)
+ "Create DIR if it does not exists yet."
+ (cond ((file-exists-p dir))
+ ((yes-or-no-p (format "The directory %s does not exist. Create? " dir))
+ (make-directory dir t))
+ (t (error "You should create a directory \"%s\"" dir)))
+ dir)
+
+(defun template-split-filename (file &optional dir)
+ "Split file name into its parts.
+If DIR is nil, FILE is a fully expanded file name, otherwise FILE is a
+file name without its directory part DIR. See `template-file'."
+ (or dir (setq dir (template-make-directory (file-name-directory file))
+ file (file-name-nondirectory file)))
+ (let* ((ext (string-match "\\.[^.]*\\'" file))
+ (raw (substring file 0 ext))
+ (num (string-match "[^0-9][0-9]+\\'" raw)))
+ (if num
+ (list dir file
+ (substring raw 0 (1+ num))
+ (substring raw (1+ num))
+ (if ext (substring file ext) ""))
+ (list dir file raw "" (if ext (substring file ext) "")))))
+
+(defun template-translate-definition (def)
+ "Translate DEF of expansion and set `template-secure' accordingly."
+ (cond ((null def) ; zero form
+ nil)
+ ((template-char-or-char-int-p def)
+ `((template-register ,def)))
+ ((stringp def)
+ `((template-read ,def nil nil nil t)))
+ ((symbolp def)
+ `((insert (if (stringp ,def) ,def template-string-default))))
+ ((and (consp def) (stringp (car def)))
+ (if (consp (car-safe (cdr def)))
+ `((template-choice ,(car def) (quote ,(cdr def))))
+ `((apply (quote template-read) (quote ,def)))))
+ ((consp (car-safe def))
+ (setq template-secure nil)
+ def)
+ (t
+ (list (template-elisp-in-definition (car def) (cdr def))))))
+
+(defun template-elisp-in-definition (def &optional prefix)
+ "Return valid elisp definition and set `template-secure' accordingly.
+DEF is the elisp form, PREFIX would be the prefix argument if DEF is a
+command."
+ (cond ((consp def)
+ (setq template-secure nil)
+ def)
+ ((or (symbolp def) (vectorp def))
+ (or (and (symbolp def) (get def 'template-secure-command))
+ (setq template-secure nil))
+ (if (and (symbolp def)
+ (functionp (get def 'template-secure-command))
+ (listp prefix)
+ (funcall (get def 'template-secure-command) prefix))
+ `(apply (quote ,def) (quote ,prefix))
+ `(progn (setq prefix-arg (quote ,prefix))
+ (command-execute (quote ,def)))))
+ (t
+ (error "Illegal form"))))
+
+
+;;;===========================================================================
+;;; Compute template name
+;;;===========================================================================
+
+(defun template-all-templates (dirs &optional base)
+ "Read names of template files in DIRS relatively to BASE.
+Insert the names to internal variable `template-all-templates'."
+ (let ((regexp (concat (regexp-quote template-extension) "\\'"))
+ (endpos (- (length template-extension)))
+ dir templates)
+ (while dirs
+ (setq dir (expand-file-name (car dirs) base)
+ dirs (cdr dirs))
+ (cond-emacs-xemacs
+ (and (file-accessible-directory-p dir)
+ (file-readable-p dir)
+ (setq templates (directory-files dir t regexp :XEMACS nil t))
+ (while templates
+ (and :EMACS
+ (not (file-directory-p (car templates)))
+ :BOTH
+ (file-readable-p (car templates))
+ (push (template-split-filename (substring (car templates)
+ 0
+ endpos))
+ template-all-templates))
+ (setq templates (cdr templates))))))))
+
+(defun template-set-template-part (part file-part)
+ "Set template part according to definition PART and FILE-PART.
+See `template-derivation-alist' for details."
+ (when part
+ (cond ((stringp part) part)
+ ((eq part t) file-part)
+ ((null (string= file-part "")) file-part))))
+
+(defun template-default-template (&optional raw num ext regexp)
+ "Return template according to RAW, NUM, EXT and REGEXP.
+See `template-derivation-alist' for details."
+ (if (or (null regexp) (string-match regexp (cadr template-file)))
+ (let ((templates template-all-templates)
+ (file-rne (cddr template-file))
+ result template-rne)
+ (setq raw (template-set-template-part raw (car file-rne))
+ num (template-set-template-part num (cadr file-rne))
+ ext (template-set-template-part ext (caddr file-rne)))
+ (while templates
+ (setq template-rne (cddar templates))
+ (if (and (or (null raw) (string= (car template-rne) raw))
+ (or (null num) (string= (cadr template-rne) num))
+ (or (null ext) (string= (caddr template-rne) ext)))
+ (setq result (car templates)
+ templates nil)
+ (setq templates (cdr templates))))
+ result)))
+
+
+;;;===========================================================================
+;;; File name refinement
+;;;===========================================================================
+
+(defun template-default-file (template &optional raw num ext)
+ "Refine file name according to TEMPLATE, RAW, NUM and EXT.
+The result is in `template-file'. See `template-derivation-alist'."
+ (let ((template-rne (cddr template))
+ (file-rne (cddr template-file)))
+ (if raw
+ (if (eq raw t) (setq raw (car template-rne)))
+ (setq raw (car file-rne)))
+ (if num
+ (if (eq num t) (setq num (cadr template-rne)))
+ (setq num (cadr file-rne)))
+ (if ext
+ (if (eq ext t) (setq ext (caddr template-rne)))
+ (setq ext (caddr file-rne)))
+ (setcdr template-file (list (concat raw num ext) raw num ext))))
+
+(defunx template-unique-file (template &optional raw num ext auto-num)
+ "Refine file name according to TEMPLATE, RAW, NUM, EXT and AUTO-NUM.
+Use auto numbering if NUM is not \"\" or AUTO-NUM is non-nil. The
+result is in `template-file'. See `template-derivation-alist'."
+ (template-default-file template raw num ext)
+ (let* ((dir (car template-file))
+ (full (expand-file-name (cadr template-file) dir)))
+ (when (if (string= (fourth template-file) "")
+ auto-num
+ (setq auto-num
+ (and (or (get-file-buffer full)
+ (file-readable-p full))
+ (string-to-int (fourth template-file)))))
+ (setq auto-num (1- auto-num)
+ raw (third template-file)
+ ext (fifth template-file))
+ (let ((list (buffer-list))
+ file1 dir1)
+ (while list
+ (and (setq file1 (buffer-file-name (car list)))
+ (setq dir1 (file-name-directory file1))
+ (string= dir1 dir)
+ (setq auto-num
+ (max (template-filename-number
+ (cddr (template-split-filename
+ (file-name-nondirectory file1)
+ dir1))
+ raw ext)
+ auto-num)))
+ (setq list (cdr list)))
+ (setq list (directory-files dir nil nil t :XEMACS t))
+ (while list
+ (unless (:EMACS file-directory-p (car list))
+ (setq auto-num
+ (max (template-filename-number
+ (cddr (template-split-filename (car list) dir))
+ raw ext)
+ auto-num)
+ list (cdr list))))
+ (template-default-file template raw
+ (int-to-string (1+ auto-num))
+ ext)))))
+
+(defun template-filename-number (file-rne raw ext)
+ "Return numbering in FILE-RNE if the RAW and EXT parts are equal."
+ (or (and (string= (car file-rne) raw)
+ (string= (caddr file-rne) ext)
+ (string-to-int (cadr file-rne)))
+ 0))
+
+
+;;;===========================================================================
+;;; Safe commands for per-template expansions
+;;;===========================================================================
+
+(defun template-insert-time (&optional format default)
+ "Insert time into current buffer using time format FORMAT.
+If FORMAT is not a string, it uses DEFAULT or `current-time-string'."
+ (interactive)
+ (insert (if (and (stringp format) (fboundp 'format-time-string))
+ (format-time-string format (current-time))
+ (or default (current-time-string)))))
+(put 'template-insert-time 'template-secure-command
+ (lambda (args)
+ (or (null args) (and (stringp (car args)) (null (cdr args))))))
+
+
+;;;===========================================================================
+;;; Functions for the predefined expansions
+;;;===========================================================================
+
+(defun template-register (&optional register)
+ "Set current location in register REGISTER.
+That is, \\[jump-to-register] REGISTER jumps to the current position.
+If REGISTER is nil, use register corresponding to the last character in
+`template-current'."
+ (let* ((char (if register
+ (template-char-or-int-to-char register)
+ (aref template-current (1- (length template-current)))))
+ (elem (assoc char template-register-alist)))
+ (point-to-register char)
+ (if elem
+ (setcdr elem t)
+ (push (list char) template-register-alist))))
+
+(defun template-read (prompt &optional prefix suffix default again-p)
+ "Ask user with PROMPT for a STRING to be inserted.
+If STRING is not \"\", insert PREFIX STRING SUFFIX, otherwise DEFAULT.
+If AGAIN-P is nil, do not ask if `template-current' appears another time
+as key in a expansion form. If AGAIN-P is `expand', the inserted region
+is searched for expansion forms where STRING is marked as a literal
+environment, see `template-literal-environment'."
+ (setq template-modified t)
+ (let ((pos (point))
+ (elem (and (null again-p)
+ (assoc template-current template-string-alist))))
+ (if elem
+ (setq elem (cdr elem))
+ (setq elem (read-from-minibuffer prompt nil nil nil
+ 'template-history)
+ elem (cond ((string= elem "") (or default ""))
+ ((eq again-p 'expand)
+ (concat prefix
+ (format template-expansion-format
+ (car template-literal-environment))
+ elem
+ (format template-expansion-format
+ (cdr template-literal-environment))
+ suffix
+ (format template-expansion-format
+ (car template-literal-environment))
+ (format template-expansion-format
+ (cdr template-literal-environment))))
+ (t
+ (concat prefix elem suffix))))
+ (or again-p (push (cons template-current elem) template-string-alist)))
+ (insert elem)
+ (if (eq again-p 'expand) (goto-char pos))))
+
+(defun template-choice (prompt table)
+ "Ask user with PROMPT for a choice and insert it.
+Each element in TABLE looks like (ANSWER . TEXT). Ask for an input with
+completion over all ANSWERs and insert corresponding TEXT if ANSWER is a
+string, otherwise ask a \"y or n\" question and use the result of
+`y-or-n-p' as ANSWER. Expansion forms in TEXT will be expanded."
+ (setq template-modified t)
+ (let ((pos (point)))
+ (insert (or (cdr (assoc (if (stringp (caar table))
+ (completing-read prompt table nil t nil
+ 'template-choice-history)
+ (y-or-n-p prompt))
+ table))
+ "")
+ (format template-expansion-format
+ (car template-literal-environment))
+ (format template-expansion-format
+ (cdr template-literal-environment)))
+ (goto-char pos)))
+
+
+;;;===========================================================================
+;;; Menu filter
+;;;===========================================================================
+
+(defun template-menu-filter (menu-items)
+ ;; checkdoc-params: (menu-items)
+ "Menu filter for `template-creation-menu'."
+ (let ((alist (append template-expansion-alist
+ template-default-expansion-alist))
+ menu used key)
+ (while alist
+ (unless (member (setq key (car (pop alist))) used)
+ (push key used)
+ (push (vector (concat "Insert " key)
+ (list 'template-insert-form current-prefix-arg key)
+ t)
+ menu)))
+ (append menu-items (nreverse menu))))
+
+
+;;;===========================================================================
+;;; Insert and define forms
+;;;===========================================================================
+
+(defun template-buffer-template-p ()
+ "Return non-nil, if current buffer is likely to be a template file."
+ (and buffer-file-name
+ (string-match (concat (regexp-quote template-extension) "\\'")
+ (file-name-sans-versions buffer-file-name))))
+
+(defun template-open-template ()
+ "If current buffer is no template file, open a new one."
+ (interactive)
+ (if (template-buffer-template-p)
+ (barf-if-buffer-read-only)
+ (let (name
+ (dir (and (car template-subdirectories)
+ (expand-file-name (car template-subdirectories)))))
+ (if (null buffer-file-name)
+ (setq name (concat "TEMPLATE" template-extension))
+ (setq name (file-name-sans-versions
+ (file-name-nondirectory buffer-file-name)))
+ (if (string-match ".\\.[^.]*\\'" name)
+ (setq name (concat "TEMPLATE"
+ (substring name (1+ (match-beginning 0)))
+ template-extension))
+ (setq name (concat name template-extension)
+ ;; dot file => template not specific for directory
+ dir (car template-default-directories))))
+ (setq name (read-file-name "Open template file (empty=none): "
+ dir nil nil name))
+ (or (string= name "")
+ (template-find-template name)))))
+
+(defun template-insert-form (arg key)
+ "Insert an expansion form according to KEY into template.
+When called interactively, allow completion over all keys in
+`template-expansion-alist' and `template-default-expansion-alist'.
+If prefix ARG is nil, run `template-open-template' first."
+ (interactive
+ (list current-prefix-arg
+ (completing-read "Insert key (0-9 for register position): "
+ (append template-expansion-alist
+ template-default-expansion-alist))))
+ (or arg (template-open-template))
+ (insert (format template-expansion-format key))
+ (if (equal key (car template-literal-environment))
+ (let ((pos (point)))
+ (insert (format template-expansion-format
+ (cdr template-literal-environment)))
+ (goto-char pos))))
+
+(defun template-define-start (arg &rest args)
+ "Insert a definition section and definition into template.
+See `template-definition-start'. If ARGS is non-nil, pass ARGS to
+`format' for a new definition. If prefix ARG is nil, run
+`template-open-template' first."
+ (interactive "P")
+ (or arg (template-open-template))
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^[ \t]*"
+ template-definition-start
+ "[ \t]*$") nil t)
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ (insert template-definition-start))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ (if args (insert (apply 'format args) "\n")))
+ (message "Put definition at the end of the template"))
+
+(defun template-define-message (arg message)
+ "Insert a temporary message MESSAGE definition into template.
+For ARG, see `template-define-start'."
+ (interactive "P\nsTemporary message: ")
+ (template-define-start arg "%S" message))
+
+(defun template-define-prompt (arg key prompt &optional prefix suffix default)
+ "Insert a definition for KEY as PROMPT into template.
+For ARG, see `template-define-start'."
+ (interactive "P\nsExpansion key: \nsExpansion prompt: \nsPrefix for non-empty input: \nsSuffix for non-empty input: \nsDefault for empty input: ")
+ (template-define-start arg "(%S %S %S %S %S)"
+ key prompt prefix suffix default))
+
+(defun template-define-register (arg register)
+ "Insert a setting of REGISTER into template.
+For ARG, see `template-define-start'."
+ (interactive "P\ncDefine register: ")
+ (let* ((old (get-register register))
+ (contents (read-from-minibuffer "Register contents: "
+ (and (stringp old)
+ (not (string-match "\n" old))
+ old)))
+ (comment (read-from-minibuffer "Comment (empty=none): ")))
+ (if (string= comment "")
+ (template-define-start arg "(%S %S)" register contents)
+ (template-define-start arg "(%S %S %S)" register contents comment))))
+
+
+;;;===========================================================================
+;;; Initialization
+;;;===========================================================================
+
+;; easymenu.el is for top-level menus only...
+(defunx template-add-submenu (menu &optional where)
+ "Add the submenu MENU to the end of a menu in WHERE in the menubar.
+WHERE is a list of menus tried to add MENU to. If no such menu exist,
+no menu is added. When using Emacs, always add to the \"Edit\" menu.
+See `easy-menu-define' for the format of MENU."
+ (and menu
+ :EMACS
+ (>= emacs-major-version 21)
+ (boundp 'menu-bar-edit-menu)
+ (let ((keymap (easy-menu-create-menu (car menu) (cdr menu))))
+ ;; `easy-menu-get-map' doesn't get the right one => use hard-coded
+ (define-key-after menu-bar-edit-menu (vector (intern (car menu)))
+ (cons 'menu-item
+ (cons (car menu)
+ (if (not (symbolp keymap))
+ (list keymap)
+ (cons (symbol-function keymap)
+ (get keymap 'menu-prop)))))))
+ :XEMACS
+ (featurep 'menubar)
+ (let ((current-menubar default-menubar) path)
+ (while where
+ (setq path (list (pop where)))
+ (if (find-menu-item default-menubar path)
+ (setq where nil)
+ (setq path nil)))
+ (when path (add-submenu path menu)))))
+
+;;;###autoload
+(defunx template-initialize (&rest dummies)
+ ;; checkdoc-params: (dummies)
+ "Initialized package template. See variable `template-initialize'."
+ (interactive)
+ (setq template-use-package t)
+ (let ((regexp (concat (regexp-quote template-extension) "\\'")))
+ (or (assoc regexp auto-mode-alist)
+ (push (list regexp nil 'template-new-file) auto-mode-alist)))
+ (when (or (eq template-initialize t)
+ (memq 'cc-mode template-initialize))
+ (add-hook 'c-mode-common-hook 'template-c-init-fill-function)
+ (add-hook 'antlr-mode-hook 'template-c-init-fill-function))
+ (when (or (eq template-initialize t)
+ (memq 'de-html-helper template-initialize))
+ (setq html-helper-build-new-buffer nil)
+ (setq html-helper-do-write-file-hooks nil))
+ (when (or (eq template-initialize t)
+ (memq 'keys template-initialize))
+ (condition-case nil ; older Emacses don't understand all
+ (progn
+ (define-key ctl-x-map "t" 'template-new-file)
+ (define-key ctl-x-map [(control =)] 'template-single-comment)
+ (define-key ctl-x-map [(control ?\;)] 'template-block-comment))
+ (error nil)))
+ (when (or (eq template-initialize t)
+ (memq 'menus template-initialize))
+ (template-add-submenu template-comment-menu :XEMACS '("Edit"))
+ (template-add-submenu template-creation-menu :XEMACS '("Cmds" "Edit"))
+ :EMACS
+ (and (boundp 'menu-bar-files-menu)
+ (define-key-after menu-bar-files-menu [template-new-file]
+ '(menu-item "New File Using Template..." template-new-file
+ :enable (not (window-minibuffer-p
+ (frame-selected-window
+ menu-updating-frame)))
+ :help "Create a new file, using a template")
+ 'dired))
+ :XEMACS
+ (and (featurep 'menubar)
+ (find-menu-item default-menubar '("File"))
+ (let ((current-menubar default-menubar))
+ ;; XEmacs-20.4 `add-submenu' does not have 4th arg IN-MENU
+ (add-menu-button '("File")
+ ["New File Using Template..." template-new-file
+ :active t]
+ "Insert File..."))))
+ (if (and (boundp 'init-file-loaded) init-file-loaded)
+ ;; doesn't exist in Emacs
+ (template-after-init)
+ (add-hook 'after-init-hook 'template-after-init t)))
+
+(defun template-after-init ()
+ "Late initialization for package template.
+See function and variable `template-initialize'."
+ (when (or (eq template-initialize t)
+ (memq 'auto template-initialize))
+ (add-hook 'write-file-hooks 'template-update-buffer)
+ (add-hook 'find-file-not-found-hooks 'template-not-found-function t))
+ (when (or (eq template-initialize t)
+ (memq 'ffap template-initialize))
+ (or template-ffap-file-finder
+ (setq template-ffap-file-finder
+ (if (boundp 'ffap-file-finder)
+ ffap-file-finder
+ (or (get 'ffap-file-finder 'saved-value) 'find-file))))
+ (setq ffap-file-finder 'template-ffap-find-file)))
+
+;;; Local IspellPersDict: .ispell_template
+;;; template.el ends here
+++ /dev/null
-; malyon.el --- mode to execute z code files version 3, 5, 8
-
-;; Maintainer: Peter Ilberg <peter.ilbergNOSPAMgmail.com>
-;; (I am unable to continue supporting malyon.el. Please send me an
-;; email if you are interested in taking over the project. Thanks.)
-
-;; Copyright (C) 1999-2011 Peter Ilberg
-
-;; Permission is hereby granted, free of charge, to any person obtaining a
-;; copy of this software and associated documentation files (the "Software"),
-;; to deal in the Software without restriction, including without limitation
-;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
-;; and/or sell copies of the Software, and to permit persons to whom the
-;; Software is furnished to do so, subject to the following conditions:
-
-;; The above copyright notice and this permission notice shall be included in
-;; all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-;; DEALINGS IN THE SOFTWARE.
-
-;;; Credits:
-
-;; The author would like to thank the following people for reporting
-;; bugs, testing, suggesting and/or contributing improvements:
-;; Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko
-
-;;; Commentary:
-
-;; This package provides a basic interpreter for version 3, 5, 8 z code
-;; story files as generated by Inform (C) Graham Nelson and Infocom.
-
-;; If you encounter a bug please send a report to Peter Ilberg at
-;; peter.ilbergNOSPAMgmail.com. Thank you!
-
-;; To play a story file simple type M-x malyon and enter the path to the
-;; story file. If anything goes wrong and you want to manually clean
-;; up type M-x malyon-quit. In addition, you can switch back to a game in
-;; progress by typing M-x malyon-restore.
-
-;; A note on the format of saved game states:
-
-;; As of version 1.0, Malyon supports the quetzal file format for saved
-;; games. Support for this format required changes to several internal
-;; data structures (stack frames and catch-throw) that are incompatible
-;; with the old implementation. Unfortunately, the old file format for
-;; saved games cannot be converted into quetzal.
-
-;; For backwards compatibility, however, Malyon still supports the old
-;; file format. And you can continue to play your old game states.
-
-;; Because of the incompatibility of the two file formats, Malyon now
-;; runs, as follows, in either of two modes: quetzal and compatibility.
-
-;; - in quetzal mode, game states are saved in quetzal format
-;; - in compatibility mode, games states are saved in the old format
-;; - loading a game state in quetzal format switches to quetzal mode
-;; - loading an old game state switches to compatibility mode
-;; - quetzal mode is the default setting
-
-;; In other words, Malyon will only use the old file format if you've
-;; restored a game state saved in the old file format.
-
-;; Enjoy!
-
-;;; Code:
-
-;; global variables - moved here to appease the byte-code compiler
-
-;; story file information
-
-(defvar malyon-story-file-name nil
- "The name of the story file being executed.")
-
-(defvar malyon-story-file nil
- "The story file which is currently being run.")
-
-(defvar malyon-story-version nil
- "The story file version.")
-
-(defvar malyon-supported-versions '(3 5 8)
- "A list of supported story file versions.")
-
-;; status and transcript buffers
-
-(defvar malyon-transcript-buffer nil
- "The main transcript buffer of the story file execution.")
-
-(defvar malyon-transcript-buffer-buffered nil
- "Is output in the transcript buffer buffered?")
-
-(defvar malyon-status-buffer nil
- "The status bar buffer of the story file execution.")
-
-(defvar malyon-status-buffer-lines nil
- "The number of lines in the status bar buffer.")
-
-(defvar malyon-status-buffer-delayed-split nil
- "If the number of lines in the status buffer is reduced,
-the window configuration is not changed immediately. It
-is changed after the next turn (read or read_char).")
-
-(defvar malyon-status-buffer-point nil
- "The point location in the status bar buffer.")
-
-(defvar malyon-max-column 72
- "Maximum column for text display.")
-
-;; window management
-
-(defvar malyon-window-configuration nil
- "The current window configuration of the malyon interpreter.")
-
-(defvar malyon-current-window nil
- "The currently active window for text output.")
-
-;; z machine registers
-
-(defvar malyon-stack nil
- "The stack of the z machine.")
-
-(defvar malyon-stack-pointer nil
- "The stack pointer of the z machine.")
-
-(defvar malyon-frame-pointer nil
- "The frame pointer of the z machine.")
-
-(defvar malyon-instruction-pointer nil
- "The instruction pointer of the z machine.")
-
-;; game file related global variables
-
-(defvar malyon-score-game nil
- "A flag indicating whether this story uses score or time.")
-
-(defvar malyon-packed-multiplier nil
- "The amount by which packed addresses are multiplied to get byte
-addresses.")
-
-(defvar malyon-global-variables nil
- "A pointer to the global variable section in the story file.")
-
-(defvar malyon-abbreviations nil
- "A pointer to the abbreviations in the story file.")
-
-(defvar malyon-alphabet nil
- "The z machine's text alphabet.")
-
-(defvar malyon-whitespace nil
- "A string of whitespace characters recognized by the interpreter.")
-
-;; object tables
-
-(defvar malyon-object-table nil
- "A pointer to the object table in the story file.")
-
-(defvar malyon-object-table-entry-size nil
- "The size of one entry in the object table.")
-
-(defvar malyon-object-properties nil
- "The number of properties per object minus one.")
-
-(defvar malyon-object-property-offset nil
- "The byte offset of the properties table in the object.")
-
-;; dictionaries
-
-(defvar malyon-dictionary nil
- "A pointer to the dictionary of the story file.")
-
-(defvar malyon-dictionary-entry-length nil
- "The length of a dictionary entry.")
-
-(defvar malyon-dictionary-num-entries nil
- "The number of dictionary entries.")
-
-(defvar malyon-dictionary-entries nil
- "A pointer to the first dictionary entry.")
-
-(defvar malyon-dictionary-word-length nil
- "The length of a dictionary word.")
-
-;; game state information
-
-(defvar malyon-game-state-restart nil
- "The machine state for implementing restart.")
-
-(defvar malyon-game-state-undo nil
- "The machine state for implementing undo.")
-
-(defvar malyon-game-state-quetzal t
- "Store game state information for quetzal.")
-
-;; various
-
-(defvar malyon-current-face nil
- "The current face in which to display text.")
-
-(defvar malyon-last-cursor-position-after-input nil
- "The last cursor position after reading input from the keyboard.")
-
-;; interactive functions
-
-(defun malyon (file-name)
- "Major mode for playing z3/5/8 story files.
-This mode allows execution of version 3, 5, 8 z code story files."
- (interactive "fStory file name: ")
- (if malyon-story-file
- (message "You are already playing a game.")
- (if (not (string-match ".*\.z[358]$" file-name))
- (message "%s is not a version 3, 5, or 8 story file." file-name)
- (condition-case nil
- (malyon-load-story-file file-name)
- (error
- (malyon-fatal-error "loading of story file failed.")))
- (setq malyon-story-version (aref malyon-story-file 0))
- (cond ((memq malyon-story-version malyon-supported-versions)
- (condition-case nil
- (malyon-initialize)
- (error
- (malyon-fatal-error "initialization of interpreter failed.")))
- (malyon-interpreter))
- (t
- (message "%s is not a version 3, 5, or 8 story file." file-name)
- (malyon-cleanup))))))
-
-(defun malyon-restore ()
- "Restore the save window configuration for the interpreter."
- (interactive)
- (condition-case nil
- (progn
- (malyon-restore-window-configuration)
- (malyon-adjust-transcript))
- (error
- (malyon-fatal-error "restoring window configuration failed."))))
-
-(defun malyon-quit ()
- "Exit the malyon interpreter."
- (interactive)
- (if malyon-story-file
- (progn
- (malyon-restore)
- (if (malyon-yes-or-no-p-minibuf "Do you really want to quit? ")
- (malyon-cleanup)))))
-
-(defun malyon-mode ()
- "This mode provides a basic interpreter for version 3, 5, 8 z code
-story files as generated by Inform (C) Graham Nelson and Infocom.
-
-Note that this package is by no means complete and bug free.
-If you encounter a bug please send a report to Peter Ilberg at
-peter.ilbergNOSPAMnatinst.com. Thank you!
-
-To play a story file simple type M-x malyon and enter the path to the
-story file. If anything goes wrong and you want to manually clean
-up type M-x malyon-quit. In addition, you can switch back to a game in
-progress by typing M-x malyon-restore.
-
-The author would like to thank the following people for reporting
-bugs, testing, suggesting and/or contributing improvements:
- Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko"
- (message "Use M-x malyon if you want to play a zcode game."))
-
-;; compatibility functions for GNU emacs
-
-(if (fboundp 'cadr)
- (defalias 'malyon-cadr 'cadr)
- (defun malyon-cadr (list)
- "Take the cadr of the list."
- (car (cdr list))))
-
-(if (fboundp 'caddr)
- (defalias 'malyon-caddr 'caddr)
- (defun malyon-caddr (list)
- "Take the caddr of the list."
- (car (cdr (cdr list)))))
-
-(if (fboundp 'cdddr)
- (defalias 'malyon-cdddr 'cdddr)
- (defun malyon-cdddr (list)
- "Take the cdddr of the list."
- (cdr (cdr (cdr list)))))
-
-(if (fboundp 'char-before)
- (defalias 'malyon-char-before 'char-before)
- (defun malyon-char-before ()
- "Return the character before the point."
- (char-after (- (point) 1))))
-
-(if (fboundp 'char-to-int)
- (defalias 'malyon-char-to-int 'char-to-int)
- (defun malyon-char-to-int (c)
- "Convert a character into an integer."
- c))
-
-(if (fboundp 'characterp)
- (defalias 'malyon-characterp 'characterp)
- (defun malyon-characterp (x)
- "Test for a character."
- (and (numberp x) (<= 0 x) (< x 256))))
-
-(defun malyon-disable-multibyte ()
- "Disable multibyte support in the current buffer."
- (condition-case nil (set-buffer-multibyte nil) (error)))
-
-(defun malyon-erase-buffer (&optional buffer)
- "Erase the given buffer."
- (save-excursion
- (if buffer (set-buffer buffer))
- (if (and buffer (eq buffer malyon-transcript-buffer))
- (malyon-begin-section)
- (erase-buffer))))
-
-(if (fboundp 'int-to-char)
- (defalias 'malyon-int-to-char 'int-to-char)
- (defun malyon-int-to-char (i)
- "Convert an integer into a character."
- i))
-
-(if (fboundp 'mapc)
- (defalias 'malyon-mapc 'mapc)
- (defun malyon-mapc (function list)
- "Apply fun to every element of args ignoring the results."
- (if (null list)
- '()
- (funcall function (car list))
- (malyon-mapc function (cdr list)))))
-
-(if (fboundp 'mapcan)
- (defalias 'malyon-mapcan 'mapcan)
- (defun malyon-mapcan (function list)
- "Apply fun to every element of args nconc'ing the result."
- (if (null list)
- '()
- (nconc (funcall function (car list))
- (malyon-mapcan function (cdr list))))))
-
-; Do not use the built-in conversion via 'multibyte-char-to-unibyte.
-(defun malyon-multibyte-char-to-unibyte (char)
- "Convert a multibyte character to unibyte."
- char)
-
-(defun malyon-point-max (&optional buffer)
- "Get the point-max of the given buffer."
- (save-excursion
- (if buffer (set-buffer buffer))
- (point-max)))
-
-(if (fboundp 'redisplay-frame)
- (defalias 'malyon-redisplay-frame 'redisplay-frame)
- (defun malyon-redisplay-frame (frame &rest ignore)
- "Redisplay the given frame."))
-
-(if (fboundp 'remove)
- (defalias 'malyon-remove 'remove)
- (defun malyon-remove (element list)
- "Remove the element from the list."
- (cond ((null list)
- '())
- ((eq element (car list))
- (malyon-remove element (cdr list)))
- ((equal element (car list))
- (malyon-remove element (cdr list)))
- (t
- (cons (car list)
- (malyon-remove element (cdr list)))))))
-
-(if (fboundp 'set-keymap-name)
- (defalias 'malyon-set-keymap-name 'set-keymap-name)
- (defun malyon-set-keymap-name (keymap name)
- "Set the name of the keymap."))
-
-(if (fboundp 'string-to-list)
- (defalias 'malyon-string-to-list 'string-to-list)
- (defun malyon-string-to-list (s)
- "Convert a string into a list of characters."
- (let ((i (- (length s) 1)) (l '()))
- (while (<= 0 i)
- (setq l (cons (aref s i) l)
- i (- i 1)))
- l)))
-
-(if (fboundp 'string-to-vector)
- (defalias 'malyon-string-to-vector 'string-to-vector)
- (defun malyon-string-to-vector (s)
- "Convert a string into a vector of characters."
- (let* ((i 0) (l (length s)) (v (make-vector l 0)))
- (while (< i l)
- (aset v i (aref s i))
- (setq i (+ 1 i)))
- v)))
-
-; Do not use the built-in conversion via 'unibyte-char-to-multibyte.
-(defun malyon-unibyte-char-to-multibyte (char)
- "Convert a unibyte character to multibyte."
- char)
-
-(defun malyon-vector-to-list (v begin end)
- "Return a list of elements in v in the range [begin, end)."
- (let ((result '()))
- (while (< begin end)
- (setq result (cons (aref v begin) result))
- (setq begin (+ 1 begin)))
- (reverse result)))
-
-(if (fboundp 'window-displayed-height)
- (defalias 'malyon-window-displayed-height 'window-displayed-height)
- (defun malyon-window-displayed-height (&optional window)
- "Get the height of the window's displayed region."
- (- (window-height) 1)))
-
-(if (fboundp 'yes-or-no-p-minibuf)
- (defalias 'malyon-yes-or-no-p-minibuf 'yes-or-no-p-minibuf)
- (defun malyon-yes-or-no-p-minibuf (prompt)
- "Ask a yes or no question."
- (yes-or-no-p prompt)))
-
-;; global variables for the malyon mode
-
-(defvar malyon-syntax-table nil
- "Syntax table used while in malyon mode (same as in text-mode).")
-
-(if malyon-syntax-table
- '()
- (setq malyon-syntax-table (make-syntax-table))
- (modify-syntax-entry ?\" ". " malyon-syntax-table)
- (modify-syntax-entry ?\\ ". " malyon-syntax-table)
- (modify-syntax-entry ?' "w " malyon-syntax-table))
-
-(defvar malyon-keymap-read nil
- "Keymap for malyon mode for reading input into a buffer.")
-
-(defvar malyon-history-saved-up nil
- "The saved binding for the up arrow key.")
-
-(defvar malyon-history-saved-down nil
- "The saved binding for the down arrow key.")
-
-(if malyon-keymap-read
- '()
- (setq malyon-keymap-read (make-sparse-keymap))
- (malyon-set-keymap-name malyon-keymap-read 'malyon-keymap-read)
- (setq malyon-history-saved-up (global-key-binding [up]))
- (setq malyon-history-saved-down (global-key-binding [down]))
- (define-key malyon-keymap-read "\r" 'malyon-end-input)
- (define-key malyon-keymap-read [up] 'malyon-history-previous-char)
- (define-key malyon-keymap-read [down] 'malyon-history-next-char)
- (define-key malyon-keymap-read "\M-p" 'malyon-history-previous-char)
- (define-key malyon-keymap-read "\M-n" 'malyon-history-next-char)
- (define-key malyon-keymap-read "\C-a" 'malyon-beginning-of-line)
- (define-key malyon-keymap-read "\C-w" 'malyon-kill-region)
- (define-key malyon-keymap-read "\C-k" 'malyon-kill-line)
- (define-key malyon-keymap-read "\M-d" 'malyon-kill-word)
- (define-key malyon-keymap-read "\C-y" 'malyon-yank)
- (define-key malyon-keymap-read "\M-y" 'malyon-yank-pop)
- (define-key malyon-keymap-read "\C-d" 'malyon-delete-char)
- (define-key malyon-keymap-read "\d" 'malyon-backward-delete-char)
- (define-key malyon-keymap-read [del] 'malyon-delete-char)
- (define-key malyon-keymap-read [backspace] 'malyon-backward-delete-char)
- (substitute-key-definition (lookup-key (current-global-map) "a")
- 'malyon-self-insert-command
- malyon-keymap-read (current-global-map)))
-
-(defvar malyon-keymap-readchar nil
- "Keymap for malyon mode for waiting for input.")
-
-(if malyon-keymap-readchar
- '()
- (setq malyon-keymap-readchar (make-sparse-keymap))
- (malyon-set-keymap-name malyon-keymap-readchar 'malyon-keymap-readchar)
- (define-key malyon-keymap-readchar "\r" 'malyon-wait-char)
- (substitute-key-definition (lookup-key (current-global-map) "a")
- 'malyon-wait-char
- malyon-keymap-readchar (current-global-map)))
-
-(defvar malyon-keymap-more nil
- "Keymap for malyon mode for browsing through text.")
-
-(if malyon-keymap-more
- '()
- (setq malyon-keymap-more (make-sparse-keymap))
- (malyon-set-keymap-name malyon-keymap-more 'malyon-keymap-more)
- (define-key malyon-keymap-more "\r" 'malyon-more-char)
- (substitute-key-definition (lookup-key (current-global-map) "a")
- 'malyon-more-char
- malyon-keymap-more (current-global-map)))
-
-(defvar malyon-keymap-more-status nil
- "Keymap for malyon mode for browsing through the status buffer.")
-
-(if malyon-keymap-more-status
- '()
- (setq malyon-keymap-more-status (make-sparse-keymap))
- (malyon-set-keymap-name malyon-keymap-more-status 'malyon-keymap-more-status)
- (define-key malyon-keymap-more-status "\r" 'malyon-more-char-status)
- (substitute-key-definition (lookup-key (current-global-map) "a")
- 'malyon-more-char-status
- malyon-keymap-more-status (current-global-map)))
-
-(defvar malyon-faces nil
- "An association list of text faces used by the malyon mode.")
-
-(defun malyon-initialize-faces ()
- (copy-face 'default 'malyon-face-plain)
- (copy-face 'bold 'malyon-face-reverse)
- (copy-face 'bold 'malyon-face-bold)
- (copy-face 'italic 'malyon-face-italic)
- (copy-face 'default 'malyon-face-error)
- (set-face-foreground 'malyon-face-error "red")
- (setq malyon-faces '((0 . malyon-face-plain)
- (1 . malyon-face-reverse)
- (2 . malyon-face-bold)
- (4 . malyon-face-italic)
- (8 . malyon-face-plain))))
-
-(defvar malyon-print-separator nil
- "A flag indicating whether to print the * * * separator.")
-
-(defun malyon-begin-section ()
- "Print a section divider and begin a new section."
- (if malyon-print-separator
- (progn
- (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n ?* ? ?* ? ?*))
- (center-line)
- (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n))
- (setq malyon-print-separator nil)))
- (narrow-to-region (point-max) (point-max)))
-
-(if malyon-whitespace
- '()
- (setq malyon-whitespace (list (malyon-char-to-int ? )
- (malyon-char-to-int ?\t)
- (malyon-char-to-int ?\n)
- (malyon-char-to-int ?\r))))
-
-;; memory utilities
-
-(defsubst malyon-read-byte (address)
- "Read a byte at address in the story file."
- (if (<= 0 address)
- (aref malyon-story-file address)
- (aref malyon-story-file (+ 65536 address))))
-
-(defsubst malyon-store-byte (address value)
- "Store a byte at address in the story file."
- (if (<= 0 address)
- (aset malyon-story-file address (logand 255 value))
- (aset malyon-story-file (+ 65536 address) (logand 255 value))))
-
-(defsubst malyon-read-word (address)
- "Read a word at address in the story file."
- (if (<= 0 address)
- (logior (lsh (aref malyon-story-file address) 8)
- (aref malyon-story-file (+ 1 address)))
- (logior (lsh (aref malyon-story-file (+ 65536 address)) 8)
- (aref malyon-story-file (+ 65537 address)))))
-
-(defsubst malyon-store-word (address value)
- "Store a word at address in the story file."
- (if (<= 0 address)
- (progn
- (aset malyon-story-file address (logand 255 (lsh value -8)))
- (aset malyon-story-file (+ 1 address) (logand 255 value)))
- (aset malyon-story-file (+ 65536 address) (logand 255 (lsh value -8)))
- (aset malyon-story-file (+ 65537 address) (logand 255 value))))
-
-(defsubst malyon-read-code-byte ()
- "Read the next byte at the program counter location."
- (setq malyon-instruction-pointer (+ malyon-instruction-pointer 1))
- (malyon-read-byte (- malyon-instruction-pointer 1)))
-
-(defsubst malyon-read-code-word ()
- "Read the next word at the program counter location."
- (setq malyon-instruction-pointer (+ malyon-instruction-pointer 2))
- (malyon-read-word (- malyon-instruction-pointer 2)))
-
-(defsubst malyon-pop-stack ()
- "Pop a value off the stack."
- (if (> 0 malyon-stack-pointer)
- (malyon-fatal-error "stack underflow."))
- (setq malyon-stack-pointer (- malyon-stack-pointer 1))
- (aref malyon-stack (+ malyon-stack-pointer 1)))
-
-(defsubst malyon-read-local-variable (variable)
- "Read a local variable."
- (aref malyon-stack (+ variable malyon-frame-pointer)))
-
-(defsubst malyon-read-global-variable (variable)
- "Read a global variable."
- (malyon-read-word (+ malyon-global-variables (* 2 variable))))
-
-(defsubst malyon-read-variable (variable)
- "Read a variable."
- (cond ((= variable 0) (malyon-pop-stack))
- ((< variable 16) (malyon-read-local-variable variable))
- (t (malyon-read-global-variable (- variable 16)))))
-
-(defsubst malyon-push-stack (value)
- "Push a value onto the stack."
- (setq malyon-stack-pointer (+ malyon-stack-pointer 1))
- (aset malyon-stack malyon-stack-pointer value))
-
-(defsubst malyon-store-local-variable (variable value)
- "Store a value in a local variable."
- (aset malyon-stack (+ variable malyon-frame-pointer) value))
-
-(defsubst malyon-store-global-variable (variable value)
- "Store a value in a global variable."
- (malyon-store-word (+ malyon-global-variables (* 2 variable)) value))
-
-(defsubst malyon-store-variable (var value)
- "Store the value in a variable."
- (setq value (logand 65535 value))
- (cond ((= var 0) (malyon-push-stack value))
- ((< var 16) (malyon-store-local-variable var value))
- (t (malyon-store-global-variable (- var 16) value))))
-
-;; list of opcodes
-
-(defvar malyon-opcodes
- [malyon-opcode-nop
- malyon-opcode-je malyon-opcode-jl
- malyon-opcode-jg malyon-opcode-dec-chk
- malyon-opcode-inc-chk malyon-opcode-jin
- malyon-opcode-test malyon-opcode-or
- malyon-opcode-and malyon-opcode-test-attr
- malyon-opcode-set-attr malyon-opcode-clear-attr
- malyon-opcode-store malyon-opcode-insert-obj
- malyon-opcode-loadw malyon-opcode-loadb
- malyon-opcode-get-prop malyon-opcode-get-prop-addr
- malyon-opcode-get-next-prop malyon-opcode-add
- malyon-opcode-sub malyon-opcode-mul
- malyon-opcode-div malyon-opcode-mod
- malyon-opcode-calls malyon-opcode-calln
- malyon-opcode-set-color malyon-opcode-throw
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-je malyon-opcode-jl
- malyon-opcode-jg malyon-opcode-dec-chk
- malyon-opcode-inc-chk malyon-opcode-jin
- malyon-opcode-test malyon-opcode-or
- malyon-opcode-and malyon-opcode-test-attr
- malyon-opcode-set-attr malyon-opcode-clear-attr
- malyon-opcode-store malyon-opcode-insert-obj
- malyon-opcode-loadw malyon-opcode-loadb
- malyon-opcode-get-prop malyon-opcode-get-prop-addr
- malyon-opcode-get-next-prop malyon-opcode-add
- malyon-opcode-sub malyon-opcode-mul
- malyon-opcode-div malyon-opcode-mod
- malyon-opcode-calls malyon-opcode-calln
- malyon-opcode-set-color malyon-opcode-throw
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-je malyon-opcode-jl
- malyon-opcode-jg malyon-opcode-dec-chk
- malyon-opcode-inc-chk malyon-opcode-jin
- malyon-opcode-test malyon-opcode-or
- malyon-opcode-and malyon-opcode-test-attr
- malyon-opcode-set-attr malyon-opcode-clear-attr
- malyon-opcode-store malyon-opcode-insert-obj
- malyon-opcode-loadw malyon-opcode-loadb
- malyon-opcode-get-prop malyon-opcode-get-prop-addr
- malyon-opcode-get-next-prop malyon-opcode-add
- malyon-opcode-sub malyon-opcode-mul
- malyon-opcode-div malyon-opcode-mod
- malyon-opcode-calls malyon-opcode-calln
- malyon-opcode-set-color malyon-opcode-throw
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-je malyon-opcode-jl
- malyon-opcode-jg malyon-opcode-dec-chk
- malyon-opcode-inc-chk malyon-opcode-jin
- malyon-opcode-test malyon-opcode-or
- malyon-opcode-and malyon-opcode-test-attr
- malyon-opcode-set-attr malyon-opcode-clear-attr
- malyon-opcode-store malyon-opcode-insert-obj
- malyon-opcode-loadw malyon-opcode-loadb
- malyon-opcode-get-prop malyon-opcode-get-prop-addr
- malyon-opcode-get-next-prop malyon-opcode-add
- malyon-opcode-sub malyon-opcode-mul
- malyon-opcode-div malyon-opcode-mod
- malyon-opcode-calls malyon-opcode-calln
- malyon-opcode-set-color malyon-opcode-throw
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop malyon-opcode-jz
- malyon-opcode-get-sibling malyon-opcode-get-child
- malyon-opcode-get-parent malyon-opcode-get-prop-len
- malyon-opcode-inc malyon-opcode-dec
- malyon-opcode-print-addr malyon-opcode-calls
- malyon-opcode-remove-obj malyon-opcode-print-obj
- malyon-opcode-ret malyon-opcode-jump
- malyon-opcode-print-paddr malyon-opcode-load
- malyon-opcode-calln malyon-opcode-jz
- malyon-opcode-get-sibling malyon-opcode-get-child
- malyon-opcode-get-parent malyon-opcode-get-prop-len
- malyon-opcode-inc malyon-opcode-dec
- malyon-opcode-print-addr malyon-opcode-calls
- malyon-opcode-remove-obj malyon-opcode-print-obj
- malyon-opcode-ret malyon-opcode-jump
- malyon-opcode-print-paddr malyon-opcode-load
- malyon-opcode-calln malyon-opcode-jz
- malyon-opcode-get-sibling malyon-opcode-get-child
- malyon-opcode-get-parent malyon-opcode-get-prop-len
- malyon-opcode-inc malyon-opcode-dec
- malyon-opcode-print-addr malyon-opcode-calls
- malyon-opcode-remove-obj malyon-opcode-print-obj
- malyon-opcode-ret malyon-opcode-jump
- malyon-opcode-print-paddr malyon-opcode-load
- malyon-opcode-calln malyon-opcode-rtrue
- malyon-opcode-rfalse malyon-opcode-print
- malyon-opcode-print-ret malyon-opcode-nop
- malyon-opcode-illegal malyon-opcode-illegal
- malyon-opcode-restart malyon-opcode-ret-popped
- malyon-opcode-catch malyon-opcode-quit
- malyon-opcode-new-line malyon-opcode-illegal
- malyon-opcode-verify malyon-opcode-illegal
- malyon-opcode-piracy malyon-opcode-nop
- malyon-opcode-je malyon-opcode-jl
- malyon-opcode-jg malyon-opcode-dec-chk
- malyon-opcode-inc-chk malyon-opcode-jin
- malyon-opcode-test malyon-opcode-or
- malyon-opcode-and malyon-opcode-test-attr
- malyon-opcode-set-attr malyon-opcode-clear-attr
- malyon-opcode-store malyon-opcode-insert-obj
- malyon-opcode-loadw malyon-opcode-loadb
- malyon-opcode-get-prop malyon-opcode-get-prop-addr
- malyon-opcode-get-next-prop malyon-opcode-add
- malyon-opcode-sub malyon-opcode-mul
- malyon-opcode-div malyon-opcode-mod
- malyon-opcode-calls malyon-opcode-calln
- malyon-opcode-set-color malyon-opcode-throw
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop malyon-opcode-calls
- malyon-opcode-storew malyon-opcode-storeb
- malyon-opcode-put-prop malyon-opcode-aread
- malyon-opcode-print-char malyon-opcode-print-num
- malyon-opcode-random malyon-opcode-push
- malyon-opcode-pull malyon-opcode-split-window
- malyon-opcode-set-window malyon-opcode-calls
- malyon-opcode-erase-window malyon-opcode-erase-line
- malyon-opcode-set-cursor malyon-opcode-get-cursor
- malyon-opcode-set-text-style malyon-opcode-buffer-mode
- malyon-opcode-output-stream malyon-opcode-input-stream
- malyon-opcode-nop malyon-opcode-read-char
- malyon-opcode-scan-table malyon-opcode-not
- malyon-opcode-calln malyon-opcode-calln
- malyon-opcode-tokenise malyon-opcode-encode-text
- malyon-opcode-copy-table malyon-opcode-print-table
- malyon-opcode-check-arg-count malyon-opcode-save
- malyon-opcode-restore malyon-opcode-log-shift
- malyon-opcode-art-shift malyon-opcode-set-font
- malyon-opcode-illegal malyon-opcode-illegal
- malyon-opcode-illegal malyon-opcode-illegal
- malyon-opcode-save-undo malyon-opcode-restore-undo
- malyon-opcode-print-unicode malyon-opcode-check-unicode
- malyon-opcode-nop malyon-opcode-nop
- malyon-opcode-nop]
- "A vector of all known legal z code opcodes.")
-
-;; initialization
-
-(defun malyon-load-story-file (file-name)
- "Load a z code story file into an internal vector."
- (save-excursion
- (set-buffer (create-file-buffer file-name))
- (malyon-disable-multibyte)
- (malyon-erase-buffer)
- (let ((coding-system-for-read 'binary))
- (insert-file-contents file-name))
- (setq malyon-story-file-name file-name)
- (setq malyon-story-file (buffer-substring-no-properties (point-min)
- (point-max)))
- (setq malyon-story-file (malyon-string-to-vector malyon-story-file))
- (if (not (eq ?\^A 1))
- (let ((i 0))
- (while (< i (length malyon-story-file))
- (aset malyon-story-file
- i
- (malyon-char-to-int (aref malyon-story-file i)))
- (setq i (+ 1 i)))))
- (kill-buffer nil)))
-
-(defun malyon-initialize ()
- "Initialize the z code interpreter."
-; (malyon-trace-file)
- (setq malyon-game-state-quetzal t)
- (malyon-initialize-faces)
- (malyon-initialize-status)
- (malyon-initialize-transcript)
- (malyon-initialize-windows)
- (malyon-initialize-story-header)
- (malyon-initialize-registers)
- (malyon-initialize-opcodes)
- (malyon-history-clear)
- (setq malyon-game-state-restart (malyon-current-game-state))
- (malyon-print-header))
-
-(defun malyon-initialize-status ()
- "Initialize the status buffer."
- (setq malyon-status-buffer (get-buffer-create "Malyon Status"))
- (switch-to-buffer malyon-status-buffer)
- (malyon-erase-buffer)
- (kill-all-local-variables)
- (setq malyon-status-buffer-point (point))
- (setq malyon-status-buffer-lines 0)
- (setq malyon-status-buffer-delayed-split nil)
- (use-local-map malyon-keymap-read)
- (set-syntax-table malyon-syntax-table)
- (setq mode-name "Malyon")
- (setq major-mode 'malyon-mode)
- (run-hooks 'malyon-mode-hook))
-
-(defun malyon-initialize-transcript ()
- "Initialize the transcript buffer."
- (setq malyon-transcript-buffer (get-buffer-create "Malyon Transcript"))
- (switch-to-buffer malyon-transcript-buffer)
- (malyon-erase-buffer)
- (kill-all-local-variables)
- (setq malyon-last-cursor-position-after-input
- (malyon-point-max malyon-transcript-buffer))
- (use-local-map malyon-keymap-read)
- (set-syntax-table malyon-syntax-table)
- (setq fill-column malyon-max-column)
- (auto-fill-mode 1)
- (setq mode-name "Malyon")
- (setq major-mode 'malyon-mode)
- (run-hooks 'malyon-mode-hook))
-
-(defun malyon-initialize-windows ()
- "Initialize the window configuration for the z machine."
- (setq window-min-height 3)
- (setq malyon-transcript-buffer-buffered t)
- (malyon-set-window-configuration 0)
- (malyon-opcode-set-window 0))
-
-(defun malyon-initialize-story-header ()
- "Initializes the header section of the story file."
- (malyon-store-byte 1
- (if (>= malyon-story-version 5)
- 28
- (logior 48 (malyon-read-byte 1))))
- (malyon-store-byte 16 (logand 440 (malyon-read-byte 16)))
- (malyon-store-byte 30 1)
- (malyon-store-byte 31 65)
- (malyon-store-byte 32 255)
- (malyon-store-byte 33 (- malyon-max-column 1))
- (malyon-store-word 34 (- malyon-max-column 1))
- (malyon-store-word 36 255)
- (malyon-store-word 38 1)
- (malyon-store-word 39 1)
- (malyon-store-byte 44 0)
- (malyon-store-byte 45 0)
- (malyon-store-byte 50 1)
- (malyon-store-byte 51 0))
-
-(defun malyon-initialize-registers ()
- "Initialize the interpreter's internal registers."
- (setq malyon-stack (make-vector 1024 0))
- (setq malyon-stack-pointer -1)
- (malyon-push-initial-frame)
- (setq malyon-frame-pointer malyon-stack-pointer)
- (setq malyon-instruction-pointer (malyon-read-word 6))
- (setq malyon-global-variables (malyon-read-word 12))
- (setq malyon-object-table (malyon-read-word 10))
- (cond ((< malyon-story-version 5)
- (setq malyon-object-table-entry-size 9)
- (setq malyon-object-properties 31)
- (setq malyon-object-property-offset 7))
- (t
- (setq malyon-object-table-entry-size 14)
- (setq malyon-object-properties 63)
- (setq malyon-object-property-offset 12)))
- (setq malyon-abbreviations (malyon-read-word 24))
- (if (< malyon-story-version 5)
- (setq malyon-score-game (zerop (logand 2 (malyon-read-byte 1)))))
- (setq malyon-packed-multiplier
- (malyon-cadr (assq malyon-story-version '((3 2) (5 4) (8 8)))))
- (if (or (< malyon-story-version 5) (zerop (malyon-read-word 52)))
- (setq malyon-alphabet (concat "abcdefghijklmnopqrstuvwxyz"
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- " \n0123456789.,!?_#'\"/\\-:()"))
- (setq malyon-alphabet (make-string 78 ? ))
- (let ((i 0))
- (while (< i 78)
- (aset malyon-alphabet i
- (malyon-read-byte (+ i (malyon-read-word 52))))
- (setq i (+ 1 i)))))
- (malyon-initialize-unicode-table)
- (setq malyon-dictionary (malyon-read-word 8))
- (setq malyon-dictionary-entry-length
- (malyon-read-byte
- (+ 1 malyon-dictionary (malyon-read-byte malyon-dictionary))))
- (setq malyon-dictionary-num-entries
- (malyon-read-word
- (+ 2 malyon-dictionary (malyon-read-byte malyon-dictionary))))
- (setq malyon-dictionary-entries
- (+ 4 malyon-dictionary (malyon-read-byte malyon-dictionary)))
- (setq malyon-dictionary-word-length (if (< malyon-story-version 5) 3 5))
- (setq malyon-current-face 'malyon-face-plain)
- (setq malyon-print-separator nil)
- (malyon-initialize-output-streams))
-
-(defun malyon-initialize-opcodes ()
- "Initialize the opcode table used by the story file."
- (cond ((< malyon-story-version 5)
- (aset malyon-opcodes 143 'malyon-opcode-not)
- (aset malyon-opcodes 181 'malyon-opcode-save)
- (aset malyon-opcodes 182 'malyon-opcode-restore)
- (aset malyon-opcodes 185 'malyon-opcode-pop)
- (aset malyon-opcodes 188 'malyon-opcode-show-status))
- (t
- (aset malyon-opcodes 143 'malyon-opcode-calln)
- (aset malyon-opcodes 181 'malyon-opcode-illegal)
- (aset malyon-opcodes 182 'malyon-opcode-illegal)
- (aset malyon-opcodes 185 'malyon-opcode-catch)
- (aset malyon-opcodes 188 'malyon-opcode-illegal))))
-
-(defun malyon-print-header ()
- "Print malyon mode header information."
- (malyon-opcode-set-text-style 2)
- (malyon-print "Malyon V 1.0.3")
- (malyon-opcode-set-text-style 0)
- (malyon-newline)
- (malyon-print "A z-code interpreter for version 3, 5, and 8 games.")
- (malyon-newline)
- (malyon-print "(c) 1999-2011 by Peter Ilberg <peter.ilbergNOSPAMgmail.com>")
- (malyon-newline)
- (malyon-newline))
-
-;; cleanup
-
-(defun malyon-cleanup ()
- "Clean up the z code interpreter."
- (condition-case nil
- (progn
- (setq malyon-story-file nil)
- (setq malyon-window-configuration nil)
- (setq malyon-game-state-restart nil)
- (setq malyon-game-state-undo nil)
- (if (get-buffer "Malyon Status")
- (kill-buffer (get-buffer "Malyon Status")))
- (if (get-buffer "Malyon Transcript")
- (progn
- (switch-to-buffer (get-buffer "Malyon Transcript"))
- (malyon-redisplay-frame (selected-frame) t)
- (delete-other-windows (get-buffer-window (current-buffer)))
- (widen)
- (text-mode)))
- (setq malyon-status-buffer nil)
- (setq malyon-transcript-buffer nil))
- (error
- (malyon-fatal-error "cleanup failed."))))
-
-;; error handling
-
-(defun malyon-fatal-error (message)
- "Print error message and abort."
- (setq message (concat "Malyon fatal error: " message))
- (unwind-protect
- (save-excursion
- (set-buffer malyon-transcript-buffer)
- (goto-char (point-max))
- (newline)
- (newline)
- (put-text-property 0
- (length message)
- 'face
- 'malyon-face-error
- message)
- (insert message)
- (newline))
- (malyon-cleanup)
- (malyon-redisplay-frame (selected-frame) t)
- (error message)))
-
-;; conversion of zscii to ascii
-
-(defvar malyon-unicode-table nil
- "An array mapping zscii characters to latin-1 ones.")
-
-(defvar malyon-default-unicode-table nil
- "The default array mapping zscii characters to latin-1 ones.")
-
-(if malyon-default-unicode-table
- '()
- (setq malyon-default-unicode-table
- [32
- 0 0 0 0 0 0 0 ; 1 - 7
- 8 0 0 0 0 10 0 0 ; 8 - 15
- 0 0 0 0 0 0 0 0 ; 16 - 23
- 0 0 0 39 0 0 0 0 ; 24 - 31
- 32 33 34 35 36 37 38 39 ; 32 - 39
- 40 41 42 43 44 45 46 47 ; 40 - 47
- 48 49 50 51 52 53 54 55 ; 48 - 55
- 56 57 58 59 60 61 62 63 ; 56 - 63
- 64 65 66 67 68 69 70 71 ; 64 - 71
- 72 73 74 75 76 77 78 79 ; 72 - 79
- 80 81 82 83 84 85 86 87 ; 80 - 87
- 88 89 90 91 92 93 94 95 ; 88 - 95
- 96 97 98 99 100 101 102 103 ; 96 - 103
- 104 105 106 107 108 109 110 111 ; 104 - 111
- 112 113 114 115 116 117 118 119 ; 112 - 119
- 120 121 122 123 124 125 126 0 ; 120 - 127
- 0 0 0 0 0 0 0 0 ; 128 - 135
- 0 0 0 0 0 0 0 0 ; 136 - 143
- 0 48 49 50 51 52 53 54 ; 144 - 151
- 55 56 57 228 246 252 196 214 ; 152 - 159
- 220 223 187 171 235 239 255 203 ; 160 - 167
- 207 225 233 237 243 250 253 193 ; 168 - 175
- 201 205 211 218 221 224 232 236 ; 176 - 183
- 242 249 192 200 204 210 217 226 ; 184 - 191
- 234 238 244 251 194 202 206 212 ; 192 - 199
- 219 229 197 248 216 227 241 245 ; 200 - 207
- 195 209 213 230 198 231 199 254 ; 208 - 215
- 240 222 208 163 63 63 161 191 ; 216 - 223
- 0 0 0 0 0 0 0 0 ; 224 - 231
- 0 0 0 0 0 0 0 0 ; 232 - 239
- 0 0 0 0 0 0 0 0 ; 240 - 247
- 0 0 0 0 0 0 0 0 ; 248 - 255
- ]))
-
-(defun malyon-initialize-unicode-table ()
- "Initializes the zscii-to-unicode conversion table."
- (setq malyon-unicode-table
- (copy-sequence malyon-default-unicode-table))
- (let* ((ext (malyon-read-word 54))
- (len (if (zerop ext) 0 (malyon-read-word ext)))
- (table (if (< len 3) 0 (malyon-read-word (+ ext 6)))))
- (if (or (< malyon-story-version 5) (zerop table))
- '()
- (let ((i 0))
- (while (< i 96)
- (aset malyon-unicode-table (+ 155 i) (malyon-char-to-int ??))
- (setq i (+ 1 i))))
- (setq len (malyon-read-byte table))
- (let ((i 0))
- (while (< i len)
- (aset malyon-unicode-table (+ 155 i)
- (malyon-read-word (+ table 1 i)))
- (setq i (+ 1 i)))))))
-
-(defsubst malyon-zscii-to-unicode (char)
- "Converts a zscii character to unicode."
- (if (or (< char 0) (> char 255))
- ??
- (let ((uni (aref malyon-unicode-table char)))
- (if (zerop uni)
- ??
- (malyon-unibyte-char-to-multibyte (malyon-int-to-char uni))))))
-
-(defsubst malyon-unicode-to-zscii (char)
- "Converts a unicode character to zscii."
- (setq char (malyon-multibyte-char-to-unibyte char))
- (setq char (if (malyon-characterp char) (malyon-char-to-int char) char))
- (if (= 13 char)
- ?\r
- (let ((i 1) (found 0))
- (while (and (< i 255) (zerop found))
- (if (= char (aref malyon-unicode-table i))
- (setq found i))
- (setq i (+ i 1)))
- (malyon-int-to-char found))))
-
-;; output streams
-
-(defvar malyon-output-streams nil
- "Valid output streams for the interpreter.")
-
-(defvar malyon-output-streams-tables nil
- "A list of active tables for stream 3.")
-
-(defun malyon-initialize-output-streams ()
- "Initializes the output streams."
- (setq malyon-output-streams '())
- (setq malyon-output-streams-tables '())
- (malyon-add-output-stream 1 0))
-
-(defun malyon-output-stream-function (stream)
- "Returns the output function representing the given stream."
- (cond ((= 1 stream) (if (zerop malyon-current-window)
- 'malyon-putchar-transcript
- 'malyon-putchar-status))
- ((= 2 stream) 'malyon-putchar-printer)))
-
-(defun malyon-add-output-stream (stream table)
- "Add a new output stream."
- (if (= stream 3)
- (progn
- (setq malyon-output-streams-tables
- (cons table malyon-output-streams-tables))
- (malyon-store-word table 0))
- (let ((function (malyon-output-stream-function stream)))
- (setq malyon-output-streams
- (if (member function malyon-output-streams)
- malyon-output-streams
- (cons function malyon-output-streams))))))
-
-(defun malyon-remove-output-stream (stream)
- "Remove an output stream."
- (if (= stream 3)
- (setq malyon-output-streams-tables (cdr malyon-output-streams-tables))
- (setq malyon-output-streams
- (malyon-remove (malyon-output-stream-function stream)
- malyon-output-streams))))
-
-(defun malyon-update-output-streams ()
- "Update output streams when the output window has changed."
- (let ((one (or (member 'malyon-putchar-transcript malyon-output-streams)
- (member 'malyon-putchar-status malyon-output-streams))))
- (setq malyon-output-streams
- (malyon-remove 'malyon-putchar-transcript
- (malyon-remove 'malyon-putchar-status
- malyon-output-streams)))
- (if one
- (malyon-add-output-stream 1 0))))
-
-(defsubst malyon-output-character (char)
- "Output a single character on all active streams."
- (setq char (malyon-zscii-to-unicode char))
- (if malyon-output-streams-tables
- (malyon-putchar-table char (car malyon-output-streams-tables))
- (malyon-mapc (lambda (s) (funcall s char)) malyon-output-streams)))
-
-;; printing text
-
-(defsubst malyon-abbrev (abbrev x)
- "Print an abbreviation."
- (malyon-print-ztext
- (* 2 (malyon-read-word (+ malyon-abbreviations
- (* 2 (+ x (* 32 (1- abbrev)))))))))
-
-(defun malyon-newline ()
- "Print a newline."
- (if (eq malyon-status-buffer (current-buffer))
- (goto-char malyon-status-buffer-point)
- (goto-char (point-max)))
- (malyon-output-character ?\r)
- (if (eq malyon-status-buffer (current-buffer))
- (setq malyon-status-buffer-point (point))
- (goto-char malyon-last-cursor-position-after-input))
- (malyon-redisplay-frame (selected-frame) nil))
-
-(defun malyon-print (object)
- "Print text."
- (let ((text (if (malyon-characterp object) (char-to-string object) object))
- (start))
- (if (eq malyon-transcript-buffer (current-buffer))
- (goto-char (point-max))
- (goto-char malyon-status-buffer-point))
- (setq start (point))
- (malyon-print-characters (malyon-string-to-list text))
- (put-text-property start (point) 'face malyon-current-face)
- (if (eq malyon-status-buffer (current-buffer))
- (setq malyon-status-buffer-point (point))
- (goto-char malyon-last-cursor-position-after-input))))
-
-(defun malyon-print-characters (text)
- "Print a list of characters."
- (malyon-mapc 'malyon-output-character text))
-
-(defsubst malyon-print-state-new (char shift abbr zscii zcode)
- "Generate a new print state."
- (list char shift abbr zscii zcode))
-
-(defsubst malyon-print-state-initial ()
- "Returns an initial state for the ztext decoder."
- (malyon-print-state-new nil -6 0 0 0))
-
-(defsubst malyon-print-state-next (x ignore shift abbr zscii z)
- "Print state transition function."
- (cond ((= zscii 2)
- (malyon-print-state-new (+ z x) -6 0 0 0))
- ((= zscii 1)
- (malyon-print-state-new nil -6 0 2 (* 32 x)))
- ((> abbr 0)
- (malyon-abbrev abbr x)
- (malyon-print-state-initial))
- ((= x 0)
- (malyon-print-state-new ? -6 0 0 0))
- ((< x 4)
- (malyon-print-state-new nil -6 x 0 0))
- ((= x 4)
- (malyon-print-state-new nil 20 0 0 0))
- ((= x 5)
- (malyon-print-state-new nil 46 0 0 0))
- ((and (= shift 46) (= x 6))
- (malyon-print-state-new nil -6 0 1 0))
- ((and (= shift 46) (= x 7))
- (malyon-print-state-new ?\r -6 0 0 0))
- (t
- (malyon-print-state-new
- (aref malyon-alphabet (+ shift x)) -6 0 0 0))))
-
-(defun malyon-print-text (address)
- "Print text at address and return the address of the following byte."
- (let ((start))
- (if (eq malyon-transcript-buffer (current-buffer))
- (goto-char (point-max))
- (goto-char malyon-status-buffer-point))
- (setq start (point))
- (setq address (malyon-print-ztext address))
- (put-text-property start (point) 'face malyon-current-face)
- (if (eq malyon-status-buffer (current-buffer))
- (setq malyon-status-buffer-point (point))
- (goto-char malyon-last-cursor-position-after-input))
- (malyon-redisplay-frame (selected-frame) nil)
- address))
-
-(defun malyon-print-ztext (address)
- "Print the ztext stored at the given address."
- (let ((high 0) (low) (a) (b) (c) (state (malyon-print-state-initial)))
- (while (zerop (logand 128 high))
- (setq high (malyon-read-byte address))
- (setq low (malyon-read-byte (+ 1 address)))
- (setq a (logand 31 (lsh high -2)))
- (setq b (logand 31 (logior (lsh high 3) (lsh low -5))))
- (setq c (logand 31 low))
- (setq state (apply 'malyon-print-state-next a state))
- (if (car state) (malyon-output-character (car state)))
- (setq state (apply 'malyon-print-state-next b state))
- (if (car state) (malyon-output-character (car state)))
- (setq state (apply 'malyon-print-state-next c state))
- (if (car state) (malyon-output-character (car state)))
- (setq address (+ 2 address)))
- address))
-
-(defun malyon-putchar-transcript (char)
- "Print a single character in the transcript window."
- (if (char-equal char ?\n)
- (newline 1)
- (insert char)
- (setq malyon-print-separator (null (member char malyon-whitespace))))
- (if (and malyon-transcript-buffer-buffered
- (> (current-column) (current-fill-column)))
- (progn
- (end-of-line)
- (forward-word -1)
- (if (< 0 (current-column))
- (newline 1))
- (end-of-line))))
-
-(defun malyon-putchar-status (char)
- "Print a single character in the status window."
- (if malyon-status-buffer-delayed-split
- (progn
- (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
- (other-window 1)))
- (if (char-equal char ?\n)
- (progn
- (beginning-of-line)
- (forward-line 1)
- (if (= (point) (point-max))
- (forward-line -1)))
- (if (> (current-column) (current-fill-column))
- '()
- (insert char)
- (delete-char 1))))
-
-(defun malyon-putchar-table (char table)
- "Print a single character into a table."
- (setq char (malyon-unicode-to-zscii char))
- (malyon-store-byte (+ 2 table (malyon-read-word table)) char)
- (malyon-store-word table (+ 1 (malyon-read-word table))))
-
-(defun malyon-putchar-printer (char)
- "Print a single character onto a printer."); not yet implemented
-
-;; more
-
-(defvar malyon-more-continue-keymap nil
- "The keymap with which to continue after More has finished.")
-
-(defun malyon-more (keymap)
- "Enter More mode."
- (if (eq malyon-status-buffer (current-buffer))
- (use-local-map keymap)
- (if (< malyon-story-version 5) (malyon-opcode-show-status))
- (if (< (count-lines malyon-last-cursor-position-after-input (point-max))
- (malyon-window-displayed-height))
- (progn
- (malyon-adjust-transcript)
- (use-local-map keymap))
- (goto-char malyon-last-cursor-position-after-input)
- (beginning-of-line)
- (recenter 1)
- (setq malyon-more-continue-keymap keymap)
- (use-local-map malyon-keymap-more)
- (message "[More]"))))
-
-(defun malyon-more-status-buffer ()
- "Enter More mode for the status buffer."
- (setq malyon-more-continue-keymap (current-local-map))
- (use-local-map malyon-keymap-more-status)
- (message "[More]")
- (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
-
-;; input history
-
-(defvar malyon-history nil
- "The input history.")
-
-(defun malyon-history-previous ()
- "Move one entry up in the input history."
- (let ((prev (aref malyon-history 0))
- (curr (aref malyon-history 1))
- (next (aref malyon-history 2)))
- (if (null prev)
- curr
- (aset malyon-history 2 (if curr (cons curr next) next))
- (aset malyon-history 0 (cdr prev))
- (aset malyon-history 1 (car prev)))))
-
-(defun malyon-history-next ()
- "Move one entry down in the input history."
- (let ((prev (aref malyon-history 0))
- (curr (aref malyon-history 1))
- (next (aref malyon-history 2)))
- (if (null next)
- curr
- (aset malyon-history 0 (if curr (cons curr prev) prev))
- (aset malyon-history 2 (cdr next))
- (aset malyon-history 1 (car next)))))
-
-(defun malyon-history-clear ()
- "Clear the input history."
- (setq malyon-history (vector '() nil '())))
-
-(defun malyon-history-insert (entry)
- "Insert an entry into the input history."
- (let* ((prev (aref malyon-history 0))
- (curr (aref malyon-history 1))
- (next (aref malyon-history 2))
- (l (malyon-remove entry
- (append (nreverse prev)
- (if curr (cons curr next) next))))
- (cut (- (length l) 19)))
- (while (> cut 0)
- (setq l (cdr l)
- cut (- cut 1)))
- (aset malyon-history 0
- (malyon-remove nil (malyon-remove "" (cons entry (nreverse l)))))
- (aset malyon-history 1 nil)
- (aset malyon-history 2 '())))
-
-;; dictionary lookup
-
-(defun malyon-dictionary-word (chars)
- "Convert a list of characters into a dictionary word."
- (list (car (car chars))
- (length chars)
- (malyon-encode-dictionary-word (append (malyon-mapcan 'cdr chars)
- '(5 5 5 5 5 5 5 5)))))
-
-(defsubst malyon-join-characters (stop list)
- "Joins three ztext characters into two bytes."
- (let ((a (car list))
- (b (malyon-cadr list))
- (c (malyon-caddr list))
- (x (if (zerop stop) 0 128)))
- (list (logior x (logand 255 (logior (lsh a 2) (lsh b -3))))
- (logand 255 (logior (lsh b 5) c)))))
-
-(defun malyon-encode-dictionary-word (l)
- "Converts a list of ztext characters into a dictionary word."
- (let* ((first l)
- (second (malyon-cdddr first))
- (third (malyon-cdddr second)))
- (apply 'vector
- (if (< malyon-story-version 5)
- (append (malyon-join-characters 0 first)
- (malyon-join-characters 1 second))
- (append (malyon-join-characters 0 first)
- (malyon-join-characters 0 second)
- (malyon-join-characters 1 third))))))
-
-(defun malyon-lookup (dict code)
- "Look for the given code in the dictionary and return its address."
- (cond ((not code) 0)
- ((not dict) (malyon-binary-search code))
- ((= dict malyon-dictionary) (malyon-binary-search code))
- (t (malyon-linear-search dict code))))
-
-(defsubst malyon-compare-words (word address)
- "Compares the given word to the word stored at address."
- (let* ((i 0)
- (j address)
- (x (aref word i))
- (y (malyon-read-byte j)))
- (while (not (or (/= x y) (= i malyon-dictionary-word-length)))
- (setq i (+ 1 i)
- j (+ 1 j)
- x (aref word i)
- y (malyon-read-byte j)))
- (- x y)))
-
-;; search functions
-
-(defun malyon-binary-search (code)
- "Binary search through the main dictionary."
- (let* ((lower 0)
- (upper (- malyon-dictionary-num-entries 1))
- (median (/ (+ lower upper) 2))
- (entry (+ malyon-dictionary-entries
- (* malyon-dictionary-entry-length median)))
- (looking (malyon-compare-words code entry)))
- (while (not (or (> lower upper) (zerop looking)))
- (setq lower (if (< 0 looking) (+ median 1) lower)
- upper (if (> 0 looking) (- median 1) upper)
- median (/ (+ lower upper) 2)
- entry (+ malyon-dictionary-entries
- (* malyon-dictionary-entry-length median))
- looking (malyon-compare-words code entry)))
- (if (zerop looking) entry 0)))
-
-(defun malyon-linear-search (dictionary code)
- "Linear search through the given dictionary."
- (let* ((length (malyon-read-byte (+ dictionary 1
- (malyon-read-byte dictionary))))
- (number (malyon-read-word (+ dictionary 2
- (malyon-read-byte dictionary))))
- (entries (+ dictionary 4 (malyon-read-byte dictionary)))
- (i 0)
- (entry (+ entries (* length i)))
- (looking (malyon-compare-words code entry)))
- (while (not (or (>= i number) (zerop looking)))
- (setq i (+ 1 i)
- entry (+ entries (* length i))
- looking (malyon-compare-words code entry)))
- (if (zerop looking) entry 0)))
-
-;; encoding text and lexical analysis
-
-(defun malyon-split-list (sep list &optional x)
- "Split a list into sublists as indicated by the separators."
- (cond ((null list)
- (list (nreverse x)))
- ((eq sep (car list))
- (cons (nreverse x) (malyon-split-list sep (cdr list) '())))
- (t
- (malyon-split-list sep (cdr list) (cons (car list) x)))))
-
-(defun malyon-characters-to-words (list)
- "Turn the list of characters into a list of words."
- (mapcar 'malyon-dictionary-word
- (delete '() (malyon-split-list 'malyon-word-separator list))))
-
-(defsubst malyon-char-in-string (c s)
- "Returns the index of c in s if found, or length of s."
- (let ((i 0))
- (while (not (or (= i (length s)) (= c (aref s i))))
- (setq i (+ 1 i)))
- i))
-
-(defsubst malyon-encode-into-ztext (c)
- "Convert a character into ztext."
- (let* ((index (malyon-char-in-string c malyon-alphabet))
- (shift (floor index 26))
- (char (+ 6 (mod index 26))))
- (cond ((> shift 2) (list 5 6 (logand 31 (lsh c -5)) (logand 31 c)))
- ((= shift 2) (list 5 char))
- ((= shift 1) (list 4 char))
- (t (list char)))))
-
-(defun malyon-encode-single-character (terminating-characters char)
- "Encode a character into ztext."
- (let ((pos (car char))
- (c (cdr char)))
- (cond ((member c malyon-whitespace)
- (list 'malyon-word-separator))
- ((member c terminating-characters)
- (list 'malyon-word-separator
- (cons pos (malyon-encode-into-ztext c))
- 'malyon-word-separator))
- (t (list (cons pos (malyon-encode-into-ztext c)))))))
-
-(defun malyon-encode-character-list (dict list)
- "Encode the list of characters into ztext."
- (let ((l '())
- (i 0))
- (while (< i (malyon-read-byte dict))
- (setq l (cons (malyon-read-byte (+ dict 1 i)) l)
- i (+ 1 i)))
- (malyon-mapcan (lambda (x) (malyon-encode-single-character l x)) list)))
-
-(defun malyon-text-length (address)
- "Return the length of the input text."
- (if (>= malyon-story-version 5)
- (malyon-read-byte (+ 1 address))
- (let ((i 0))
- (while (not (zerop (malyon-read-byte (+ i 1 address))))
- (setq i (+ i 1)))
- i)))
-
-(defun malyon-text-to-character-list (address)
- "Convert the input text into a list of characters."
- (let ((i (malyon-text-length address))
- (text '()))
- (while (< 0 i)
- (setq text (cons
- (cons (if (< malyon-story-version 5) i (+ 1 i))
- (malyon-read-byte
- (+ i address (if (< malyon-story-version 5) 0 1))))
- text)
- i (- i 1)))
- text))
-
-(defun malyon-text-to-words (address dictionary)
- "Turn ztext into a list of dictionary words."
- (malyon-characters-to-words
- (malyon-encode-character-list (if dictionary dictionary malyon-dictionary)
- (malyon-text-to-character-list address))))
-
-;; window management
-
-(defvar malyon-status-buffer-grew-this-turn nil
- "A flag signalling if the status buffer grew this turn.")
-
-(defun malyon-adjust-transcript ()
- "Adjust the position of the transcript text."
- (save-excursion
- (setq malyon-status-buffer-grew-this-turn nil)
- (set-buffer malyon-transcript-buffer)
- (goto-char (point-max))
- (recenter (- (malyon-window-displayed-height) 2))))
-
-(defun malyon-prepare-status-buffer (status)
- "Fill the status buffer with empty lines."
- (save-excursion
- (set-buffer malyon-status-buffer)
- (let ((lines (count-lines (point-min) (point-max)))
- (new status))
- (if (zerop lines)
- (newline 1))
- (goto-char (point-max))
- (setq status (- status lines -1))
- (while (> status 0)
- (insert (make-string (+ 3 malyon-max-column) ? ))
- (newline 1)
- (setq status (- status 1)))
- (goto-char (point-min))
- (forward-line (+ 1 new))
- (kill-region (point) (point-max))
- (insert (make-string (+ 3 malyon-max-column) ? ))
- (newline 1))))
-
-(defun malyon-restore-window-configuration ()
- "Restore the saved window configuration."
- (let ((buffer (window-buffer (selected-window))))
- (if malyon-window-configuration
- (set-window-configuration malyon-window-configuration))
- (cond ((eq malyon-status-buffer buffer) (other-window 1))
- ((eq malyon-transcript-buffer buffer) (goto-char (point-max))))))
-
-(defun malyon-set-window-configuration (status)
- "Set up the new window configuration."
- (cond ((< status malyon-status-buffer-lines)
- (setq malyon-status-buffer-delayed-split status)
- (if malyon-status-buffer-grew-this-turn
- (malyon-more-status-buffer)))
- ((> status malyon-status-buffer-lines)
- (malyon-split-buffer-windows status)
- (setq malyon-status-buffer-grew-this-turn t))
- ((not malyon-window-configuration)
- (malyon-split-buffer-windows status))))
-
-(defun malyon-split-buffer-windows (status)
- "Split the buffer windows.
-The status buffer gets 'status' lines while the transcript buffer
-gets the remaining lines."
- (delete-other-windows (get-buffer-window (current-buffer)))
- (setq malyon-status-buffer-lines status)
- (setq malyon-status-buffer-delayed-split nil)
- (if (zerop status)
- '()
- (split-window (get-buffer-window (current-buffer)) (+ status 3))
- (switch-to-buffer malyon-status-buffer)
- (malyon-prepare-status-buffer status)
- (malyon-opcode-set-cursor 1 1)
- (other-window 1))
- (switch-to-buffer malyon-transcript-buffer)
- (setq malyon-window-configuration (current-window-configuration)))
-
-;; getting and setting the machine state
-
-(defun malyon-current-game-state ()
- "Return the current state of the interpreter."
- (vector malyon-instruction-pointer
- malyon-stack-pointer
- malyon-frame-pointer
- (copy-sequence malyon-stack)
- (copy-sequence malyon-story-file)
- malyon-game-state-quetzal))
-
-(defun malyon-set-game-state (state)
- "Installs the given state as the new state of the interpreter."
- (setq malyon-instruction-pointer (aref state 0))
- (setq malyon-stack-pointer (aref state 1))
- (setq malyon-frame-pointer (aref state 2))
- (setq malyon-stack (copy-sequence (aref state 3)))
- (setq malyon-story-file (copy-sequence (aref state 4)))
- (setq malyon-game-state-quetzal (aref state 5))
- (save-excursion
- (malyon-erase-buffer malyon-status-buffer)
- (malyon-split-buffer-windows 0)
- (setq malyon-last-cursor-position-after-input
- (malyon-point-max malyon-transcript-buffer))))
-
-;; file utilities
-
-(defsubst malyon-write-byte-to-file (byte)
- "Write a byte to a file."
- (insert-char (logand 255 byte) 1))
-
-(defsubst malyon-write-word-to-file (word)
- "Write a word to the last opened file."
- (insert-char (logand 255 (lsh word -8)) 1)
- (insert-char (logand 255 word) 1))
-
-(defsubst malyon-write-dword-to-file (dword)
- "Write a dword to the last opened file."
- (insert-char (logand 255 (lsh dword -24)) 1)
- (insert-char (logand 255 (lsh dword -16)) 1)
- (insert-char (logand 255 (lsh dword -8)) 1)
- (insert-char (logand 255 dword) 1))
-
-(defsubst malyon-write-chunk-id-to-file (id)
- "Write a quetzal chunk id to the last opened file."
- (insert id))
-
-(defsubst malyon-read-byte-from-file ()
- "Read the next byte from a file."
- (if (= (point) (point-max))
- 0
- (forward-char 1)
- (malyon-char-to-int (malyon-char-before))))
-
-(defsubst malyon-read-word-from-file ()
- "Read the next word from the last opened file."
- (logior (lsh (malyon-read-byte-from-file) 8) (malyon-read-byte-from-file)))
-
-(defsubst malyon-read-dword-from-file ()
- "Read the next dword from the last opened file."
- (logior (lsh (malyon-read-byte-from-file) 24)
- (lsh (malyon-read-byte-from-file) 16)
- (lsh (malyon-read-byte-from-file) 8)
- (malyon-read-byte-from-file)))
-
-(defsubst malyon-read-chunk-id-from-file ()
- "Read a quetzal chunk id from the last opened file."
- (string (malyon-int-to-char (malyon-read-byte-from-file))
- (malyon-int-to-char (malyon-read-byte-from-file))
- (malyon-int-to-char (malyon-read-byte-from-file))
- (malyon-int-to-char (malyon-read-byte-from-file))))
-
-(defun malyon-get-file-name (address)
- "Retrieves the file name stored at address."
- (let ((name (make-string (malyon-read-byte address) ? ))
- (i 0))
- (while (< i (length name))
- (aset name i (malyon-read-byte (+ address 1 i)))
- (setq i (+ 1 i)))
- name))
-
-;; saving data to disk
-
-(defun malyon-save-file (file &optional table length)
- "Save the current game state or a memory section to disk."
- (interactive "FSave file: ")
- (condition-case nil
- (save-excursion
- (set-buffer (create-file-buffer file))
- (malyon-disable-multibyte)
- (malyon-erase-buffer)
- (cond (table (malyon-save-table table length))
- (malyon-game-state-quetzal
- (malyon-save-quetzal-state (malyon-current-game-state)))
- (t
- (malyon-save-game-state (malyon-current-game-state))))
- (let ((coding-system-for-write 'binary))
- (write-file file))
- (kill-buffer nil)
- 1)
- (error 0)))
-
-(defun malyon-save-table (table length)
- "Save the given section of memory to the file."
- (let ((i 0)
- (j table))
- (while (< i length)
- (malyon-write-byte-to-file (malyon-read-byte j))
- (setq i (+ 1 i)
- j (+ 1 j)))))
-
-(defun malyon-save-game-state (state)
- "Saves the game state to disk."
- (let ((ip (aref state 0))
- (sp (aref state 1))
- (fp (aref state 2))
- (stack (aref state 3))
- (mem (aref state 4))
- (dyn (malyon-read-word 14))
- (i 0))
- (malyon-write-word-to-file (length malyon-story-file-name))
- (while (< i (length malyon-story-file-name))
- (malyon-write-byte-to-file (aref malyon-story-file-name i))
- (setq i (+ 1 i)))
- (malyon-write-dword-to-file ip)
- (malyon-write-word-to-file sp)
- (malyon-write-word-to-file fp)
- (malyon-write-word-to-file dyn)
- (setq i 0)
- (while (<= i sp)
- (malyon-write-dword-to-file (aref stack i))
- (setq i (+ 1 i)))
- (setq i 0)
- (while (< i dyn)
- (malyon-write-byte-to-file (aref mem i))
- (setq i (+ 1 i)))))
-
-(defun malyon-save-quetzal-state (state)
- "Saves the game state to disk in quetzal format."
- (goto-char (point-min))
- (malyon-save-quetzal-ifhd state)
- (malyon-save-quetzal-cmem state)
- (malyon-save-quetzal-stks state)
- (goto-char (point-min))
- (malyon-write-chunk-id-to-file "IFZS")
- (goto-char (point-min))
- (malyon-write-dword-to-file (- (point-max) (point-min)))
- (goto-char (point-min))
- (malyon-write-chunk-id-to-file "FORM"))
-
-(defun malyon-save-quetzal-ifhd (state)
- "Saves the IFhd chunk of the quetzal format."
- (malyon-write-chunk-id-to-file "IFhd")
- (malyon-write-dword-to-file 13)
- (malyon-write-word-to-file (malyon-read-word 2))
- (malyon-write-word-to-file (malyon-read-word 18))
- (malyon-write-word-to-file (malyon-read-word 20))
- (malyon-write-word-to-file (malyon-read-word 22))
- (malyon-write-word-to-file (malyon-read-word 28))
- (malyon-write-byte-to-file (lsh (aref state 0) -16))
- (malyon-write-byte-to-file (lsh (aref state 0) -8))
- (malyon-write-byte-to-file (aref state 0))
- (malyon-write-byte-to-file 0))
-
-(defun malyon-save-quetzal-cmem (state)
- "Saves the CMem chunk of the quetzal format."
- (let ((beginning (point-max))
- (original (aref malyon-game-state-restart 4))
- (current (aref state 4))
- (size (malyon-read-word 14))
- (byte 0)
- (count 0)
- (i 0))
- (goto-char (point-max))
- (while (< i size)
- (setq byte (logxor (aref current i) (aref original i)))
- (if (zerop byte)
- (setq count (+ 1 count))
- (while (> count 0)
- (malyon-write-byte-to-file 0)
- (setq count (- count 1))
- (malyon-write-byte-to-file (min 255 count))
- (setq count (- count (min 255 count))))
- (malyon-write-byte-to-file byte))
- (setq i (+ 1 i)))
- (setq size (- (point-max) beginning))
- (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
- (goto-char beginning)
- (malyon-write-chunk-id-to-file "CMem")
- (malyon-write-dword-to-file size)))
-
-(defun malyon-save-quetzal-stks (state)
- "Saves the Stks chunk of the quetzal format."
- (let ((beginning (point-max))
- (size 0))
- (goto-char (point-max))
- (malyon-save-quetzal-stack-frame (- (aref state 2) 4)
- (aref state 1)
- (aref state 3))
- (setq size (- (point-max) beginning))
- (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
- (goto-char beginning)
- (malyon-write-chunk-id-to-file "Stks")
- (malyon-write-dword-to-file size)))
-
-(defun malyon-save-quetzal-stack-frame (fp sp stack)
- "Saves the stack frames for the Stks chunk."
- (let* ((frame (malyon-get-stack-frame fp sp stack))
- (frame-id (aref frame 0))
- (previous-fp (aref frame 1))
- (previous-sp (aref frame 2))
- (return-addr (aref frame 3))
- (result-addr (aref frame 4))
- (local-vars (aref frame 5))
- (num-args (aref frame 6))
- (eval-stack (aref frame 7)))
- (if (> frame-id 0)
- (malyon-save-quetzal-stack-frame previous-fp previous-sp stack))
- (malyon-write-byte-to-file (lsh return-addr -16))
- (malyon-write-byte-to-file (lsh return-addr -8))
- (malyon-write-byte-to-file return-addr)
- (if (zerop frame-id)
- (malyon-write-byte-to-file 0)
- (malyon-write-byte-to-file (logior (if result-addr 0 16)
- (length local-vars))))
- (malyon-write-byte-to-file (if result-addr result-addr 0))
- (malyon-write-byte-to-file (- (lsh 1 num-args) 1))
- (malyon-write-word-to-file (length eval-stack))
- (while (not (null local-vars))
- (malyon-write-word-to-file (car local-vars))
- (setq local-vars (cdr local-vars)))
- (while (not (null eval-stack))
- (malyon-write-word-to-file (car eval-stack))
- (setq eval-stack (cdr eval-stack)))))
-
-;; restoring data from disk
-
-(defvar malyon-restore-data-error nil
- "An error message if restoring data from a file failed.")
-
-(defvar malyon-restore-quetzal-stack nil
- "A temporary stack for restoring quetzal game states.")
-
-(defvar malyon-restore-quetzal-stack-pointer nil
- "A temporary stack pointer for restoring quetzal game states.")
-
-(defvar malyon-restore-quetzal-frame-pointer nil
- "A temporary frame-pointer for restoring quetzal game states.")
-
-(defun malyon-restore-file (file &optional table length)
- "Restore a game state or a memory section from disk."
- (interactive "fLoad file: ")
- (if (not (and (file-exists-p file) (file-readable-p file)))
- 0
- (condition-case nil
- (save-excursion
- (setq malyon-restore-data-error nil)
- (set-buffer (create-file-buffer file))
- (malyon-disable-multibyte)
- (malyon-erase-buffer)
- (let ((coding-system-for-read 'binary))
- (insert-file-contents file))
- (goto-char (point-min))
- (if table
- (malyon-restore-table table length)
- (let* ((first (malyon-read-chunk-id-from-file))
- (second (malyon-read-dword-from-file))
- (third (malyon-read-chunk-id-from-file)))
- (if (and (string= "FORM" first) (string= "IFZS" third))
- (malyon-restore-quetzal-state (+ 8 second))
- (goto-char (point-min))
- (malyon-restore-game-state))))
- (kill-buffer nil)
- (if (null malyon-restore-data-error)
- 2
- (message malyon-restore-data-error)
- 0))
- (error 0))))
-
-(defun malyon-restore-table (table length)
- "Restore the given section of memory from a file."
- (let ((i 0)
- (j table))
- (while (< i length)
- (malyon-store-byte j (malyon-read-byte-from-file))
- (setq i (+ 1 i)
- j (+ 1 j)))))
-
-(defun malyon-restore-game-state ()
- "Restore a saved game state from disk."
- (let ((len 0)
- (name 0)
- (story 0)
- (ip 0)
- (sp 0)
- (fp 0)
- (dyn 0)
- (stack (copy-sequence malyon-stack))
- (mem (copy-sequence malyon-story-file))
- (i 0))
- (setq len (malyon-read-word-from-file))
- (setq name (make-string len ? ))
- (while (< i len)
- (aset name i (malyon-read-byte-from-file))
- (setq i (+ 1 i)))
- (setq ip (malyon-read-dword-from-file))
- (setq sp (malyon-read-word-from-file))
- (setq fp (malyon-read-word-from-file))
- (setq dyn (malyon-read-word-from-file))
- (setq i 0)
- (while (<= i sp)
- (aset stack i (malyon-read-dword-from-file))
- (setq i (+ 1 i)))
- (setq i 0)
- (while (< i dyn)
- (aset mem i (malyon-read-byte-from-file))
- (setq i (+ 1 i)))
- (setq name (file-name-nondirectory name))
- (setq story (file-name-nondirectory malyon-story-file-name))
- (if (or (string-match name story) (string-match story name))
- (malyon-set-game-state (vector ip sp fp stack mem nil))
- (setq malyon-restore-data-error "Invalid save file."))))
-
-(defun malyon-restore-quetzal-state (size)
- "Restore a saved quetzal game state from disk."
- (let ((chunk-id nil)
- (chunk-len 0)
- (ip 0)
- (memory nil)
- (stack nil)
- (beginning 0))
- (while (< (point) size)
- (setq chunk-id (malyon-read-chunk-id-from-file))
- (setq chunk-len (malyon-read-dword-from-file))
- (setq beginning (point))
- (cond ((string= chunk-id "IFhd")
- (setq ip (malyon-restore-quetzal-ifhd chunk-len)))
- ((string= chunk-id "CMem")
- (setq memory (malyon-restore-quetzal-cmem chunk-len)))
- ((string= chunk-id "UMem")
- (setq memory (malyon-restore-quetzal-umem chunk-len)))
- ((string= chunk-id "Stks")
- (setq stack (malyon-restore-quetzal-stks chunk-len))))
- (if (zerop (mod chunk-len 2)) '() (setq chunk-len (+ 1 chunk-len)))
- (goto-char (+ beginning chunk-len)))
- (cond ((and ip memory stack)
- (malyon-set-game-state (vector ip
- (aref stack 0)
- (aref stack 1)
- (aref stack 2)
- memory
- t)))
- ((null malyon-restore-data-error)
- (setq malyon-restore-data-error "invalid quetzal file.")))))
-
-(defun malyon-restore-quetzal-ifhd (size)
- "Restore an IFhd chunk from disk. Return the instruction pointer."
- (if (and (= (malyon-read-word-from-file) (malyon-read-word 2))
- (= (malyon-read-word-from-file) (malyon-read-word 18))
- (= (malyon-read-word-from-file) (malyon-read-word 20))
- (= (malyon-read-word-from-file) (malyon-read-word 22))
- (= (malyon-read-word-from-file) (malyon-read-word 28)))
- (logior (lsh (malyon-read-byte-from-file) 16)
- (lsh (malyon-read-byte-from-file) 8)
- (malyon-read-byte-from-file))
- (setq malyon-restore-data-error "quetzal file doesn't belong to game.")
- nil))
-
-(defun malyon-restore-quetzal-cmem (size)
- "Restore a CMem chunk from disk. Return the entire memory layout."
- (let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
- (max-size (+ (point) size))
- (byte 0)
- (i 0))
- (while (< (point) max-size)
- (setq byte (malyon-read-byte-from-file))
- (if (zerop byte)
- (setq i (+ 1 i (malyon-read-byte-from-file)))
- (aset memory i (logxor byte (aref memory i)))
- (setq i (+ 1 i))))
- memory))
-
-(defun malyon-restore-quetzal-umem (size)
- "Restore a UMem chunk from disk. Return the entire memory layout."
- (let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
- (i 0))
- (while (< i size)
- (aset memory i (malyon-read-byte-from-file))
- (setq i (+ 1 i)))
- memory))
-
-(defun malyon-restore-quetzal-stks (size)
- "Restore a Stks chunk from disk. Return a vector containing the
-stack pointer, the frame pointer, and the stack itself."
- (let ((i 0) (frame-id 0))
- (setq malyon-restore-quetzal-stack
- (copy-sequence (aref malyon-game-state-restart 3)))
- (setq malyon-restore-quetzal-stack-pointer -1)
- (setq malyon-restore-quetzal-frame-pointer 2)
- (while (< i size)
- (let* ((beginning (point))
- (return3 (malyon-read-byte-from-file))
- (return2 (malyon-read-byte-from-file))
- (return1 (malyon-read-byte-from-file))
- (return-addr (logior (lsh return3 16) (lsh return2 8) return1))
- (result-locals (malyon-read-byte-from-file))
- (has-result (zerop (logand 16 result-locals)))
- (num-locals (logand 15 result-locals))
- (result-addr (malyon-read-byte-from-file))
- (arg-flags (+ 1 (malyon-read-byte-from-file)))
- (num-args 0)
- (eval-size (malyon-read-word-from-file))
- (local-vars '())
- (eval-stack '()))
- (while (> num-locals 0)
- (setq local-vars (cons (malyon-read-word-from-file) local-vars))
- (setq num-locals (- num-locals 1)))
- (while (> eval-size 0)
- (setq eval-stack (cons (malyon-read-word-from-file) eval-stack))
- (setq eval-size (- eval-size 1)))
- (while (> arg-flags 1)
- (setq arg-flags (lsh arg-flags -1))
- (setq num-args (+ num-args 1)))
- (malyon-push-stack-frame frame-id
- return-addr
- (if (zerop frame-id)
- nil
- (if has-result result-addr nil))
- (reverse local-vars)
- num-args
- (reverse eval-stack))
- (setq frame-id (+ 1 frame-id))
- (setq i (+ i (- (point) beginning)))))
- (vector malyon-restore-quetzal-stack-pointer
- malyon-restore-quetzal-frame-pointer
- malyon-restore-quetzal-stack)))
-
-;; object table management
-
-(defsubst malyon-object-address (object)
- "Compute the address at which the object is stored."
- (+ malyon-object-table
- (* 2 malyon-object-properties)
- (* malyon-object-table-entry-size (- object 1))))
-
-(defsubst malyon-object-read-parent (address)
- "Return the parent."
- (if (< malyon-story-version 5)
- (malyon-read-byte (+ 4 address))
- (malyon-read-word (+ 6 address))))
-
-(defsubst malyon-object-read-sibling (address)
- "Return the next sibling."
- (if (< malyon-story-version 5)
- (malyon-read-byte (+ 5 address))
- (malyon-read-word (+ 8 address))))
-
-(defsubst malyon-object-read-child (address)
- "Return the first child."
- (if (< malyon-story-version 5)
- (malyon-read-byte (+ 6 address))
- (malyon-read-word (+ 10 address))))
-
-(defsubst malyon-object-store-parent (address value)
- "Set the parent."
- (if (< malyon-story-version 5)
- (malyon-store-byte (+ 4 address) value)
- (malyon-store-word (+ 6 address) value)))
-
-(defsubst malyon-object-store-sibling (address value)
- "Set the next sibling."
- (if (< malyon-story-version 5)
- (malyon-store-byte (+ 5 address) value)
- (malyon-store-word (+ 8 address) value)))
-
-(defsubst malyon-object-store-child (address value)
- "Set the first child."
- (if (< malyon-story-version 5)
- (malyon-store-byte (+ 6 address) value)
- (malyon-store-word (+ 10 address) value)))
-
-(defun malyon-find-property (object property)
- "Return the address of the object's property, or 0 if it doesn't exist."
- (let ((next (malyon-first-property object))
- (number 0))
- (setq number (logand (malyon-read-byte next) malyon-object-properties))
- (while (> number property)
- (setq next (malyon-next-property next))
- (setq number (logand (malyon-read-byte next) malyon-object-properties)))
- (if (= number property) next 0)))
-
-(defun malyon-first-property (object)
- "Get the address of the object's first property."
- (let ((header (malyon-read-word (+ malyon-object-property-offset
- (malyon-object-address object)))))
- (+ header 1 (* 2 (malyon-read-byte header)))))
-
-(defun malyon-next-property (property)
- "Get the address of the following property."
- (let ((size (malyon-read-byte property))
- (addr (+ property 1)))
- (+ 1 addr (cond ((< malyon-story-version 5) (lsh size -5))
- ((zerop (logand 128 size)) (lsh size -6))
- (t
- (let ((second (logand 63 (malyon-read-byte addr))))
- (if (= 0 second) 64 second)))))))
-
-(defun malyon-remove-object (object)
- "Remove the object from the children list of its parent."
- (let* ((address (malyon-object-address object))
- (parent (malyon-object-read-parent address))
- (sibling (malyon-object-read-sibling address)))
- (malyon-object-store-parent address 0)
- (malyon-object-store-sibling address 0)
- (if (/= parent 0)
- (let ((parent-addr (malyon-object-address parent)))
- (let ((children (malyon-object-read-child parent-addr)))
- (if (or (= children 0) (= children object))
- (malyon-object-store-child parent-addr sibling)
- (let ((this (malyon-object-address children)))
- (let ((next (malyon-object-read-sibling this)))
- (while (/= next object)
- (setq this (malyon-object-address next))
- (setq next (malyon-object-read-sibling this)))
- (malyon-object-store-sibling this sibling)))))))))
-
-;; function calls and code branches
-
-(defun malyon-call-routine (routine arguments &optional result)
- "Call a routine with the given arguments and return its result."
- (if (= routine 0)
- (if result (malyon-store-variable result 0) 0)
- (malyon-push-stack (if result 0 1))
- (malyon-push-stack (if result result 0))
- (malyon-push-stack malyon-instruction-pointer)
- (malyon-push-stack
- (logior (lsh (- malyon-stack-pointer malyon-frame-pointer) 8)
- (length arguments)))
- (setq malyon-instruction-pointer (* malyon-packed-multiplier routine))
- (let ((args (malyon-read-code-byte)) (value nil))
- (if malyon-game-state-quetzal
- (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
- (malyon-push-stack (logior (lsh (+ 1 id) 8) args))))
- (setq malyon-frame-pointer malyon-stack-pointer)
- (while (> args 0)
- (setq value (if (< malyon-story-version 5) (malyon-read-code-word) 0))
- (malyon-push-stack (if (null arguments) value (car arguments)))
- (setq arguments (cdr arguments))
- (setq args (- args 1))))))
-
-(defun malyon-jump-if (condition)
- "Jump depending on the condition and the following jump data."
- (let ((byte (malyon-read-code-byte))
- (offset nil)
- (iftrue nil))
- (setq iftrue (/= 0 (logand byte 128)))
- (setq offset (logand byte 63))
- (if (= 0 (logand byte 64))
- (progn
- (setq offset (logior (lsh offset 8) (malyon-read-code-byte)))
- (if (>= offset 8192) (setq offset (- offset 16384)))))
- (if (or (and iftrue condition) (and (not iftrue) (not condition)))
- (progn
- (cond ((= offset 0) (malyon-opcode-rfalse))
- ((= offset 1) (malyon-opcode-rtrue))
- (t (setq
- malyon-instruction-pointer
- (+ malyon-instruction-pointer offset -2))))))))
-
-(defun malyon-return (value)
- "Return from a routine."
- (setq malyon-stack-pointer malyon-frame-pointer)
- (if malyon-game-state-quetzal (malyon-pop-stack))
- (setq malyon-frame-pointer
- (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
- (setq malyon-instruction-pointer (malyon-pop-stack))
- (let ((result (malyon-pop-stack))
- (store (malyon-pop-stack)))
- (if (zerop store)
- (malyon-return-store result value)
- (malyon-return-ignore result value))))
-
-(defun malyon-return-ignore (where value)
- "Return from a routine ignoring the result.")
-
-(defun malyon-return-store (where value)
- "Return from a routine storing the result."
- (malyon-store-variable where value))
-
-(defun malyon-push-initial-frame ()
- "Push the initial stack frame required in quetzal mode."
- (if malyon-game-state-quetzal
- (progn
- (malyon-push-stack 1)
- (malyon-push-stack 0)
- (malyon-push-stack 0)
- (malyon-push-stack 0)
- (malyon-push-stack 0))))
-
-(defun malyon-get-stack-frame (fp sp stack)
- "Return a decoded stack frame in quetzal mode.
-The result is a vector containing the frame id, the fp of the
-previous frame, the sp of the previous frame, the return address,
-the result variable if any, a list of local variables, the number
-of arguments, and a list of the evaluation stack elements."
- (let* ((has-result (zerop (aref stack fp)))
- (result-addr (if has-result (aref stack (+ 1 fp)) nil))
- (return-addr (aref stack (+ 2 fp)))
- (offset (lsh (aref stack (+ 3 fp)) -8))
- (num-args (logand 255 (aref stack (+ 3 fp))))
- (frame-id (lsh (aref stack (+ 4 fp)) -8))
- (num-locals (logand 255 (aref stack (+ 4 fp))))
- (start-locals (+ 5 fp))
- (start-eval (+ 5 fp num-locals))
- (local-vars '())
- (eval-stack '()))
- (if (not (zerop num-locals))
- (setq local-vars
- (malyon-vector-to-list stack start-locals start-eval)))
- (if (> sp start-eval)
- (setq eval-stack
- (malyon-vector-to-list stack start-eval (+ 1 sp))))
- (vector frame-id
- (- fp offset 2)
- (- fp 1)
- return-addr
- result-addr
- local-vars
- num-args
- eval-stack)))
-
-(defsubst malyon-restore-quetzal-push-stack (value)
- "Push a value onto the restore quetzal stack."
- (setq malyon-restore-quetzal-stack-pointer
- (+ malyon-restore-quetzal-stack-pointer 1))
- (aset malyon-restore-quetzal-stack
- malyon-restore-quetzal-stack-pointer
- value))
-
-(defun malyon-push-stack-frame
- (frame-id return-addr result local-vars num-args eval-stack)
- "Pushes a new stack frame in quetzal mode."
- (malyon-restore-quetzal-push-stack (if result 0 1))
- (malyon-restore-quetzal-push-stack (if result result 0))
- (malyon-restore-quetzal-push-stack return-addr)
- (malyon-restore-quetzal-push-stack
- (logior (lsh (- malyon-restore-quetzal-stack-pointer
- malyon-restore-quetzal-frame-pointer) 8)
- num-args))
- (malyon-restore-quetzal-push-stack
- (logior (lsh frame-id 8) (length local-vars)))
- (setq malyon-restore-quetzal-frame-pointer
- malyon-restore-quetzal-stack-pointer)
- (while (not (null local-vars))
- (malyon-restore-quetzal-push-stack (car local-vars))
- (setq local-vars (cdr local-vars)))
- (while (not (null eval-stack))
- (malyon-restore-quetzal-push-stack (car eval-stack))
- (setq eval-stack (cdr eval-stack))))
-
-;; other stuff
-
-(defvar malyon-aread-text nil
- "Text buffer for user input.")
-
-(defvar malyon-aread-parse nil
- "Parse buffer for user input.")
-
-(defvar malyon-aread-beginning-of-line nil
- "The beginning of the input line.")
-
-;; execution
-
-(defun malyon-interpreter ()
- "Run the z code interpreter on the given story file."
- (condition-case nil
- (progn
- (malyon-restore-window-configuration)
- (if malyon-story-file
- (catch 'malyon-end-of-interpreter-loop
- (setq malyon-last-cursor-position-after-input
- (malyon-point-max malyon-transcript-buffer))
- (malyon-execute))))
- (error
- (malyon-fatal-error "unspecified internal runtime error."))))
-
-(defsubst malyon-fetch-variable-operands (specifier)
- "Fetch a variable number of operands based on the specifier argument."
- (let ((var (logand specifier 49152))
- (op '()))
- (setq specifier (logand 65535 specifier))
- (while (/= 0 specifier)
- (cond ((= var 0) (setq op (cons (malyon-read-code-word) op)))
- ((= var 16384) (setq op (cons (malyon-read-code-byte) op)))
- ((= var 32768) (setq op (cons (malyon-read-variable
- (malyon-read-code-byte)) op)))
- (t (setq specifier 0)))
- (setq specifier (logand 65535 (lsh specifier 2)))
- (setq var (logand specifier 49152)))
- (nreverse op)))
-
-(defsubst malyon-fetch-extended (opcode)
- "Fetch operands for an extended instruction."
- (malyon-fetch-variable-operands
- (logior (lsh (malyon-read-code-byte) 8) 255)))
-
-(defsubst malyon-fetch-variable (opcode)
- "Fetch operands for a variable instruction."
- (malyon-fetch-variable-operands
- (if (or (= opcode 236) (= opcode 250))
- (malyon-read-code-word)
- (logior (lsh (malyon-read-code-byte) 8) 255))))
-
-(defsubst malyon-fetch-short (opcode)
- "Fetch operands for a short instruction."
- (let ((op (logand opcode 48)))
- (cond ((= op 0) (list (malyon-read-code-word)))
- ((= op 16) (list (malyon-read-code-byte)))
- ((= op 32) (list (malyon-read-variable (malyon-read-code-byte)))))))
-
-(defsubst malyon-fetch-long (instr)
- "Fetch operands for a long instruction."
- (let ((byte1 (malyon-read-code-byte))
- (byte2 (malyon-read-code-byte)))
- (list (if (= (logand instr 64) 0) byte1 (malyon-read-variable byte1))
- (if (= (logand instr 32) 0) byte2 (malyon-read-variable byte2)))))
-
-(defun malyon-execute ()
- "Execute z code instructions.
-Load the next instruction opcode and its operands and execute it.
-Repeat ad infinitum."
- (let ((opcode) (operands)); (pc))
- (while t
-; (setq pc malyon-instruction-pointer)
- (setq opcode (malyon-read-code-byte))
- (setq operands (cond ((= opcode 190)
- (setq opcode (+ 256 (malyon-read-code-byte)))
- (malyon-fetch-extended opcode))
- ((>= opcode 192)
- (malyon-fetch-variable opcode))
- ((>= opcode 128)
- (malyon-fetch-short opcode))
- (t
- (malyon-fetch-long opcode))))
-; (malyon-trace-opcode pc opcode operands)
- (apply (aref malyon-opcodes opcode) operands))))
-
-;; opcodes
-
-(defsubst malyon-number (n)
- "Convert an unsigned number into a signed one."
- (if (< n 32768) n (- n 65536)))
-
-(defun malyon-opcode-add (a b)
- "Addition."
- (malyon-store-variable (malyon-read-code-byte)
- (+ (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-and (a b)
- "Bitwise and."
- (malyon-store-variable (malyon-read-code-byte) (logand a b)))
-
-(defun malyon-opcode-aread (text parse &optional time routine)
- "Read input text."
- (setq malyon-aread-text text)
- (setq malyon-aread-parse parse)
- (goto-char (point-max))
- (setq malyon-aread-beginning-of-line (point))
-; Some games violate these assumptions for the "Quit" question.
-; (if (> 3 (malyon-read-byte text))
-; (malyon-fatal-error "text buffer less than 3 bytes."))
-; (if (and (not (zerop parse)) (> 2 (malyon-read-byte parse)))
-; (malyon-fatal-error "parse buffer less than 2 bytes."))
- (malyon-more malyon-keymap-read)
- (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
-
-(defun malyon-opcode-art-shift (value places)
- "Arithmetic shift."
- (malyon-store-variable (malyon-read-code-byte) (ash value places)))
-
-(defun malyon-opcode-buffer-mode (mode)
- "Toggles buffering of text in the transcript window."
- (setq malyon-transcript-buffer-buffered (/= 0 mode)))
-
-(defun malyon-opcode-calln (routine &rest arguments)
- "Call a routine and ignore the result."
- (malyon-call-routine routine arguments))
-
-(defun malyon-opcode-calls (routine &rest arguments)
- "Call a routine and store the result."
- (malyon-call-routine routine arguments (malyon-read-code-byte)))
-
-(defun malyon-opcode-catch ()
- "Return the current stack frame."
- (malyon-store-variable
- (malyon-read-code-byte)
- (if malyon-game-state-quetzal
- (lsh (aref malyon-stack malyon-frame-pointer) -8)
- malyon-frame-pointer)))
-
-(defun malyon-opcode-check-arg-count (count)
- "Tests the number of arguments passed to routine."
- (malyon-jump-if
- (<= count (logand 255 (aref malyon-stack
- (if malyon-game-state-quetzal
- (- malyon-frame-pointer 1)
- malyon-frame-pointer))))))
-
-(defun malyon-opcode-check-unicode (char)
- "Check whether the given character is valid for input/output."
- (malyon-store-variable (malyon-read-code-byte) 0))
-
-(defun malyon-opcode-clear-attr (object attribute)
- "Clear the given attribute in the given object."
- (let ((attributes (malyon-object-address object))
- (byte (lsh attribute -3)))
- (malyon-store-byte (+ attributes byte)
- (logand (malyon-read-byte (+ attributes byte))
- (logxor (lsh 128 (- (logand attribute 7)))
- 255)))))
-
-(defun malyon-opcode-copy-table (first second size)
- "Copies first table onto second one."
- (let* ((length (abs (malyon-number size)))
- (zero (zerop second))
- (forward (or (< (malyon-number size) 0) (> first second)))
- (i 0)
- (a (if forward first (+ first length -1)))
- (b (if forward (if zero first second) (+ second length -1))))
- (while (< i length)
- (malyon-store-byte b (if zero 0 (malyon-read-byte a)))
- (setq i (+ i 1)
- a (if forward (+ a 1) (- a 1))
- b (if forward (+ b 1) (- b 1))))))
-
-(defun malyon-opcode-dec (var)
- "Decrement variable."
- (malyon-store-variable var
- (- (malyon-number (malyon-read-variable var)) 1)))
-
-(defun malyon-opcode-dec-chk (variable threshold)
- "Decrement variable and jump if it's less than the given value."
- (let ((value (malyon-number (malyon-read-variable variable))))
- (malyon-store-variable variable (- value 1))
- (malyon-jump-if (< (- value 1) (malyon-number threshold)))))
-
-(defun malyon-opcode-div (a b)
- "Division."
- (if (zerop b) (malyon-fatal-error "division by 0."))
- (malyon-store-variable (malyon-read-code-byte)
- (/ (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-encode-text (text length from encoded)
- "Encode the zscii text starting at from with the given length.
-The result is stored at encoded."
- (let* ((i length)
- (j encoded)
- (l '())
- (word '()))
- (while (< 0 i)
- (setq l (cons (malyon-read-byte (+ text from i -1)) l)
- i (- i 1)))
- (setq word (malyon-encode-dictionary-word
- (append (malyon-mapcan 'malyon-encode-into-ztext l)
- '(5 5 5 5 5 5 5 5))))
- (while (< i 6)
- (malyon-store-byte j (car l))
- (setq i (+ 1 i)
- j (+ 1 j)
- l (cdr word)))))
-
-(defun malyon-opcode-erase-line (value)
- "Erases the rest of the line."
- (if (= value 1)
- (if (eq malyon-transcript-buffer (current-buffer))
- (kill-line nil)
- (save-excursion
- (let ((i (current-column)))
- (while (<= i malyon-max-column)
- (insert ? )
- (delete-char 1)
- (setq i (+ 1 i))))))))
-
-(defun malyon-opcode-erase-window (window)
- "Erase the contents of the given window."
- (save-excursion
- (let ((w (malyon-number window)))
- (if (or (= w 0) (= w -1) (= w -2))
- (malyon-erase-buffer malyon-transcript-buffer))
- (if (or (= w 1) (= w -1) (= w -2))
- (malyon-erase-buffer malyon-status-buffer))
- (if (= w -1)
- (malyon-split-buffer-windows 0)))
- (setq malyon-last-cursor-position-after-input
- (malyon-point-max malyon-transcript-buffer))))
-
-(defun malyon-opcode-get-child (object)
- "Get the first child of the given object and jump."
- (let ((child (malyon-object-read-child (malyon-object-address object))))
- (malyon-store-variable (malyon-read-code-byte) child)
- (malyon-jump-if (/= 0 child))))
-
-(defun malyon-opcode-get-cursor (array)
- "Retrieves the current cursor position."
- (save-excursion
- (set-buffer malyon-status-buffer)
- (malyon-store-word array (- (count-lines (point-min) (point)) 1))
- (malyon-store-word (+ 2 array) (+ 1 (current-column)))))
-
-(defun malyon-opcode-get-next-prop (object property)
- "Retrieve the first or next property id of object."
- (let ((next (malyon-first-property object))
- (number 0))
- (if (zerop property)
- '()
- (setq number (logand (malyon-read-byte next)
- malyon-object-properties))
- (setq next (malyon-next-property next))
- (while (> number property)
- (setq number (logand (malyon-read-byte next)
- malyon-object-properties))
- (setq next (malyon-next-property next)))
- (if (/= number property)
- (malyon-fatal-error "property does not exist.")))
- (setq number (logand (malyon-read-byte next) malyon-object-properties))
- (malyon-store-variable (malyon-read-code-byte) number)))
-
-(defun malyon-opcode-get-parent (object)
- "Get the parent of the given object."
- (malyon-store-variable (malyon-read-code-byte)
- (malyon-object-read-parent
- (malyon-object-address object))))
-
-(defun malyon-opcode-get-prop (object property)
- "Get the value of the object's property."
- (let* ((address (malyon-find-property object property))
- (size (malyon-read-byte address)))
- (malyon-store-variable
- (malyon-read-code-byte)
- (cond ((zerop address)
- (malyon-read-word (+ malyon-object-table (* 2 (- property 1)))))
- ((and (< malyon-story-version 5) (zerop (lsh size -5)))
- (malyon-read-byte (+ address 1)))
- ((and (>= malyon-story-version 5) (zerop (logand 192 size)))
- (malyon-read-byte (+ address 1)))
- (t
- (malyon-read-word (+ address 1)))))))
-
-(defun malyon-opcode-get-prop-addr (object property)
- "Get the address of the object's property."
- (let* ((address (malyon-find-property object property))
- (size (malyon-read-byte address))
- (offset (if (< malyon-story-version 5)
- 1
- (if (zerop (logand 128 size)) 1 2))))
- (malyon-store-variable (malyon-read-code-byte)
- (if (zerop address) 0 (+ address offset)))))
-
-(defun malyon-opcode-get-prop-len (property)
- "Get the length of the object's property."
- (let ((size (malyon-read-byte (- property 1))))
- (malyon-store-variable
- (malyon-read-code-byte)
- (cond ((< malyon-story-version 5) (+ 1 (lsh size -5)))
- ((zerop (logand 128 size)) (+ 1 (lsh size -6)))
- ((zerop (logand 63 size)) 64)
- (t (logand 63 size))))))
-
-(defun malyon-opcode-get-sibling (object)
- "Get the next object in the tree and jump."
- (let ((sibling (malyon-object-read-sibling (malyon-object-address object))))
- (malyon-store-variable (malyon-read-code-byte) sibling)
- (malyon-jump-if (/= 0 sibling))))
-
-(defun malyon-opcode-illegal (&rest ignore)
- "Print an error message and exit the interpreter."
- (malyon-fatal-error "illegal opcode."))
-
-(defun malyon-opcode-inc (var)
- "Increment variable."
- (malyon-store-variable var
- (+ (malyon-number (malyon-read-variable var)) 1)))
-
-(defun malyon-opcode-inc-chk (variable threshold)
- "Increment variable and jump if it's greater than the given value."
- (let ((value (malyon-number (malyon-read-variable variable))))
- (malyon-store-variable variable (+ value 1))
- (malyon-jump-if (> (+ value 1) (malyon-number threshold)))))
-
-(defun malyon-opcode-input-stream (number)
- "Select the given input stream. Only the keyboard is supported."
- (if (zerop (malyon-number number))
- '()
- (message "Only the keyboard is supported as an input stream.")))
-
-(defun malyon-opcode-insert-obj (object destination)
- "Insert an object into the children list of another."
- (let ((child (malyon-object-address object))
- (parent (malyon-object-address destination)))
- (malyon-remove-object object)
- (malyon-object-store-parent child destination)
- (malyon-object-store-sibling child (malyon-object-read-child parent))
- (malyon-object-store-child parent object)))
-
-(defun malyon-opcode-je (a &rest rest)
- "Jump if first operand equals any of the following."
- (malyon-jump-if (member (malyon-number a) (mapcar 'malyon-number rest))))
-
-(defun malyon-opcode-jg (a b)
- "Jump if first operand > second operand."
- (malyon-jump-if (> (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-jin (child parent)
- "Jump if second object is parent of the first one."
- (malyon-jump-if
- (= parent (malyon-object-read-parent (malyon-object-address child)))))
-
-(defun malyon-opcode-jl (a b)
- "Jump if first operand < second operand."
- (malyon-jump-if (< (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-jump (offset)
- "Jump unconditionally."
- (setq malyon-instruction-pointer (+ malyon-instruction-pointer
- (malyon-number offset) -2)))
-
-(defun malyon-opcode-jz (a)
- "Jump if operand = 0."
- (malyon-jump-if (zerop a)))
-
-(defun malyon-opcode-load (variable)
- "Load a variable."
- (malyon-store-variable (malyon-read-code-byte)
- (malyon-read-variable variable)))
-
-(defun malyon-opcode-loadb (array index)
- "Load an array element into a variable."
- (malyon-store-variable (malyon-read-code-byte)
- (malyon-read-byte (+ array index))))
-
-(defun malyon-opcode-loadw (array index)
- "Load an array element into a variable."
- (malyon-store-variable (malyon-read-code-byte)
- (malyon-read-word (+ array (* 2 index)))))
-
-(defun malyon-opcode-log-shift (value places)
- "Logical shift."
- (malyon-store-variable (malyon-read-code-byte) (lsh value places)))
-
-(defun malyon-opcode-mod (a b)
- "Modulo."
- (malyon-store-variable (malyon-read-code-byte)
- (mod (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-mul (a b)
- "Multiplication."
- (malyon-store-variable (malyon-read-code-byte)
- (* (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-new-line ()
- "Print a newline."
- (malyon-newline))
-
-(defun malyon-opcode-nop (&rest ignore)
- "Do nothing.")
-
-(defun malyon-opcode-not (a)
- "Bitwise not."
- (malyon-store-variable (malyon-read-code-byte) (logand 65535 (lognot a))))
-
-(defun malyon-opcode-or (a b)
- "Bitwise or."
- (malyon-store-variable (malyon-read-code-byte) (logior a b)))
-
-(defun malyon-opcode-output-stream (stream &optional table)
- "Select an output stream."
- (let ((stream (malyon-number stream)))
- (cond ((< 0 stream) (malyon-add-output-stream stream table))
- ((> 0 stream) (malyon-remove-output-stream (- stream))))))
-
-(defun malyon-opcode-piracy ()
- "Piracy check, effectively an unconditional jump."
- (malyon-jump-if 1))
-
-(defun malyon-opcode-pop ()
- "Pop a value off the stack."
- (malyon-pop-stack))
-
-(defun malyon-opcode-print ()
- "Print a string."
- (setq malyon-instruction-pointer
- (malyon-print-text malyon-instruction-pointer)))
-
-(defun malyon-opcode-print-addr (address)
- "Print a string."
- (malyon-print-text address))
-
-(defun malyon-opcode-print-char (c)
- "Print a character."
- (malyon-print (char-to-string c)))
-
-(defun malyon-opcode-print-num (n)
- "Print a number."
- (malyon-print (number-to-string (malyon-number n))))
-
-(defun malyon-opcode-print-obj (obj)
- "Print the short name of the object."
- (malyon-print-text
- (+ 1 (malyon-read-word (+ malyon-object-property-offset
- (malyon-object-address obj))))))
-
-(defun malyon-opcode-print-paddr (address)
- "Print a string."
- (malyon-print-text (* malyon-packed-multiplier address)))
-
-(defun malyon-opcode-print-ret ()
- "Print a string, print a newline, return true/1."
- (setq malyon-instruction-pointer
- (malyon-print-text malyon-instruction-pointer))
- (malyon-newline)
- (malyon-return 1))
-
-(defun malyon-opcode-print-table (text width &optional height skip)
- "Print the given table."
- (if (not height) (setq height 1))
- (if (not skip) (setq skip 0))
- (let ((column (current-column))
- (address text)
- (y 0)
- (x 0))
- (while (< y height)
- (if (zerop y)
- '()
- (malyon-newline)
- (malyon-print-characters (make-string column ? )))
- (setq x 0)
- (while (< x width)
- (malyon-output-character (malyon-read-byte address))
- (setq address (+ 1 address))
- (setq x (+ 1 x)))
- (setq address (+ skip address))
- (setq y (+ 1 y)))))
-
-(defun malyon-opcode-print-unicode (char)
- "Prints a unicode character.")
-
-(defun malyon-opcode-pull (variable)
- "Pull value off stack."
- (malyon-store-variable variable (malyon-pop-stack)))
-
-(defun malyon-opcode-push (value)
- "Push value onto stack."
- (malyon-push-stack value))
-
-(defun malyon-opcode-put-prop (object property value)
- "Set the object's property to the given value."
- (let* ((address (malyon-find-property object property))
- (size (malyon-read-byte address)))
- (cond ((= address 0)
- (malyon-fatal-error "property does not exist."))
- ((and (< malyon-story-version 5) (zerop (lsh size -5)))
- (malyon-store-byte (+ 1 address) (logand 255 value)))
- ((and (>= malyon-story-version 5) (zerop (logand size 192)))
- (malyon-store-byte (+ 1 address) (logand 255 value)))
- (t
- (malyon-store-word (+ 1 address) value)))))
-
-(defun malyon-opcode-quit ()
- "End the game immediately."
- (malyon-adjust-transcript)
- (malyon-cleanup)
- (throw 'malyon-end-of-interpreter-loop 'malyon-opcode-quit))
-
-(defun malyon-opcode-random (limit)
- "Generate a random number or set the seed value."
- (malyon-store-variable (malyon-read-code-byte)
- (if (>= 0 (malyon-number limit))
- 0
- (+ 1 (random (malyon-number limit))))))
-
-(defun malyon-opcode-read-char (&optional device &rest ignore)
- "Read a character."
- (if (and device (/= 1 device))
- (malyon-fatal-error "illegal device specified in read_char."))
- (if (eq malyon-transcript-buffer (current-buffer))
- (goto-char (point-max)))
- (message "[Press a key.]")
- (malyon-more malyon-keymap-readchar)
- (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-character))
-
-(defun malyon-opcode-remove-obj (object)
- "Remove an object from its parent's children list."
- (malyon-remove-object object))
-
-(defun malyon-opcode-restart ()
- "Restart the game."
- (malyon-set-game-state malyon-game-state-restart))
-
-(defun malyon-opcode-restore (&optional table bytes name)
- "Restore a saved game state or a section of memory from a file."
- (let ((result (if name
- (malyon-restore-file
- (malyon-get-file-name name) table bytes)
- (call-interactively 'malyon-restore-file))))
- (if (< malyon-story-version 5)
- (malyon-jump-if (not (zerop result)))
- (malyon-store-variable (malyon-read-code-byte) result))))
-
-(defun malyon-opcode-restore-undo ()
- "Restore game state for undo."
- (if malyon-game-state-undo
- (malyon-set-game-state malyon-game-state-undo))
- (malyon-store-variable (malyon-read-code-byte) 2))
-
-(defun malyon-opcode-ret (value)
- "Return a value."
- (malyon-return value))
-
-(defun malyon-opcode-ret-popped ()
- "Return top of stack."
- (malyon-return (malyon-pop-stack)))
-
-(defun malyon-opcode-rfalse ()
- "Return false/0."
- (malyon-return 0))
-
-(defun malyon-opcode-rtrue ()
- "Return true/1."
- (malyon-return 1))
-
-(defun malyon-opcode-save (&optional table bytes name)
- "Save the current game state or a section of memory to a file."
- (let ((result (if name
- (malyon-save-file (malyon-get-file-name name) table bytes)
- (call-interactively 'malyon-save-file))))
- (if (< malyon-story-version 5)
- (malyon-jump-if (not (zerop result)))
- (malyon-store-variable (malyon-read-code-byte) result))))
-
-(defun malyon-opcode-save-undo ()
- "Save game state for undo."
- (setq malyon-game-state-undo (malyon-current-game-state))
- (malyon-store-byte (malyon-read-code-byte) 1))
-
-(defun malyon-opcode-scan-table (x table len &optional form)
- "Scan the given table for the first occurrence of x."
- (if (not form) (setq form 130))
- (let ((inc (logand 127 form))
- (byte (zerop (logand 128 form)))
- (addr table)
- (found 0)
- (index 0))
- (while (and (zerop found) (< index len))
- (setq found
- (if byte
- (if (= x (malyon-read-byte addr)) addr 0)
- (if (= x (malyon-read-word addr)) addr 0)))
- (setq addr (+ addr inc))
- (setq index (+ index 1)))
- (malyon-store-variable (malyon-read-code-byte) found)
- (malyon-jump-if (not (zerop found)))))
-
-(defun malyon-opcode-set-attr (object attribute)
- "Set the given attribute in the given object."
- (let ((attributes (malyon-object-address object))
- (byte (lsh attribute -3)))
- (malyon-store-byte (+ attributes byte)
- (logior (malyon-read-byte (+ attributes byte))
- (lsh 128 (- (logand attribute 7)))))))
-
-(defun malyon-opcode-set-color (foreground background)
- "Sets the fore- and background colors ie. does nothing.")
-
-(defun malyon-opcode-set-cursor (&optional line column)
- "Set the cursor."
- (if (eq malyon-transcript-buffer (current-buffer))
- (goto-char (point-max))
- (if malyon-status-buffer-delayed-split
- (progn
- (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
- (other-window 1)))
- (if line '() (setq line (count-lines (point-min) (point))))
- (if column '() (setq column (current-column)))
- (if (> line malyon-status-buffer-lines)
- (progn
- (malyon-split-buffer-windows line)
- (other-window 1)))
- (goto-char (point-min))
- (if (and (<= 1 line) (<= line malyon-status-buffer-lines))
- (forward-line line)
- (beginning-of-line))
- (if (and (<= 1 column) (<= column malyon-max-column))
- (forward-char (- column 1))
- (beginning-of-line))
- (setq malyon-status-buffer-point (point))))
-
-(defun malyon-opcode-set-font (font)
- "Sets the font if available or 0 otherwise."
- (malyon-store-variable (malyon-read-code-byte) 0))
-
-(defun malyon-opcode-set-text-style (style)
- "Set the text style/face."
- (let ((face (assq style malyon-faces)))
- (setq malyon-current-face (if face (cdr face) 'malyon-face-plain))))
-
-(defun malyon-opcode-set-window (window)
- "Set the current window."
- (malyon-restore-window-configuration)
- (setq malyon-current-window window)
- (malyon-update-output-streams)
- (if (zerop window)
- (if (not (eq malyon-transcript-buffer (current-buffer)))
- (other-window 1))
- (if (not (eq malyon-status-buffer (current-buffer)))
- (other-window 1))
- (malyon-opcode-set-cursor 1 1)))
-
-(defun malyon-opcode-show-status ()
- "Display the status line."
- (save-excursion
- (malyon-opcode-split-window 1)
- (malyon-restore-window-configuration)
- (malyon-opcode-set-window 1)
- (malyon-prepare-status-buffer 1)
- (malyon-opcode-set-cursor 1 1)
- (malyon-opcode-print-obj (malyon-read-global-variable 0))
- (if (<= (current-column) (- (current-fill-column) 10))
- (let* ((x (malyon-read-global-variable 1))
- (y (malyon-read-global-variable 2))
- (hours (if (> x 12) (- x 12) x))
- (ampm (if (> x 12) "PM" "AM"))
- (score (format "%4d/%4d" x y))
- (time (format "%02d:%02d%s" hours y ampm)))
- (malyon-opcode-set-cursor 1 (- (current-fill-column) 10))
- (malyon-print (if malyon-score-game score time))))
- (malyon-opcode-set-window 0)
- (malyon-adjust-transcript)))
-
-(defun malyon-opcode-split-window (size)
- "Split upper and lower window."
- (malyon-set-window-configuration size))
-
-(defun malyon-opcode-store (variable value)
- "Store a value in a variable."
- (malyon-store-variable variable value))
-
-(defun malyon-opcode-storeb (array index value)
- "Store a value in an array at the given index."
- (malyon-store-byte (+ array index) value))
-
-(defun malyon-opcode-storew (array index value)
- "Store a value in an array at the given index."
- (malyon-store-word (+ array (* 2 index)) value))
-
-(defun malyon-opcode-sub (a b)
- "Subtraction."
- (malyon-store-variable (malyon-read-code-byte)
- (- (malyon-number a) (malyon-number b))))
-
-(defun malyon-opcode-test (bitmap flags)
- "Test if all of the flags are set in the bitmap."
- (malyon-jump-if (= flags (logand bitmap flags))))
-
-(defun malyon-opcode-test-attr (object attribute)
- "Jump depending on the given attribute in the given object."
- (malyon-jump-if
- (/= 0 (logand (malyon-read-byte (+ (malyon-object-address object)
- (lsh attribute -3)))
- (lsh 128 (- (logand attribute 7)))))))
-
-(defun malyon-opcode-throw (value frame)
- "Return from the given stack frame."
- (if malyon-game-state-quetzal
- (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
- (while (/= frame id)
- (setq malyon-stack-pointer malyon-frame-pointer)
- (malyon-pop-stack)
- (setq malyon-frame-pointer
- (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
- (malyon-pop-stack)
- (malyon-pop-stack)
- (setq id (lsh (aref malyon-stack malyon-frame-pointer) -8))))
- (setq malyon-frame-pointer frame))
- (malyon-return value))
-
-(defun malyon-opcode-tokenise (text parse &optional dict flag)
- "Perform lexical analysis on the text buffer."
- (let* ((words (malyon-text-to-words text dict))
- (word (car words))
- (start (car word))
- (len (malyon-cadr word))
- (code (malyon-caddr word))
- (entry (malyon-lookup dict code))
- (i 0))
- (while (not (or (null words) (= i (malyon-read-byte parse))))
- (if (and (zerop entry) flag (/= 0 flag))
- '()
- (malyon-store-word (+ 2 parse (* 4 i)) entry)
- (malyon-store-byte (+ 4 parse (* 4 i)) len)
- (malyon-store-byte (+ 5 parse (* 4 i)) start))
- (setq words (cdr words)
- word (car words)
- start (car word)
- len (malyon-cadr word)
- code (malyon-caddr word)
- entry (malyon-lookup dict code)
- i (+ 1 i)))
- (malyon-store-byte (+ 1 parse) i)))
-
-(defun malyon-opcode-verify ()
- "Verify the correctness of the story file."
- (let ((length (+ 1 (* malyon-packed-multiplier (malyon-read-word 26))))
- (sum 0)
- (i 64))
- (while (< i length)
- (setq sum (mod (+ sum (malyon-read-byte i)) 65536)
- i (+ 1 i)))
- (malyon-jump-if (= (malyon-read-word 28) sum))))
-
-;; keymap utilities
-
-(defun malyon-end-input ()
- "Store the input line in a text buffer and perform lexical analysis."
- (interactive)
- (condition-case nil
- (progn
- (malyon-adjust-transcript)
- (switch-to-buffer malyon-transcript-buffer)
- (goto-char (point-max))
- (let* ((input (downcase
- (buffer-substring-no-properties
- (if (< malyon-aread-beginning-of-line (point))
- malyon-aread-beginning-of-line
- (point))
- (point))))
- (vec (malyon-string-to-vector input))
- (text (apply 'vector (mapcar 'malyon-unicode-to-zscii vec)))
- (len (min (malyon-read-byte malyon-aread-text) (length text)))
- (i 0))
- (malyon-history-insert input)
- (if (>= malyon-story-version 5)
- (malyon-store-byte (+ malyon-aread-text 1) len))
- (while (< i len)
- (malyon-store-byte
- (+ malyon-aread-text (if (< malyon-story-version 5) 1 2) i)
- (malyon-char-to-int (aref text i)))
- (setq i (+ 1 i)))
- (if (< malyon-story-version 5)
- (malyon-store-byte (+ malyon-aread-text 1 len) 0)))
- (if (/= 0 malyon-aread-parse)
- (malyon-opcode-tokenise malyon-aread-text malyon-aread-parse))
- (newline)
- (if (>= malyon-story-version 5)
- (malyon-store-variable (malyon-read-code-byte) 10))
- (malyon-interpreter))
- (error
- (malyon-fatal-error "unspecified internal runtime error."))))
-
-(defun malyon-more-char ()
- "Page down in More mode."
- (interactive)
- (condition-case nil
- (scroll-up)
- (error))
- (if (>= (count-lines (point) (point-max))
- (malyon-window-displayed-height))
- (message "[More]")
- (goto-char (point-max))
- (malyon-adjust-transcript)
- (use-local-map malyon-more-continue-keymap)))
-
-(defun malyon-more-char-status ()
- "Wait for a key then continue."
- (interactive)
- (condition-case nil
- (progn
- (malyon-adjust-transcript)
- (use-local-map malyon-more-continue-keymap)
- (malyon-interpreter))
- (error
- (malyon-fatal-error "unspecified internal runtime error."))))
-
-(defun malyon-wait-char ()
- "Store the input character in a variable and resume execution."
- (interactive)
- (condition-case nil
- (progn
- (malyon-store-variable
- (malyon-read-code-byte)
- (malyon-char-to-int (malyon-unicode-to-zscii last-command-char)))
- (use-local-map malyon-keymap-read)
- (malyon-interpreter))
- (error
- (malyon-fatal-error "unspecified internal runtime error."))))
-
-(defun malyon-history-previous-char (arg)
- "Display the previous item in the input history."
- (interactive "p")
- (let ((input (malyon-history-previous)))
- (cond ((> malyon-aread-beginning-of-line (point))
- (funcall malyon-history-saved-up arg))
- (input
- (save-excursion
- (set-buffer malyon-transcript-buffer)
- (delete-region malyon-aread-beginning-of-line (point-max)))
- (goto-char (point-max))
- (insert input)
- (malyon-adjust-transcript)))))
-
-(defun malyon-history-next-char (arg)
- "Display the next item in the input history."
- (interactive "p")
- (let ((input (malyon-history-next)))
- (cond ((> malyon-aread-beginning-of-line (point))
- (funcall malyon-history-saved-down arg))
- (input
- (save-excursion
- (set-buffer malyon-transcript-buffer)
- (delete-region malyon-aread-beginning-of-line (point-max)))
- (goto-char (point-max))
- (insert input)
- (malyon-adjust-transcript)))))
-
-(defun malyon-beginning-of-line (arg)
- "Go to the beginning of the line."
- (interactive "p")
- (if (> malyon-aread-beginning-of-line (point))
- (beginning-of-line)
- (goto-char malyon-aread-beginning-of-line)))
-
-(defun malyon-kill-region (arg)
- "Kill region."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (kill-region (point) (mark))
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-kill-line (arg)
- "Kill rest of the current line."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (kill-line)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-kill-word (arg)
- "Kill the current word."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (kill-word 1)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-yank (arg)
- "Yank."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (yank)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-yank-pop (arg)
- "Yank pop."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (yank-pop 1)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-delete-char (arg)
- "Delete a character."
- (interactive "p")
- (if (<= malyon-aread-beginning-of-line (point))
- (delete-char 1)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-backward-delete-char (arg)
- "Delete a character backwards."
- (interactive "p")
- (if (< malyon-aread-beginning-of-line (point))
- (backward-delete-char-untabify 1)
- (message "Editing is restricted to the input prompt.")))
-
-(defun malyon-self-insert-command (arg)
- "Insert a character."
- (interactive "p")
- (if (> malyon-aread-beginning-of-line (point))
- (goto-char (point-max)))
- (self-insert-command 1))
-
-;; tracing utility
-
-(defun malyon-trace-file ()
- "Turn tracing on for a particular file."
- (let ((trace
- (get-buffer-create
- (concat "Malyon Trace " malyon-story-file-name))))
- (if trace
- (save-excursion
- (set-buffer trace)
- (malyon-erase-buffer)
- (insert (concat "Tracing " malyon-story-file-name "..."))
- (newline)))))
-
-(defun malyon-trace-newline ()
- "Output tracing newline."
- (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
- (if trace
- (save-excursion
- (set-buffer trace)
- (goto-char (point-max))
- (newline)))))
-
-(defun malyon-trace-opcode (pc opcode operands)
- "Output a z code instruction."
- (malyon-trace-string
- (format "%8d %-3d %-25s %s\n"
- pc
- opcode
- (symbol-name (aref malyon-opcodes opcode))
- (apply 'concat (malyon-mapcan
- (lambda (x)
- (list " "
- (number-to-string
- (if (malyon-characterp x)
- (malyon-char-to-int x)
- x))))
- operands)))))
-
-(defun malyon-trace-string (s)
- "Output tracing string."
- (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
- (if (and trace s)
- (save-excursion
- (set-buffer trace)
- (goto-char (point-max))
- (insert s)))))
-
-(defun malyon-trace-object (o)
- "Output tracing object."
- (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
- (if (and trace o)
- (save-excursion
- (set-buffer trace)
- (goto-char (point-max))
- (prin1 o trace)))))
-
-;;; announce malyon-mode
-
-(provide 'malyon-mode)
-(provide 'malyon)
-
-;;; malyon-mode.el ends here
+++ /dev/null
-;;; org-mac-protocol.el -- process events triggered by the
-;;; org-mac-protocol suite of AppleScripts
-
-;; Copyright (C) 2009, 2010 Christopher Suckling
-
-;; Authors: Christopher Suckling <suckling at gmail dot com>
-
-;; 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.
-
-;; It is distributed in the hope that it will be useful, but WITHOUT
-;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
-;; License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;; Version: 0.634
-;; Keywords: outlines, hyperlinks, wp
-
-;;; Commentary
-;;
-;; This file provides org-protocol handlers and various hacks to
-;; produce a nicely centered, pop-up remember frame for links passed
-;; to emacsclient by the org-mac-protocol suite of AppleScripts. It
-;; also defines new org-mode hyperlink types for opening files in
-;; various OS X applications.
-
-;;; Installation and Usage
-;;
-;; Please see org-mac-protocol.org
-
-;;; Credit
-;;
-;; Portions of this code are developed from a blog post by Jack Moffitt:
-;; http://metajack.im/2008/12/30/gtd-capture-with-emacs-orgmode/
-
-(require 'cl)
-(require 'org-protocol)
-(require 'org-bibtex)
-
-;;; Define org-mode hyperlink types
-;;
-;; BibDesk
-
-(org-add-link-type "bibdesk" 'org-mac-bibdesk-open)
-
-(defun org-mac-bibdesk-open (uri)
- "Visit bibtex entry in BibDesk"
- (let* ((key (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"BibDesk.app\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set theKey to \"" key "\"\n"
- "open theDoc\n"
- "tell document 1 of application \"BibDesk\"\n"
- "set somePubs to (publications whose cite key contains theKey)\n"
- "set the selection to somePubs\n"
- "set theSelection to the selection\n"
- "set thePub to get item 1 of theSelection\n"
- "show thePub\n"
- "end tell\n"
- "end tell"))))
-
-;; Skim
-
-(org-add-link-type "skim" 'org-mac-skim-open)
-
-(defun org-mac-skim-open (uri)
- "Visit page of pdf in Skim"
- (let* ((page (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Skim\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set thePage to " page "\n"
- "open theDoc\n"
- "go document 1 to page thePage of document 1\n"
- "end tell"))))
-
-;; Pages
-
-(org-add-link-type "pages" 'org-mac-pages-open)
-
-(defun org-mac-pages-open (uri)
- "Visit page of document in Pages. Reliant on character offset
-from start of document, so link may degrade if document is
-edited"
- (let* ((charoff (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Pages\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set theCharOff to " charoff "\n"
- "open theDoc\n"
- "select character theCharOff of document 1\n"
- "end tell"))))
-
-;; Numbers
-
-(org-add-link-type "numbers" 'org-mac-numbers-open)
-
-(defun org-mac-numbers-open (uri)
- "Visit range of spreadsheet in Numbers. Although the correct
-cells will be selected, it may be necessary to change sheets
-manually"
- (let* ((sheet (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (table (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
- (org-protocol-unhex-string (match-string 2 uri))))
- (range (when (string-match "::\\(.+\\)::\\(.+\\)::\\(.+\\)\\'" uri)
- (match-string 3 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Numbers\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set theSheet to \"" sheet "\"\n"
- "set theTable to \"" table "\"\n"
- "set theRange to \"" range "\"\n"
- "open theDoc\n"
- "tell document 1\n"
- "tell sheet (theSheet as integer)\n"
- "tell table theTable\n"
- "set selection range to range theRange\n"
- "end tell\n"
- "end tell\n"
- "end tell\n"
- "end tell"))))
-
-
-;; Keynote
-
-(org-add-link-type "keynote" 'org-mac-keynote-open)
-
-(defun org-mac-keynote-open (uri)
- "Visit slide in Keynote"
- (let* ((slide (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Keynote\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set theSlide to " slide "\n"
- "open theDoc\n"
- "show slide theSlide of slideshow 1\n"
- "end tell"))))
-
-
-;; iTunes
-
-(org-add-link-type "iTunes" 'org-mac-iTunes-open)
-
-(defun org-mac-iTunes-open (uri)
- "Visit track in iTunes"
- (let* ((track (when (string-match "[0-9a-zA-Z]+\\'" uri)
- (match-string 0 uri))))
- (do-applescript
- (concat
- "tell application \"iTunes\"\n"
- "activate\n"
- "set theTrack to \"" track "\"\n"
- "set view of front browser window to user playlist \"Music\" of source \"Library\"\n"
- "play (some track of playlist \"Music\" of source \"Library\" whose persistent ID is theTrack)\n"
- "playpause\n"
- "end tell"
- ))))
-
-
-;; Address Book
-;; Support based on code by Alexander Poslavsky
-
-(org-add-link-type "address" 'org-mac-addressbook-open)
-
-(defun org-mac-addressbook-open (uri)
- "Applescript to open correct address-book entry"
- (do-applescript
- (concat
- "set theID to \"" uri "\"\n"
-
- "tell application \"System Events\"\n"
- "activate\n"
- "try\n"
- "open location \"addressbook\:\/\/\" \& theID\n"
- "on error\n"
- "display dialog \"no matching contact found\"\n"
- "end try\n"
- "end tell"
- )))
-
-
-;;; Variables and advice for managing *remember* frames
-
-;; updated for org-capture hooks
-
-(defvar width-of-display (x-display-pixel-width)
- "For some reason, (x-display-pixel-width) returns corrupted
-values when called during (org-mac-protocol-remember); this
-ensures that correct value is returned")
-(setq width-of-display (x-display-pixel-width))
-
-(defvar height-of-display (x-display-pixel-height)
- "For some reason, (x-display-pixel-height) returns corrupted
-values when called during (org-mac-protocol-remember); this
-ensures that correct value is returned")
-(setq height-of-display (x-display-pixel-height))
-
-(defvar org-mac-protocol-app nil
- "The application that AppleScript will activate
-after the *remember* buffer is killed")
-
-(defadvice remember-finalize (after delete-remember-frame activate)
- "Advise remember-finalize to close the frame if it is the mac-remember frame"
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (mapc
- (lambda (x)
- (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
- (make-frame-visible x)))
- (frame-list))
- (mapc
- (lambda (x)
- (when (equal (frame-parameter x 'name) "*mac-remember*")
- (delete-frame x)))
- (frame-list))
- (do-applescript
- (concat
- "tell application \"" org-mac-protocol-app "\"\n"
- "activate\n"
- "end tell"))))
-
-(defadvice remember-destroy (after delete-remember-frame activate)
- "Advise remember-destroy to close the frame if it is the
-mac-rememeber frame"
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (mapc
- (lambda (x)
- (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
- (make-frame-visible x)))
- (frame-list))
- (mapc
- (lambda (x)
- (when (equal (frame-parameter x 'name) "*mac-remember*")
- (delete-frame x)))
- (frame-list))
- (do-applescript
- (concat
- "tell application \"" org-mac-protocol-app "\"\n"
- "activate\n"
- "end tell"))))
-
-(defadvice org-remember-apply-template (before delete-non-remember-windows activate)
- "Advise org-remember to delete non-remember windows if it is in
-the remember frame"
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (delete-other-windows)))
-
-(add-hook 'org-capture-mode-hook
- '(lambda ()
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (delete-other-windows))))
-
-(add-hook 'org-capture-after-finalize-hook
- '(lambda ()
- (unless (boundp 'org-refile-for-capture)
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (mapc
- (lambda (x)
- (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
- (make-frame-visible x)))
- (frame-list))
- (mapc
- (lambda (x)
- (when (equal (frame-parameter x 'name) "*mac-remember*")
- (delete-frame x)))
- (frame-list))
- (do-applescript
- (concat
- "tell application \"" org-mac-protocol-app "\"\n"
- "activate\n"
- "end tell"))))))
-
-(add-hook 'org-after-refile-insert-hook
- '(lambda ()
- (when (boundp 'org-refile-for-capture)
- (when (equal "*mac-remember*" (frame-parameter nil 'name))
- (mapc
- (lambda (x)
- (when (not (equal (frame-parameter x 'name) "*mac-remember*"))
- (make-frame-visible x)))
- (frame-list))
- (mapc
- (lambda (x)
- (when (equal (frame-parameter x 'name) "*mac-remember*")
- (delete-frame x)))
- (frame-list))
- (do-applescript
- (concat
- "tell application \"" org-mac-protocol-app "\"\n"
- "activate\n"
- "end tell"))))))
-
-;;; Define org-protocol protocols
-
-(add-to-list 'org-protocol-protocol-alist
- '("org-mac-remember"
- :protocol "mac-remember"
- :function org-mac-protocol-remember
- :kill-client t))
-
-(add-to-list 'org-protocol-protocol-alist
- '("org-mac-safari-tabs"
- :protocol "safari-tabs"
- :function org-mac-safari-tabs
- :kill-client t))
-
-(defun org-mac-protocol-remember (data)
- "Process an org-protocol://mac-remember:// scheme URL.
-Pop up a small, centred Emacs frame containing a remember
-buffer. Destroys the frame after the remember buffer is filed and
-return to originating application. This code is
-essentially (org-protocol-remember) with an additional :shortdesc
-link property"
-
- (let* ((elements (org-protocol-split-data data nil ":"))
- (info (car elements))
- (app (org-protocol-unhex-string (cadr elements)))
- (parts (org-protocol-split-data info t))
- (template (or (and (= 1 (length (car parts))) (pop parts))
- org-protocol-default-template-key))
- (url (org-protocol-sanitize-uri (car parts)))
- (type (if (string-match "^\\([a-z]+\\):" url)
- (match-string 1 url)))
- (title (or (cadr parts) ""))
- (shorttitle (or (caddr parts) ""))
- (region (or (cadddr parts) ""))
- (orglink (org-make-link-string
- url (if (string-match "[^[:space:]]" title) title url)))
- (org-capture-link-is-already-stored t)
- remember-annotation-functions)
-
- (setq org-mac-protocol-app app)
-
- (do-applescript
- (concat
- "tell application \"Emacs\"\n"
- "activate\n"
- "end tell"))
-
- (make-frame '((name . "*mac-remember*") (width . 80) (height . 20)))
- (mapc (lambda (x)
- (if (not (equal (frame-parameter x 'name) "*mac-remember*"))
- (make-frame-invisible x)
- (let ((center-left
- (/ (- width-of-display (frame-pixel-width)) 2))
- (center-top
- (/ (- (- height-of-display 22) (frame-pixel-height)) 2)))
- (set-frame-parameter nil 'top center-top)
- (set-frame-parameter nil 'left center-left))))
- (frame-list))
- (select-frame-by-name "*mac-remember*")
-
- (setq org-stored-links
- (cons (list url title) org-stored-links))
- (kill-new orglink)
- (org-store-link-props :type type
- :link url
- :description title
- :shortdesc shorttitle
- :initial region)
- (message "protocol: %s" (plist-get org-store-link-plist :shortdesc))
-
- (if (boundp 'org-capture-templates)
- (org-capture nil template)
- (org-remember nil (string-to-char template))))
- nil)
-
-(defun org-mac-safari-tabs (data)
- "Process an org-protocol://safari-tabs:// scheme URL.
-Inserts a formatted list of hyperlinks to the tabs open in the
-front Safari window"
- (let* ((elements (org-protocol-split-data data nil "::"))
- ;; discard the last element, as it is blank
- (links (butlast elements)))
- (mapc (lambda (x)
- (org-protocol-store-link x))
- links))
- nil)
-
-
-(provide 'org-mac-protocol)
+++ /dev/null
-;;; synonyms.el --- Look up synonyms for a word or phrase in a thesaurus.
-;;
-;; Filename: synonyms.el
-;; Description: Look up synonyms for a word or phrase in a thesaurus.
-;; Author: Drew Adams
-;; Maintainer: Drew Adams (concat "drew.adams" "@" "oracle" ".com")
-;; Copyright (C) 2005-2014, Drew Adams, all rights reserved.
-;; Created: Tue Dec 20 14:39:26 2005
-;; Version: 0
-;; Package-Requires: ()
-;; Last-Updated: Thu Dec 26 09:51:41 2013 (-0800)
-;; By: dradams
-;; Update #: 2518
-;; URL: http://www.emacswiki.org/synonyms.el
-;; Doc URL: http://www.emacswiki.org/ThesauriAndSynonyms
-;; Keywords: text, dictionary, thesaurus, spelling, apropos, help
-;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x, 24.x
-;;
-;; Features that might be required by this library:
-;;
-;; `thingatpt', `thingatpt+'.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Commentary:
-;;
-;; Look up synonyms for a word or phrase in a thesaurus.
-;;
-;;
-;; Getting Started
-;; ---------------
-;;
-;; To use library Synonyms, you will need the Moby Thesaurus II file,
-;; `mthesaur.txt', available here:
-;;
-;; ftp://ibiblio.org/pub/docs/books/gutenberg/etext02/mthes10.zip
-;;
-;; Put this in your initialization file (~/.emacs):
-;;
-;; ;; The file names are absolute, not relative, locations
-;; ;; - e.g. /foobar/mthesaur.txt.cache, not mthesaur.txt.cache
-;; (setq synonyms-file <name & location of mthesaur.txt>)
-;; (setq synonyms-cache-file <name & location of your cache file>)
-;; (require 'synonyms)
-;;
-;; As an alternative to the first two lines, you can use Customize to
-;; set `synonyms-file' and `synonyms-cache-file' persistently. The
-;; second of these files is created by this library, to serve as a
-;; synonym cache for completion.
-;;
-;; The main command is `synonyms'. It prompts you for a word or
-;; phrase to look up in the thesaurus. The synonyms found are then
-;; displayed in buffer *Synonyms*. For example, `M-x synonyms RET
-;; democracy' displays synonyms for `democracy'.
-;;
-;; If you do not define `synonyms-file' and `synonyms-cache-file'
-;; prior to using command `synonyms', that command will prompt you to
-;; define them. If you want to use the same values during subsequent
-;; Emacs sessions, then you should use `M-x customize-option' to save
-;; those newly defined values.
-;;
-;;
-;; Some Definitions
-;; ----------------
-;;
-;; The thesaurus is divided into "entries", which are like glossary
-;; entries: each entry is followed by associated words and phrases,
-;; which, for lack of a better word, I refer to as "synonyms". For
-;; example, `democracy' is an entry, and it is followed by its
-;; synonyms. Some synonyms are not also entries. For example,
-;; `patriarchy' is in the thesaurus as a synonym but not as an entry.
-;;
-;; Note: What I call "synonyms" here are not necessarily synonyms, in
-;; the sense of having the same or even similar meanings. They are
-;; simply terms collected together with the same thesaurus entry
-;; because they are related in some way - the grouping is what
-;; defines their relation.
-;;
-;; In Moby Thesaurus II, the meanings of synonyms in the same group
-;; do have something in common, but this might be simply the fact
-;; that they are terms of a similar kind. For example, the
-;; "synonyms" following the `democracy' thesaurus entry are words
-;; such as `dictatorship' and `autocracy'. These are different forms
-;; of the same general thing: government - they are certainly not
-;; synonymous with each other or with the entry `democracy'.
-;;
-;;
-;; Searching the Thesaurus
-;; -----------------------
-;;
-;; The default input value for command `synonyms' is the word under
-;; the cursor. Alternatively, if a region is active and you are in
-;; Transient Mark mode (recommended), then it is the text in the
-;; region (selection).
-;;
-;; Your input is actually treated as a regular expression (regexp),
-;; so you can also input patterns like `for.*ion', which will match
-;; thesaurus entries `formation', `formulation', `fornication',
-;; `fortification', and `forward motion'. Note that the last of
-;; these is a phrase rather than a single word.
-;;
-;; Using a regexp as input is a powerful way to search, but be aware
-;; that it can be costly in CPU time and computer memory if the
-;; regexp is not appropriate. The regexp `.*' will, for example,
-;; likely use up available memory before being able to return the
-;; entire thesaurus (it's very large). You can always use `C-g' to
-;; interrupt a thesaurus search if you mistakenly use an inefficient
-;; regexp.
-;;
-;;
-;; Using a Prefix Argument To Do More
-;; ----------------------------------
-;;
-;; You can use a prefix argument to modify searching and the
-;; presentation of search results, as follows:
-;;
-;; `C-u' - Search for additional synonyms, in two senses:
-;;
-;; 1) Return also synonyms that are matched partially
-;; by the input.
-;;
-;; 2) Search the entire thesaurus for input matches,
-;; even if the input matches a thesaurus entry.
-;;
-;; `M--' - Append the search results to any previous search
-;; results, in buffer *Synonyms*. (Normally, the new
-;; results replace any previous results.)
-;;
-;; `C-u C-u' - `C-u' plus `M--': Search more and append results.
-;;
-;; If you find yourself often using a particular prefix argument (for
-;; example, to append results), then you might want to instead change
-;; the default behavior to reflect this preference. Options
-;; `synonyms-match-more-flag' and `synonyms-append-result-flag'
-;; correspond to using `C-u' and `M--', respectively. In fact, a
-;; prefix argument simply toggles the value of the corresponding
-;; option for the duration of the command. So, for example, if
-;; `synonyms-append-result-flag' is t and you use `M--', then results
-;; will not be appended.
-;;
-;; When partially matching input (`C-u', sense #1), complete synonyms
-;; are matched against your input. This means that you generally
-;; need not add a preceding or trailing `.*' to try to match a
-;; complete synonym. For example, input `format' will match the
-;; complete synonyms `conformation', `efformation', `format',
-;; `formation', `formative', `formational', `information',
-;; `informative', `informational', `malformation', `deformation',
-;; `reformation', `transformation', `reformatory', and so on - there
-;; is no need to input `.*format.*' to match the same synonyms.
-;;
-;; To better understand the meaning of #2 above for `C-u' (to
-;; continue the search even if your input matches an entry), try, for
-;; example, `C-u M-x synonyms RET widespread'. You'll see not only
-;; the main synonyms listed for `widespread' as an entry, but also
-;; lots of different meanings of `widespread', judging by the entries
-;; for which it is listed as a synonym:
-;;
-;; `accepted', `ample', `broad', `broadcast', `capacious',
-;; `catholic', `commodious', `commonness', `conventional',
-;; `currency', `current', `customary', `deep', `deltoid',
-;; `diffuse', `discrete', `dispersed', `disseminated',
-;; `dissipated', `distributed', `epidemic', `established',
-;; `everyday', `expansive', `extended', `extensive', `familiar',
-;; `fan shaped', `far flung', `far reaching', `flaring', `full',
-;; `general', `indiscriminate', `infinite', `large scale',
-;; `liberal', `normal', `normality', `open', `ordinary',
-;; `outstretched', `pervasive', `popular', `prescribed',
-;; `prescriptive', `prevailing', `prevalence', `prevalent',
-;; `public', `rampant', `received', `regnant', `regular',
-;; `regulation', `reign', `rife', `roomy', `ruling', `run',
-;; `scattered', `set', spacious`', `sparse', `splay', `sporadic',
-;; `sprawling', `spread', `standard', `stock', `straggling',
-;; `stretched out', `sweeping', `time-honored', `traditional',
-;; `universal', `usual', `vast', `voluminous', `wholesale', `wide
-;; open', `wide', and `wonted'.
-;;
-;; These are just the entries! Each of these is of course followed by
-;; its own synonyms - perhaps 100 or 300, including `widespread'.
-;;
-;; This list of entries is not the same list as the synonyms for
-;; entry `widespread'. There are words and phrases here that are not
-;; in the latter list, and vice versa. For example, the former (but
-;; not the latter) list includes `full'; the latter (but not the
-;; former) list includes `wide-reaching'.
-;;
-;; The latter are the words most closely related to `widespread'.
-;; The list above are the other thesaurus entries (corresponding to
-;; main categories) to which `widespread' is most closely related.
-;; Looking at all of the synonym groups in which `widespread' appears
-;; can tell you additional information about its meanings - and it
-;; can provide additional synonyms for `widespread'.
-;;
-;;
-;; Using Completion with Synonyms
-;; ------------------------------
-;;
-;; You can complete words and phrases in the minibuffer, as input to
-;; command `synonyms'. You can use library Synonyms together with
-;; library `Icicles to complete a partial word in a text buffer into a
-;; word or phrase in the thesaurus. If you use both libraries then
-;; load Icicles after Synonyms. For more information on Icicles, see
-;; `http://www.emacswiki.org/Icicles'.
-;;
-;; ** Minibuffer Input Completion **
-;;
-;; You can enter any text to match against thesaurus synonyms. When
-;; you are prompted by command `synonyms' to enter this text, you can
-;; also use input completion to complete to a thesaurus synonym.
-;; That is, even though you can enter any text (including a regexp),
-;; completion will only complete to synonyms in the thesaurus.
-;;
-;; If you load library Icicles, then a more powerful version of
-;; command `synonyms' is used. In particular, it lets you:
-;;
-;; - Use `S-TAB' during completion to see the list of all synonyms
-;; (thesaurus terms) that match your minibuffer input so far.
-;;
-;; - Use `next' (or repeated `S-TAB'), and `prior' (usually keys
-;; `Page Down' and `Page Up') during completion to cycle through
-;; the completion candidates (synonyms) that match your input.
-;;
-;; - Use `C-next' and `C-prior' during completion to display the
-;; synonyms of the current completion candidate.
-;;
-;; ** Completing Buffer Text Using the Thesaurus **
-;;
-;; Icicles also provides two commands for using completion to insert
-;; thesaurus entries in a buffer:
-;;
-;; - `icicle-complete-thesaurus-entry' completes a word in a text
-;; buffer to any word or phrase in the thesaurus. I bind it to
-;; `C-c /'.
-;;
-;; - `icicle-insert-thesaurus-entry' inserts thesaurus words and
-;; phrases in a text buffer. It is a multi-command, which means
-;; that, within a single call to it, you can insert any number of
-;; thesaurus entries, in succession. If you want to, you can
-;; write an entire book using a single call to
-;; `icicle-insert-thesaurus-entry'!
-;;
-;;
-;; Browsing the Thesaurus
-;; ----------------------
-;;
-;; Besides using command `synonyms' to search for synonyms, you can
-;; use Synonyms to browse the thesaurus. This is really just the
-;; same thing, but key and mouse bindings are provided in buffer
-;; *Synonyms*, so you need not input anything - just point and click
-;; the hyperlinks. Buffer *Synonyms* is in Synonyms major mode,
-;; which provides a few additional features.
-;;
-;; You can still choose to search for additional synonyms or append
-;; search results, without bothering with a prefix argument, by using
-;; modifier keys (Control, Meta) with a mouse click.
-;;
-;; Another way of browsing is to revisit previous search-result
-;; pages. You can do this using commands `synonyms-history-backward'
-;; and `synonyms-history-forward'. In buffer *Synonyms*, these are
-;; bound to the following key sequences, for convenience:
-;;
-;; `l', `p', `mouse-4' - `synonyms-history-backward'
-;; `r', `n', `mouse-5' - `synonyms-history-forward'
-;;
-;; The `l' and `r' bindings correspond to the history bindings in
-;; Info. The `p' and `n' bindings stand for "previous" and "next".
-;; The bindings to additional mouse buttons correspond to typical
-;; bindings for Back and Forward in Web browsers.
-;;
-;; In addition to these bindings, the same history commands can be
-;; accessed by clicking links [Back] and [Forward] with `mouse-2'.
-;;
-;; If you have previously used the append option (via, for example,
-;; `M-mouse2'), so that there are multiple search results in buffer
-;; *Synonyms*, then using a history command simply takes you to the
-;; preceding (for [Back]) or following (for [Forward]) result in the
-;; buffer, measured from the current cursor position. Depending on
-;; the cursor position, this might be different from the previous or
-;; next search made previously.
-;;
-;; This is for convenience, but it is also more efficient in the case
-;; of a regexp search that takes a long time. Except for this
-;; special treatment of appended results, whenever you navigate the
-;; search-results history you are actually searching again for a
-;; synonym you sought previously. The case of appended results is
-;; analogous to accessing a Web browser cache when navigating the
-;; history.
-;;
-;; You can of course use modifier keys (Control, Meta) while you
-;; click links [Back] and [Forward], to impose their usual behavior:
-;; search for additional synonyms or append search results, or both.
-;;
-;; Finally, some people prefer menus, so there is a Synonyms menu-bar
-;; menu when you are in Synonyms mode, complete with all of the
-;; functionalities described above.
-;;
-;; For more information on the browsing possibilities in buffer
-;; *Synonyms*, use `?' in Synonyms mode.
-;;
-;;
-;; Dictionary Definitions, Antonyms, etc.
-;; --------------------------------------
-;;
-;; Synonyms works with a large but simple database of groups of words
-;; and phrases that are synonyms of each other. This database does
-;; not provide definitions of words or phrases; it simply groups
-;; them. Command `synonym-definition' (aka `dictionary-definition')
-;; lets you look up a word or phrase (or a regexp) using one or more
-;; dictionaries on the Web. That is usually the best source for this
-;; kind of information, but you obviously need an Internet connection
-;; to use this command.
-;;
-;; Options (variables) `synonyms-dictionary-url' and
-;; `synonyms-dictionary-alternate-url' are URLs you can set to point
-;; to the dictionaries of your choice. The default value of
-;; `synonyms-dictionary-alternate-url' looks up the search term in
-;; multiple dictionaries, and it lets you use wildcards. Use `C-h v
-;; synonyms-dictionary-alternate-url' for more information. The
-;; default value of `synonyms-dictionary-url' usually provides a
-;; quicker answer. Both of these URLs also give you access to
-;; additional information about the search term (antonyms, etymology,
-;; even pronunciation).
-;;
-;; In buffer *Synonyms*, you can simply hit `d' followed by `RET' or
-;; `mouse-2' to look up a term that is in the buffer. Just as for
-;; looking up a synonym by clicking `mouse-2', if you select text
-;; (region), then that text is looked up.
-;;
-;;
-;; A Cache File of Synonyms
-;; ------------------------
-;;
-;; The very first time you use Synonyms, a large list of synonyms
-;; will be compiled and written to a cache file. This is slow - it
-;; takes 2-3 minutes - but it is only a one-time cost. From then on,
-;; whenever you first use Synonyms during an Emacs session, the cache
-;; file will be read (quickly), to create the list of synonyms that
-;; are used for minibuffer completion.
-;;
-;;
-;; Using Other Thesauri, Dictionaries, and so on - CSV data
-;; --------------------------------------------------------
-;;
-;; There is nothing in library Synonyms that ties it to the Moby
-;; Thesaurus II thesaurus. All of its functionality will work with
-;; any file of comma-separated values. Each line of such a file is
-;; interpreted as a synonym group, as understood here, and the first
-;; word or phrase on each line is interpreted as a thesaurus entry,
-;; as understood here. This means only that search results are
-;; organized into sections with entry headers.
-;;
-;; If, for example, you had a CSV file of personal contacts, where
-;; the first term in each line was a last name or a company name,
-;; then you could use library Synonyms to query it, producing the
-;; same kind of output as for the thesaurus.
-;;
-;; One thing to keep in mind if you try to use library Synonyms with
-;; a different CSV file is that there are several different CSV-file
-;; syntaxes. The one that Synonyms is built to use is a simple one,
-;; with no quote marks around entries and no embedded quote marks
-;; within entries.
-;;
-;; Similarly, there is nothing here that limits the functionality to
-;; English. If you had a thesaurus in another language, it should
-;; work as well.
-;;
-;; Currently, Synonyms works with a single raw synonyms file
-;; (thesaurus) and a corresponding single cache file (for
-;; completion). However, it would be easy to extend the
-;; functionality to use multiple thesauri or, in general, multiple
-;; CSV files. Suggestions of requirements (e.g. ways to select a
-;; thesaurus for particular passages of text) are welcome.
-
-;;
-;;
-;; Things Defined Here
-;; -------------------
-;;
-;; Faces defined here -
-;;
-;; `synonyms-heading', `synonyms-search-text',
-;; `synonyms-mouse-face'.
-;;
-;;
-;; User options (variables) defined here -
-;;
-;; `synonyms-append-result-flag', `synonyms-cache-file',
-;; `synonyms-file', `synonyms-fill-column',
-;; `synonyms-match-more-flag', `synonyms-mode-hook',
-;; `synonyms-use-cygwin-flag'.
-;;
-;; Commands defined here -
-;;
-;; `dictionary-definition', `synonyms', `synonyms-append-result',
-;; `synonyms-append-result-no-read', `synonyms-definition',
-;; `synonyms-definition-mouse', `synonyms-definition-no-read',
-;; `synonyms-ensure-synonyms-read-from-cache',
-;; `synonyms-history-backward', `synonyms-history-forward',
-;; `synonyms-make-obarray', `synonyms-match-more',
-;; `synonyms-match-more-no-read',
-;; `synonyms-match-more+append-result',
-;; `synonyms-match-more+append-result-no-read', `synonyms-mode',
-;; `synonyms-mouse', `synonyms-mouse-append-result',
-;; `synonyms-mouse-match-more',
-;; `synonyms-mouse-match-more+append-result', `synonyms-no-read',
-;; `synonyms-write-synonyms-to-cache'.
-;;
-;; Non-interactive functions defined here -
-;;
-;; `synonyms-action', `synonyms-add-history-links',
-;; `synonyms-default-regexp', `synonyms-define-cache-file',
-;; `synonyms-define-synonyms-file', `synonyms-format-entries',
-;; `synonyms-format-entry', `synonyms-format-finish',
-;; `synonyms-format-synonyms',
-;; `synonyms-hack-backslashes-if-cygwin', `synonyms-lookup',
-;; `synonyms-nearest-word', `synonyms-file-readable-p',
-;; `synonyms-search-entries', `synonyms-search-synonyms',
-;; `synonyms-show-synonyms', `synonyms-file-writable-p'.
-;;
-;; Internal variables defined here -
-;;
-;; `synonyms-history', `synonyms-history-forward',
-;; `synonyms-list-for-obarray', `synonyms-mode-map',
-;; `synonyms-obarray', `synonyms-search-text'.
-;;
-;; Key bindings made here - see `synonyms-mode'. All key bindings
-;; are local to Synonyms mode; no global bindings are made here.
-
-;;
-;;
-;; Acknowledgements
-;; ----------------
-;;
-;; The basic functionality provided here was derived from library
-;; `mthesaur.el', by Tad Ashlock <taashloNOSPAMcyberdude.com>. That
-;; library, in turn, was inspired by library `thesaurus.el', by Ray
-;; Nickson. Thanks also to those who sent helpful bug reports.
-;;
-;;
-;; Note on MS Windows Emacs 20 and Cygwin `grep'
-;; ---------------------------------------------
-;;
-;; There is apparently a bug in the Emacs (at least versions 20-22) C
-;; code that implements function `call-process' on MS Windows. When
-;; using native Windows Emacs with Cygwin commands, such as `grep',
-;; the C code removes a level of backslashes in some cases, so string
-;; arguments supplied to `call-process' need to have twice as many
-;; backslashes as they should need in those cases. It is for this
-;; reason that option `synonyms-use-cygwin-flag' is supplied here.
-;; When that option is non-nil, backslashes in regexps are hacked to
-;; do the right thing. (In Emacs 20, this means doubling the
-;; backslashes; in Emacs 21-22, this means doubling them unless there
-;; are spaces in the search string.)
-;;
-;;
-;; Maybe To Do?
-;; ------------
-;;
-;; 1. It would be ideal to have not only synonym information but also
-;; definitions, antonyms, more general and more specific terms,
-;; filtering by part of speech (verb vs adjective etc.), and so
-;; on. A good example of what I'd really like to have is provided
-;; by the free Windows program WordWeb (available here:
-;; http://wordweb.info/). Combining that functionality with
-;; Icicles completion features would provide a great tool, IMO.
-;;
-;; `synonyms-definition*' goes a long way toward providing this,
-;; and perhaps it is the best way to go, since there is so much
-;; more definitional info on the Web.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Change Log:
-;;
-;; 2012/08/21 dadams
-;; Call tap-put-thing-at-point-props after load thingatpt+.el.
-;; 2012/08/18 dadams
-;; Invoke tap-define-aliases-wo-prefix if thingatpt+.el is loaded.
-;; 2012/03/02 dadams
-;; Require cl.el at compile time only for Emacs 20.
-;; 2011/07/30 dadams
-;; Moved Icicles code to icicles-cmd2.el. Removed soft-require of icicles.el.
-;; 2011/02/11 dadams
-;; Better defaults for faces, for dark backgrounds.
-;; 2011/01/04 dadams
-;; Added autoload cookies (for defgroup, defface, defcustom, and commands).
-;; 2010/08/20 dadams
-;; synonyms - non-Icicles version: Made ARG optional too.
-;; synonyms(-no-read|-history-(backward|forward)):
-;; Use ARG, not current-prefix-arg.
-;; 2010/01/12 dadams
-;; synonyms-history-(backward|forward): save-excursion + set-buffer -> with-current-buffer.
-;; 2007/12/05 dadams
-;; synonyms-obarray: Removed * doc-string prefix.
-;; 2007/02/10 dadams
-;; icicle-sort-case-insensitively -> icicle-case-insensitive-string-less-p.
-;; 2006/12/22 dadams
-;; Renamed group synonyms to Synonyms. :group 'icicles -> :group 'Icicles.
-;; 2006/03/31 dadams
-;; synonyms-write-synonyms-to-cache: Use prin1 instead of pp.
-;; 2006/03/17 dadams
-;; synonyms-file-(read|writ)able-p: Put non-empty string condition first.
-;; 2006/03/14 dadams
-;; synonyms-file-(read|writ)able-p: Make sure also not a directory.
-;; 2006/03/12 dadams
-;; synonyms-ensure-synonyms-read-from-cache, synonyms-define-synonyms-file:
-;; Set synonyms(-cache)-file to expanded version.
-;; 2006/03/01 dadams
-;; Updated Commentary to mention Icicles completion of synonyms.
-;; 2006/02/02 dadams
-;; synonyms-define-cache-file: Fixed typo.
-;; 2006/01/28 dadams
-;; synonyms-define-cache-file: wrap file-name-directory in expand-file-name.
-;; 2006/01/19 dadams
-;; synonyms-format-finish: Minor tweak to regexp: space and tab, but not newline or formfeed.
-;; 2006/01/18 dadams
-;; Added dictionary definition lookup:
-;; Added: synonyms-dictionary(-alternate)-url, synonyms-definition*.
-;; Bound synonyms-definition-*.
-;; 2006/01/14 dadams
-;; Bug fixes -
-;; Make sure file name is expanded (thanks to Nikos Apostolakis):
-;; synonyms-search-(entries|synonyms): Expand file name.
-;; synonyms-define-*-file: Set variable after expanding file name.
-;; synonyms-format-entry, synonyms-history-*, synonyms-add-history-links:
-;; Raise error if search finds nothing.
-;; synonyms-hack-backslashes-if-cygwin: Don't double if spaces and not Emacs 20.
-;; Renamed synonyms-double-backslashes-if-cygwin to synonyms-hack-backslashes-if-cygwin.
-;; synonyms-mode-map: swapped bindings for C-mouse-2 and C-down-mouse-2, for Emacs 22.
-;; 2006/01/11 dadams
-;; Fixed typo: require 'synonyms. (Thanks to Nikos Apostolakis.)
-;; 2006/01/07 dadams
-;; Added :link.
-;; 2006/01/04 dadams
-;; synonyms-format-finish: Don't skip numbered header, so highlight multiple synonyms in entry.
-;; 2006/01/02 dadams
-;; Added: synonyms-define-cache-file, synonyms-define-synonyms-file,
-;; synonyms-file-readable-p, synonyms-file-writable-p.
-;; synonyms-make-obarray: Use synonyms-define-synonyms-file.
-;; Use synonyms-mode, to get modified syntax (bug fix).
-;; synonyms-write-synonyms-to-cache: Use synonyms-define-cache-file.
-;; synonyms-ensure-synonyms-read-from-cache: Use synonyms-file-readable-p.
-;; synonyms(-cache)-file: Use empty string as initial value.
-;; Thanks to Alex Schroeder [alexNOSPAMemacswiki.org] for suggestion to prompt for file names.
-;; 2005/12/31 dadams
-;; Added menu-bar Synonyms menu.
-;; Renamed synonyms-read-synonyms-from-cache to synonyms-ensure-synonyms-read-from-cache.
-;; Call it from synonyms, not from synonyms-mode.
-;; Defined synonyms-mode-map per convention.
-;; synonyms-match-more, synonyms-append-result, synonyms-match-more+append-result:
-;; Use synonyms, not synonyms-no-read.
-;; Added: synonyms-*-no-read. Bound those, not the new read versions.
-;; 2005/12/29 dadams
-;; Treat modifiers with clicks on [Back] and [Forward] links.
-;; synonyms-history-(backward|forward): Add prefix arg. Bind options.
-;; synonyms-mode, synonyms-lookup: Disable undo.
-;; 2005/12/28 dadams
-;; Added: synonyms-history-(backward|forward), synonyms-add-history-links, synonyms-link.
-;; Added: [Back] and [Forward] links.
-;; synonyms-show-synonyms: Put cursor on first synonym.
-;; synonyms-mouse, synonyms-lookup: Removed save-excursion.
-;; synonyms-mouse: Treat clicks on [Back] and [Forward] links too.
-;; synonyms-format-finish: Added save-excursion for last part: filling and adding mouse-face.
-;; synonyms-nearest-word: Remove text properties.
-;; synonyms: Use synonym-action.
-;; synonyms-lookup: When no synonyms found, remove search-text from history.
-;; Require cl.el when compile.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth
-;; ;; Floor, Boston, MA 02110-1301, USA.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Code:
-
-(eval-when-compile (when (< emacs-major-version 21) (require 'cl))) ;; push, pop
-
-(require 'thingatpt nil t) ;; (no error if not found): word-at-point
-(when (and (require 'thingatpt+ nil t);; (no error if not found): word-nearest-point
- (fboundp 'tap-put-thing-at-point-props)) ; >= 2012-08-21
- (tap-define-aliases-wo-prefix)
- (tap-put-thing-at-point-props))
-
-;; Quiet the byte-compiler.
-(defvar appendp) ; Here.
-(defvar morep) ; Here.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-
-;;; Faces (alphabetical) -----------------------------------
-
-;;;###autoload
-(defgroup Synonyms nil
- "Commands to look up synonyms in a thesaurus."
- :prefix "synonyms-"
- :group 'convenience :group 'help :group 'apropos :group 'matching
- :link `(url-link :tag "Send Bug Report"
- ,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\
-synonyms.el bug: \
-&body=Describe bug here, starting with `emacs -q'. \
-Don't forget to mention your Emacs and library versions."))
- :link '(url-link :tag "Other Libraries by Drew"
- "http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries")
- :link '(url-link :tag "Download" "http://www.emacswiki.org/cgi-bin/wiki/synonyms.el")
- :link '(url-link :tag "Description" "http://www.emacswiki.org/cgi-bin/wiki/Synonyms")
- :link '(emacs-commentary-link :tag "Commentary" "synonyms"))
-
-;;;###autoload
-(defface synonyms-heading '((((background dark)) (:foreground "Yellow"))
- (t (:foreground "Blue")))
- "*Face for different synonym types."
- :group 'Synonyms :group 'faces)
-
-;;;###autoload
-(defface synonyms-search-text '((t (:foreground "Red")))
- "*Face for the term whose synonyms were sought."
- :group 'Synonyms :group 'faces)
-
-;;;###autoload
-(defface synonyms-link '((((background dark)) (:foreground "Yellow" :underline t))
- (t (:foreground "Blue" :underline t)))
- "*Face for history links."
- :group 'Synonyms :group 'faces)
-
-;;;###autoload
-(defface synonyms-mouse-face '((((background dark)) (:background "DarkCyan"))
- (t (:background "Cyan")))
- "*Mouse face for the term whose synonyms were sought."
- :group 'Synonyms :group 'faces)
-
-
-
-
-;;; User Options (alphabetical) ----------------------------
-
-;;;###autoload
-(defcustom synonyms-append-result-flag nil
- "*t means that `synonyms' appends search result to previous results.
-No other value, besides t, has this effect.
-
-This can be overridden by using a negative prefix argument,
-for example, `M--'. If you use `C-u C-u', then both this and
-`synonyms-match-more-flag' are overridden."
- :type 'boolean :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-cache-file ""
- "*Location to write cache file containing synonyms.
-Written to save the list of synonyms used for completion.
-This is an absolute (complete-path) location, including the file name."
- :type '(file :must-match t) :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-file ""
- "*Location of thesaurus file `mthesaur.txt'.
-This is an absolute (complete-path) location, including the file name."
- :type '(file :must-match t) :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-fill-column 80
- "*Synonyms* buffer text is wrapped (filled) to this many columns."
- :type 'integer :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-match-more-flag nil
- "*t means additional thesaurus entries can be matched by `synonyms'.
-No other value, besides t, has this effect.
-
-A value of t means two things:
- 1) Input can match parts of synonyms, in addition to whole synonyms.
- 2) All synonyms are shown, even if input matches a thesaurus entry.
-
-This can be overridden by using a positive prefix argument,
- for example, `C-u'. If you use `C-u C-u', then both this and
-`synonyms-append-result-flag' are overridden."
- :type 'boolean :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-mode-hook nil
- "*Normal hook run when entering Thesaurus mode."
- :type 'hook :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-use-cygwin-flag nil
- "*Non-nil means to double backslashes in arguments to `call-process'.
-There is apparently a bug in the Emacs (at least versions 20-22) C
-code that implements function `call-process' on MS Windows. When
-using native Windows Emacs with Cygwin commands, such as `grep', the C
-code removes a level of backslashes, so string arguments supplied to
-`call-process' need to have twice as many backslashes as they should
-need. If you are using Emacs on Windows and Cygwin `grep', then you
-probably will want to use a non-nil value for
-`synonyms-use-cygwin-flag'."
- :type 'boolean :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-dictionary-url "http://dictionary.reference.com/search?q="
- "*URL of a Web dictionary lookup. Text to look up is appended to this.
-See also `synonyms-dictionaries-url'."
- :type 'string :group 'Synonyms)
-
-;;;###autoload
-(defcustom synonyms-dictionary-alternate-url "http://www.onelook.com/?ls=b&w="
- "*URL of a Web dictionary lookup. Text to look up is appended to this.
-The default value, \"http://www.onelook.com/?ls=b&w=\" lets you use `?'
-and `*' as wildcards in the terms you look up. These are not used as
-regexp wildcards, however. `?' stands for any single character, and
-`*' stands for any sequence of characters. In terms of regexp syntax,
-`?' here is equivalent to the regexp `.', and `*' is equivalent to the
-regexp `.*'. See http://www.onelook.com/?c=faq#patterns for more
-information on the allowed wildcard patterns.
-See also `synonyms-dictionary-url'."
- :type 'string :group 'Synonyms)
-
-;;; Internal variables (alphabetical) ----------------------
-
-(defvar synonyms-history nil "Minibuffer history list for thesaurus lookup.")
-
-(defvar synonyms-history-forward nil
- "Minibuffer history list for thesaurus lookup using `synonyms-history-backward'.")
-
-(defvar synonyms-list-for-obarray nil "List of synonyms to be used for completion")
-
-(defvar synonyms-mode-map nil "Keymap for `synonyms-mode'.")
-
-(unless synonyms-mode-map
- (let ((map (make-sparse-keymap "Synonyms")))
- (define-key map [(?d) (mouse-2)] 'synonyms-definition-mouse)
- (define-key map "d\r" 'synonyms-definition-no-read)
- (define-key map "s" 'synonyms)
- (define-key map [S-return] 'synonyms)
- (define-key map "\r" 'synonyms-no-read)
- (define-key map [C-return] 'synonyms-match-more-no-read)
- (define-key map [M-return] 'synonyms-append-result-no-read)
- (define-key map [C-M-return] 'synonyms-match-more+append-result-no-read)
- (define-key map [mouse-2] 'synonyms-mouse)
- (define-key map [C-mouse-2] 'undefined)
- (define-key map [C-down-mouse-2] 'synonyms-mouse-match-more) ; Get rid of `facemenu-mouse-menu'
- (define-key map [M-mouse-2] 'synonyms-mouse-append-result)
- (define-key map [C-M-mouse-2] 'synonyms-mouse-match-more+append-result)
- (define-key map "l" 'synonyms-history-backward) ; As in Info
- (define-key map "p" 'synonyms-history-backward) ; As in previous
- (define-key map "r" 'synonyms-history-forward) ; As in Info
- (define-key map "n" 'synonyms-history-forward) ; As in next
- (define-key map [mouse-4] 'synonyms-history-backward)
- (define-key map [mouse-5] 'synonyms-history-forward)
- (define-key map " " 'scroll-up) ; SPC
- (define-key map "\^?" 'scroll-down) ; DEL
- (define-key map "?" 'describe-mode)
- (define-key map "q" 'quit-window)
- (define-key map [menu-bar] (make-sparse-keymap))
- (define-key map [menu-bar synonyms] (cons "Synonyms" map))
- (define-key map [synonyms-help] '("Help" . describe-mode))
- (define-key map [synonyms-separator-2] '("--"))
- (define-key map [synonyms-next] '("Show Next" . synonyms-history-forward))
- (put 'synonyms-history-forward 'menu-enable 'synonyms-history-forward)
- (define-key map [synonyms-previous] '("Show Previous" . synonyms-history-backward))
- (put 'synonyms-history-backward 'menu-enable '(and synonyms-history (cdr synonyms-history)))
- (define-key map [synonyms-separator] '("--"))
- (define-key map [synonyms-more-append]
- '("Find (Max), Append Results" . synonyms-match-more+append-result))
- (define-key map [synonyms-append]
- '("Find, Append Results" . synonyms-append-result))
- (define-key map [synonyms-more] '("Find (Max)" . synonyms-match-more))
- (define-key map [synonyms-synonyms] '("Find" . synonyms))
- (setq synonyms-mode-map map)))
-
-;; 103307 is the smallest prime > 103304, which is the number of synonyms.
-(defvar synonyms-obarray (make-vector 103307 0)
- "Obarray of synonyms. Used for completion.")
-
-(defvar synonyms-search-text nil "Current text being looked up (matched).")
-
-
-
-
-;;; Functions ----------------------------------------------
-
-;;;###autoload
-(define-derived-mode synonyms-mode text-mode "Synonyms"
- "Major mode for browsing thesaurus entries (synonyms).
-Like Text mode but with these additional key bindings:
-
- \\<synonyms-mode-map>\\[synonyms-mouse], \\[synonyms-no-read], \\[synonyms] - \
-Look up synonyms for a word or phrase
- \\[synonyms-mouse-match-more], \\[synonyms-match-more] - Like \\[synonyms-no-read], but \
-try to match more terms
- \\[synonyms-mouse-append-result], \\[synonyms-append-result] - Like \\[synonyms-no-read], but \
-add result to previous result
- \\[synonyms-mouse-match-more+append-result], \\[synonyms-match-more+append-result] - Like \
-\\[synonyms-match-more] and \\[synonyms-append-result] combined
-
- \\[scroll-up] - Scroll down through the buffer of synonyms
- \\[scroll-down] - Scroll up through the buffer of synonyms
- \\[describe-mode] - Display this help
- \\[quit-window] - Quit Synonyms mode
-
-Of the various key bindings that look up synonyms, the most flexible
-is \\[synonyms] - it prompts you for the search string to match. This
-can be a regular expression (regexp). The other lookup bindings are
-for convenience - just click.
-
-In Synonyms mode, Transient Mark mode is enabled.
-
-Options `synonyms-match-more-flag' and `synonyms-append-result-flag'
-affect synonym matching and the results. For convenience, \\[synonyms-mouse-match-more],
-\\[synonyms-mouse-append-result], and \\[synonyms-mouse-match-more+append-result] \
-toggle the effect of those options for the
-duration of the command.
-
-Note that even though Synonyms mode is similar to Text mode, buffer
-`*Synonyms*' is read-only, by default - use `C-x C-q' to toggle.
-
-Turning on Synonyms mode runs the normal hooks `text-mode-hook' and
-`synonyms-mode-hook' (in that order)."
-
- ;; Synonyms to account for:
- ;; `$', `1', `0': $100-a-plate dinner; `2': catch-22, V-2; `3': 3-D; `9': strontium 90.
- ;; To match `$', you will of course need to escape it: `\$'.
- (modify-syntax-entry ?- "w" synonyms-mode-syntax-table) ; Make hyphen (-) a word character.
- (modify-syntax-entry ?1 "w" synonyms-mode-syntax-table) ; Make numerals 1,2,3,9,0 word characters.
- (modify-syntax-entry ?2 "w" synonyms-mode-syntax-table)
- (modify-syntax-entry ?3 "w" synonyms-mode-syntax-table)
- (modify-syntax-entry ?9 "w" synonyms-mode-syntax-table)
- (modify-syntax-entry ?0 "w" synonyms-mode-syntax-table)
- (modify-syntax-entry ?$ "w" synonyms-mode-syntax-table) ; Make dollar ($) a word character.
- (buffer-disable-undo)
- (setq fill-column synonyms-fill-column)
- (set (make-local-variable 'transient-mark-mode) t))
-
-;;;###autoload
-(defun synonyms-ensure-synonyms-read-from-cache ()
- "Ensure synonyms are in `synonyms-obarray', from `synonyms-cache-file'.
-If this file does not yet exist, then it and the obarray are created.
-Creating the obarray for the first time takes 2-3 minutes.
-This does nothing if the obarray is already complete."
- (interactive)
- (unless (intern-soft "synonym" synonyms-obarray) ; Do nothing if already complete.
- (setq synonyms-list-for-obarray () ; Just to make sure.
- synonyms-cache-file (expand-file-name synonyms-cache-file))
- (if (synonyms-file-readable-p synonyms-cache-file)
- (let ((list-buf (find-file-noselect synonyms-cache-file 'nowarn 'raw))
- (obarray synonyms-obarray))
- (unwind-protect
- (setq synonyms-list-for-obarray (read list-buf))
- (kill-buffer list-buf)))
- (synonyms-make-obarray) ; Create obarray from scratch
- (synonyms-write-synonyms-to-cache)))) ; and write it out, for next time.
-
-;;;###autoload
-(defun synonyms-make-obarray ()
- "Fill `synonyms-obarray' with the available synonyms."
- (interactive)
- (unless (intern-soft "synonym" synonyms-obarray) ; Do nothing if already complete.
- (synonyms-define-synonyms-file)
- (with-temp-message "Building synonyms list for completion. This will take a few minutes..."
- (let ((thesaurus-buf (find-file-noselect synonyms-file 'nowarn 'raw))
- synonym)
- (unwind-protect
- (save-current-buffer
- (set-buffer thesaurus-buf)
- (goto-char (point-min))
- (synonyms-mode) ; To use the modified syntax table.
- (while (re-search-forward "\\(\\(\\w\\|[ ]\\)+\\)\\(,\\|$\\)" nil t)
- (setq synonym (buffer-substring (match-beginning 1) (match-end 1)))
- (intern synonym synonyms-obarray)))
- (kill-buffer thesaurus-buf))))))
-
-(defun synonyms-define-synonyms-file ()
- "Prompt user to define `synonyms-file', unless it is readable."
- (setq synonyms-file (expand-file-name synonyms-file))
- (unless (synonyms-file-readable-p synonyms-file)
- (while (not (synonyms-file-readable-p synonyms-file))
- (setq synonyms-file (read-file-name "Thesaurus file: " nil nil 'confirm "mthesaur.txt")))
- (custom-set-variables (list 'synonyms-file
- (setq synonyms-file (expand-file-name synonyms-file))
- 'now))))
-
-;;;###autoload
-(defun synonyms-write-synonyms-to-cache ()
- "Write synonyms in `synonyms-obarray' to file `synonyms-cache-file'."
- (interactive)
- (synonyms-define-cache-file)
- (with-temp-message "Writing synonyms cache file..."
- (with-temp-file synonyms-cache-file
- (mapatoms (lambda (symb) (push symb synonyms-list-for-obarray)) synonyms-obarray)
- (prin1 synonyms-list-for-obarray (current-buffer)))))
-
-(defun synonyms-define-cache-file ()
- "Prompt user to define `synonyms-cache-file', unless it is writable."
- (unless (synonyms-file-writable-p synonyms-cache-file)
- (while (not (synonyms-file-writable-p synonyms-cache-file))
- (setq synonyms-cache-file
- (read-file-name "Cache file: "
- (expand-file-name (file-name-directory synonyms-file)) nil nil
- (concat (file-name-nondirectory synonyms-file) ".cache"))))
- (custom-set-variables (list 'synonyms-cache-file
- (setq synonyms-cache-file (expand-file-name synonyms-cache-file))
- 'now))))
-
-(defun synonyms-file-readable-p (file)
- "Return non-nil if FILE (a string) names a readable file."
- (and (not (string= "" file)) (file-readable-p file) (not (file-directory-p file))))
-
-(defun synonyms-file-writable-p (file)
- "Return non-nil if FILE (a string) names a writable file."
- (and (not (string= "" file)) (file-writable-p file) (not (file-directory-p file))))
-
-(defun synonyms (&optional arg regexp)
- "Show synonyms that match a regular expression (e.g. a word or phrase).
-You are prompted for the regexp. By default, it is the text
-of the region, if it is active and `transient-mark-mode' is enabled,
-or the nearest word to the cursor, if not.
-
-Option `synonyms-match-more-flag' non-nil means additional thesaurus
- entries can be matched. This can be more time-consuming. It means
- two things:
-
- 1) Input can match parts of synonyms, in addition to whole synonyms.
- 2) All synonyms are shown, even if input matches a thesaurus entry.
-
-Option `synonyms-append-result-flag' non-nil means to append search
- result to previous results.
-
-A prefix argument toggles the meaning of each of those options for the
-duration of the command:
-
- If `C-u' or `C-u C-u', then toggle `synonyms-match-more-flag'.
- If negative or `C-u C-u', then toggle `synonyms-append-result-flag'.
-
-\(`C-u C-u' thus means toggle both options.)
-
-When called from Lisp, optional second argument REGEXP is the regexp
-to match (no prompting)."
- (interactive "P")
- (synonyms-ensure-synonyms-read-from-cache) ; Fill `synonyms-obarray', for use in completion.
- (let* ((num-arg (prefix-numeric-value arg))
- (morep (eq synonyms-match-more-flag (atom arg)))
- (appendp (eq synonyms-append-result-flag (and (wholenump num-arg)
- (/= 16 num-arg))))
- (default-search-text (or regexp (synonyms-default-regexp)))
- (search-text (or regexp
- (let ((case-fold-search t)) ; Case-insensitive completion.
- (completing-read
- "Show synonyms for word or phrase (regexp): "
- synonyms-obarray nil nil nil 'synonyms-history
- default-search-text)))))
- (synonyms-action search-text)))
-
-(defun synonyms-action (search-text)
- "Helper function for command `synonyms'.
-APPENDP and MOREP are free here."
- (setq synonyms-search-text search-text) ; Save it.
- (when (string= "" search-text) (error "No text to look up"))
- (unless (member search-text synonyms-history) (push search-text synonyms-history))
- ;; Change `.' to `[^,]' in `search-text', so we don't mix terms.
- (setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
- (synonyms-lookup search-text (and (boundp 'appendp) appendp) (and (boundp 'morep) morep)))
-
-;;;###autoload
-(defun synonyms-no-read (arg)
- "Same as command `synonyms', but uses the default input text (regexp)."
- (interactive "P")
- (let* ((num-arg (prefix-numeric-value arg))
- (morep (eq synonyms-match-more-flag (atom arg)))
- (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg))))
- (search-text (synonyms-default-regexp)))
- (setq synonyms-search-text search-text) ; Save it.
- (when (string= "" search-text) (error "No text to look up"))
- (unless (member search-text synonyms-history) (push search-text synonyms-history))
- ;; Change `.' to `[^,]' in `search-text', so we don't mix terms.
- (setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
- (synonyms-lookup search-text appendp morep)))
-
-;;;###autoload
-(defun synonyms-match-more ()
- "Same as using `synonyms' with `synonyms-match-more-flag' = t."
- (interactive)
- (let ((synonyms-match-more-flag t))
- (synonyms)))
-
-;;;###autoload
-(defun synonyms-match-more-no-read (arg)
- "Same as using `synonyms' with `synonyms-match-more-flag' = t."
- (interactive "P")
- (let ((synonyms-match-more-flag t))
- (synonyms-no-read arg)))
-
-;;;###autoload
-(defun synonyms-append-result ()
- "Same as using `synonyms' with `synonyms-append-result-flag' = t."
- (interactive)
- (let ((synonyms-append-result-flag t))
- (synonyms)))
-
-;;;###autoload
-(defun synonyms-append-result-no-read (arg)
- "Same as using `synonyms' with `synonyms-append-result-flag' = t."
- (interactive "P")
- (let ((synonyms-append-result-flag t))
- (synonyms-no-read arg)))
-
-;;;###autoload
-(defun synonyms-match-more+append-result ()
- "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
- (interactive)
- (let ((synonyms-match-more-flag t)
- (synonyms-append-result-flag t))
- (synonyms)))
-
-;;;###autoload
-(defun synonyms-match-more+append-result-no-read (arg)
- "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
- (interactive "P")
- (let ((synonyms-match-more-flag t)
- (synonyms-append-result-flag t))
- (synonyms-no-read arg)))
-
-;;;###autoload
-(defun synonyms-mouse (event arg)
- "Show synonyms that match a regular expression (e.g. a word or phrase).
-The regexp to match is the synonym or region clicked with mouse-2. If
-the region is active, but a synonym elsewhere is clicked, that synonym
-is used, not the selected text.
-
-You can either click a listed synonym, to see its synonyms, or select
-one or more words and click the selection, to see matching synonyms.
-To quickly select a series of words: double-click mouse-1 to select
-the first word, then click mouse-3 to extend the selection to the last
-word.
-
-Selection is useful when you want to see synonyms of a similar term.
-For example, instead of clicking the listed synonym `bleeding heart', you
-might select `heart' and click that.
-
-The prefix argument acts the same as for command `synonyms'.
-
-If you click a history link with mouse-2, previously retrieved search
-results are revisited."
- (interactive "e\nP")
- (set-buffer (window-buffer (posn-window (event-end event))))
- (let ((beg (region-beginning))
- (end (region-end))
- (active mark-active))
- (goto-char (posn-point (event-end event)))
- (cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
- ((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
- (t (if (and active (> (point) beg) (< (point) end))
- (goto-char end)
- (deactivate-mark)) ; User did not click inside region, so deactivate it.
- (synonyms-no-read arg)))))
-
-;;;###autoload
-(defun synonyms-mouse-match-more (event arg)
- "Same as `synonyms-mouse' with `synonyms-match-more-flag' = t."
- (interactive "e\nP")
- (let ((synonyms-match-more-flag t))
- (synonyms-mouse event arg)))
-
-;;;###autoload
-(defun synonyms-mouse-append-result (event arg)
- "Same as `synonyms-mouse' with `synonyms-append-result-flag' = t."
- (interactive "e\nP")
- (let ((synonyms-append-result-flag t))
- (synonyms-mouse event arg)))
-
-;;;###autoload
-(defun synonyms-mouse-match-more+append-result (event arg)
- "Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
- (interactive "e\nP")
- (let ((synonyms-match-more-flag t)
- (synonyms-append-result-flag t))
- (synonyms-mouse event arg)))
-
-(defun synonyms-default-regexp ()
- "Return the default regexp for `synonym' and `synonyms-mouse'.
-If the region is active in `transient-mark-mode', use its text.
-Else, if this is *Synonyms* buffer, use the synonym under the cursor.
-Else use the word nearest the cursor.
-
-An active region has no effect except in `transient-mark-mode'."
- (if (and mark-active transient-mark-mode) ; Use region text, if active.
- (buffer-substring-no-properties (point) (mark))
- (if (eq major-mode 'synonyms-mode) ; Use mouse-face text, if in synonyms-mode.
- (let (beg end)
- (when (and (not (eobp)) (get-text-property (point) 'mouse-face))
- (setq end (point)
- beg (1+ (point))))
- (when (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
- (setq end (1- (point))
- beg (point)))
- (if (null beg)
- (synonyms-nearest-word) ; Punt - no mouse-face, for some reason.
- (setq beg (previous-single-property-change beg 'mouse-face)
- end (or (next-single-property-change end 'mouse-face) (point-max)))
- (replace-regexp-in-string ; Replace newlines with spaces, except at the
- "\\(^ \\| $\\)" "" ; beginning and end.
- (replace-regexp-in-string "[\n]" " " (buffer-substring-no-properties beg end) nil t)
- nil t)))
- (synonyms-nearest-word))))
-
-(defun synonyms-nearest-word ()
- "Word nearest the cursor."
- (let ((word (if (fboundp 'word-nearest-point)
- (word-nearest-point) ; In `thingatpt+.el'.
- (word-at-point)))) ; In `thingatpt.el'.
- (set-text-properties 0 (length word) nil word) ; Remove all text properties.
- word))
-
-(defun synonyms-lookup (search-text appendp morep)
- "Search the thesaurus for SEARCH-TEXT.
-APPEND-P non-nil means to append search result to previous results.
-MORE-P non-nil means additional thesaurus entries can be matched."
- (save-selected-window
- (with-temp-message
- (format "Looking up %s synonyms for \"%s\"%s..." (if morep "(max)" "")
- (replace-regexp-in-string (regexp-quote "[^,]") "." search-text nil t)
- (if appendp " (appending)" ""))
- (let ((temp-buf (generate-new-buffer " *Temp*")))
- (unwind-protect
- (progn
- (set-buffer temp-buf)
- (buffer-disable-undo) ; Make sure (should already be, because of *Temp* name).
- (erase-buffer)
- (let ((entry-p (synonyms-search-entries search-text temp-buf morep)))
- ;; For `morep' search, we don't stop even if we find an entry.
- (unless (if morep
- (or (synonyms-search-synonyms search-text temp-buf t) entry-p)
- (or entry-p (synonyms-search-synonyms search-text temp-buf nil)))
- (pop synonyms-history) ; Remove it from search history, so we don't try again.
- (error "No synonyms found for `%s'" search-text))
- (let ((results-buf (get-buffer-create "*Synonyms*")))
- (synonyms-format-synonyms search-text morep)
- (synonyms-show-synonyms temp-buf results-buf appendp)
- (message nil))))
- (kill-buffer temp-buf))))))
-
-(defun synonyms-search-entries (search-text buf morep)
- "Search thesaurus entries (headings) for SEARCH-TEXT.
-Put result in buffer BUF.
-MORE-P non-nil means additional thesaurus entries can be matched."
- (call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
- (if morep
- (format "^\\w*%s\\w*," search-text)
- (format "^%s," search-text)))
- (expand-file-name synonyms-file))
- (not (zerop (count-lines (point-min) (point-max)))))
-
-(defun synonyms-search-synonyms (search-text buf morep)
- "Search thesaurus body for SEARCH-TEXT.
-SEARCH-TEXT is a regexp that can match any part of a thesaurus term.
-Put result in buffer BUF.
-MORE-P non-nil means additional thesaurus entries can be matched."
- (call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
- (if morep
- (format ",\\w*%s\\w*\\(,\\|$\\)" search-text)
- (format ",%s\\(,\\|$\\)" search-text)))
- (expand-file-name synonyms-file))
- (not (zerop (count-lines (point-min) (point-max)))))
-
-(defun synonyms-hack-backslashes-if-cygwin (string)
- "Double each backslash in STRING, unless it contains SPC characters.
-More precisely, if `synonyms-use-cygwin-flag' is non-nil and this is
-Emacs 20 or there are no spaces in STRING, then double any backslashes
-in STRING.
-
-This is an ugly hack made necessary because of bugs in Emacs C code."
- (when (and synonyms-use-cygwin-flag
- (or (= emacs-major-version 20) (not (string-match " " string))))
- (setq string (replace-regexp-in-string "[\\]" "\\\\" string nil t)))
- string)
-
-(defun synonyms-format-synonyms (search-text morep)
- "Format synonyms that match SEARCH-TEXT.
-MORE-P non-nil means additional thesaurus entries can be matched."
- (goto-char (point-min))
- (let ((entries-count (count-lines (point-min) (point-max))))
- (if (= entries-count 1)
- (synonyms-format-entry search-text t morep)
- (synonyms-format-entries search-text entries-count morep))
- (synonyms-format-finish search-text morep)))
-
-(defun synonyms-format-entry (search-text single-p morep)
- "Format a single thesaurus entry that matches SEARCH-TEXT.
-SINGLE-P non-nil means there is only one entry."
- (beginning-of-line)
- (let ((beg (point))
- (orig (if morep ; Use saved search text.
- (format "\\w*\\(%s\\)\\w*" synonyms-search-text)
- (format "\\(%s\\)" synonyms-search-text)))
- (entry-p nil)
- term end)
- (when single-p (insert "Synonyms for "))
- (setq term (point))
- (when (looking-at orig) (setq entry-p t))
- (unless (search-forward "," nil t) (error "Bad thesaurus file - no commas"))
- (setq end (match-beginning 0))
- (replace-match ":\n\n" nil t)
- (cond (single-p
- (add-text-properties beg term '(face synonyms-heading))
- (add-text-properties term end (if entry-p
- '(face synonyms-search-text
- mouse-face synonyms-mouse-face)
- '(face synonyms-heading)))
- (add-text-properties end (+ 2 end) '(face synonyms-heading)))
- (t
- (add-text-properties beg (1+ end) '(face synonyms-heading))
- (save-excursion
- (forward-line -2)
- (save-restriction
- (narrow-to-region (point) (save-excursion (end-of-line) (backward-char) (point)))
- (unless (search-forward ". " nil t)
- (error "Badly formatted numeric entry - no period"))
- (add-text-properties (point) (point-max) '(mouse-face synonyms-mouse-face))
- (when (looking-at orig)
- (add-text-properties (match-beginning 1) (match-end 1)
- '(face synonyms-search-text)))))))
- (forward-line)))
-
-(defun synonyms-format-entries (search-text entries-count morep)
- "Format thesaurus entries that have synonyms matching SEARCH TEXT.
-ENTRIES-COUNT is the number of entries.
-MORE-P non-nil means additional thesaurus entries can be matched."
- (let ((countdown entries-count)
- (beg (point))
- (part1 "Synonyms for ")
- (part2 ":\n"))
- (insert part1 synonyms-search-text part2)
- (add-text-properties beg (setq beg (+ beg (length part1))) '(face synonyms-heading))
- (add-text-properties beg (setq beg (+ beg (length synonyms-search-text)))
- '(face synonyms-search-text mouse-face synonyms-mouse-face))
- (add-text-properties beg (+ beg (length part2)) '(face synonyms-heading))
- (while (> countdown 0)
- (setq countdown (1- countdown))
- (insert (format "\n\%s. " (- entries-count countdown)))
- (synonyms-format-entry search-text nil morep))))
-
-(defun synonyms-format-finish (search-text morep)
- "Finish formatting synonyms matching SEARCH-TEXT.
-MORE-P non-nil means additional thesaurus entries can be matched."
- ;; Put a space after each comma.
- (goto-char (point-min))
- (forward-line) ; First line might have [^,] in it.
- (while (search-forward "," nil t) (replace-match ", " nil t))
- (goto-char (point-min))
- (let ((case-fold-search t)
- (new-search-text (if morep
- (format "\\(^\\|, \\)\\w*\\(%s\\)\\w*\\($\\|,\\)" search-text)
- (format "\\(^\\|, \\)\\(%s\\)\\($\\|,\\)" search-text)))
- (no-numbered-headers-p (not (re-search-forward "^[0-9]+[.]" nil t))))
- (goto-char (point-min))
- (forward-line)
- (while (re-search-forward new-search-text nil t)
- (add-text-properties (match-beginning 2) (match-end 2) '(face synonyms-search-text))
- (goto-char (match-end 2)))
- ;; Do `synonyms-mode' here too, so hyphen will be a word char.
- ;; IS THERE A WAY TO DO A LET to change the syntax of hyphen, instead of entering mode?
- (synonyms-mode)
- (save-excursion
- (goto-char (point-min))
- (forward-line)
- (while (re-search-forward "\\(^\\|, \\)\\(\\(\\w\\|[\\t ]\\)+\\)\\($\\|,\\)" nil t)
- (add-text-properties (match-beginning 2) (match-end 2) '(mouse-face synonyms-mouse-face))
- (goto-char (match-end 2)))
- (fill-region (point-min) (point-max)))
- (synonyms-add-history-links)))
-
-(defun synonyms-add-history-links ()
- "Add Back and Forward chronological navigation links"
- (save-excursion
- (unless (re-search-backward "Synonyms for") (error "No \"Synonyms for\" text"))
- (end-of-line)
- (insert (make-string (- fill-column 16 (point)) ?\ ) "[")
- (let ((beg (point))
- (Back "Back")
- (spacer "] [")
- (Forward "Forward"))
- (insert Back)
- (add-text-properties beg (point)
- '(face synonyms-link mouse-face synonyms-mouse-face back-link t
- help-echo "mouse-2, RET: Go backward in synonyms search history"))
- (insert spacer Forward)
- (add-text-properties (+ beg (length Back) (length spacer)) (point)
- '(face synonyms-link mouse-face synonyms-mouse-face forward-link t
- help-echo "mouse-2, RET: Go forward in synonyms search history"))
- (insert "]"))))
-
-(defun synonyms-show-synonyms (temp-buf results-buf appendp)
- "Display search results from buffer TEMP-BUF in buffer RESULTS-BUF.
-If APPEND-P is non-nil and RESULTS-BUF is not empty, then insert a
-separator line between previous search results and the current results."
- (set-buffer results-buf)
- (setq buffer-read-only nil)
- (unless (= (point-min) (point-max))
- (if (not appendp)
- (erase-buffer)
- (goto-char (point-max))
- (let ((beg (point)))
- (insert "\n" (make-string (1- (window-width)) ?_) "\n\n\n")
- (add-text-properties beg (point) '(face synonyms-heading)))))
- (let ((start-result (point)))
- (insert-buffer temp-buf)
- (select-window (display-buffer results-buf))
- (goto-char start-result)
- (forward-line 2) ; Put cursor on first synonym.
- (when (looking-at "^[0-9]. ") (goto-char (match-end 0)))
- (recenter 2)
- (synonyms-mode)
- (setq buffer-read-only t)))
-
-;;;###autoload
-(defun synonyms-history-backward (arg)
- "Run `synonyms' on a previous argument, moving backward in the history.
-A prefix argument has the same meaning as for command `synonyms'."
- (interactive "P")
- (unless (cdr synonyms-history) (error "Cannot move backward in history"))
- (push (pop synonyms-history) synonyms-history-forward) ; Put current on forward list.
- (let* ((num-arg (prefix-numeric-value arg))
- (morep (eq synonyms-match-more-flag (atom arg)))
- (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
-
- ;; Visit last. If *Synonyms* has appended search results, go to the previous one, from (point).
- (if (not (get-buffer "*Synonyms*"))
- (synonyms-action (car synonyms-history))
- (let ((divider (with-current-buffer "*Synonyms*" (re-search-backward "^___" nil t))))
- (if (not divider)
- (synonyms-action (car synonyms-history))
- (set-buffer "*Synonyms*")
- (goto-char divider)
- (unless (re-search-backward "^Synonyms for \\([^:]+\\):" nil t)
- (error "Cannot find previous synonyms page"))
- (goto-char (match-beginning 1))
- (recenter 0)
- (message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
-
-;;;###autoload
-(defun synonyms-history-forward (arg)
- "Run `synonyms' on a previous argument, moving forward in the history.
-A prefix argument has the same meaning as for command `synonyms'."
- (interactive "P")
- (unless synonyms-history-forward (error "Cannot move forward in history"))
- (push (pop synonyms-history-forward) synonyms-history) ; Put current on backward list.
- (let* ((num-arg (prefix-numeric-value arg))
- (morep (eq synonyms-match-more-flag (atom arg)))
- (appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
-
- ;; Visit current. If *Synonyms* has appended search results, go to the next one, from (point).
- (if (not (get-buffer "*Synonyms*"))
- (synonyms-action (car synonyms-history))
- (let ((divider (with-current-buffer "*Synonyms*" (re-search-forward "^___" nil t))))
- (if (not divider)
- (synonyms-action (car synonyms-history))
- (set-buffer "*Synonyms*")
- (goto-char divider)
- (unless (re-search-forward "^Synonyms for \\([^:]+\\):" nil t)
- (error "Cannot find next synonyms page"))
- (goto-char (match-beginning 1))
- (recenter 0)
- (message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
-
-;;;###autoload
-(defalias 'dictionary-definition 'synonyms-definition)
-;;;###autoload
-(defun synonyms-definition (search-text alternate-p)
- "Look up the definition of a word or phrase using online dictionaries.
-The dictionary used is `synonyms-dictionary-url'.
-With prefix arg, look up the definition in the alternate dictionary,
-`synonyms-dictionary-alternate-url'."
- (interactive (list (completing-read "Look up definition of word or phrase (regexp): "
- synonyms-obarray nil nil nil 'synonyms-history
- (synonyms-default-regexp))
- current-prefix-arg))
- (synonyms-ensure-synonyms-read-from-cache) ; Fill `synonyms-obarray', for use in completion.
- (browse-url (concat (if alternate-p synonyms-dictionary-alternate-url synonyms-dictionary-url)
- search-text)))
-
-;;;###autoload
-(defun synonyms-definition-no-read (alternate-p)
- "Look up the definition of a word or phrase using online dictionaries.
-The dictionary used is `synonyms-dictionary-url'.
-With prefix arg, look up the definition in the alternate dictionary,
-`synonyms-dictionary-alternate-url'."
- (interactive "P")
- (synonyms-definition (synonyms-default-regexp) alternate-p))
-
-;;;###autoload
-(defun synonyms-definition-mouse (event alternate-p)
- "Look up the definition of a word or phrase using online dictionaries.
-The dictionary used is `synonyms-dictionary-url'.
-With prefix arg, look up the definition in the alternate dictionary,
-`synonyms-dictionary-alternate-url'."
- (interactive "e\nP")
- (set-buffer (window-buffer (posn-window (event-end event))))
- (let ((beg (region-beginning))
- (end (region-end))
- (active mark-active))
- (goto-char (posn-point (event-end event)))
- (cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
- ((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
- (t (if (and active (> (point) beg) (< (point) end))
- (goto-char end)
- (deactivate-mark)) ; User did not click inside region, so deactivate it.
- (synonyms-definition (synonyms-default-regexp) alternate-p)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(provide 'synonyms)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; synonyms.el ends here
+++ /dev/null
-;;; template.el --- use templates, decorate comments, auto-update buffers
-
-;; Copyright (C) 1995-2003 Free Software Foundation, Inc.
-;;
-;; Author: Christoph Wedler <wedlerNOSPAMusers.sourceforge.net>
-;; Version: (see `template-version' below)
-;; Keywords: template, comment decoration, auto-updating, data, tools
-;; X-URL: http://emacs-template.sourceforge.net/
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; When you create a new file with Emacs, package Template supplies an initial
-;; buffer content via a template: a file with normal text and expansion
-;; forms. There is a menu to easily create such templates. You can also use new
-;; commands to decorate comments and update the buffer contents.
-
-;; The main difference between Template and other similar packages is that you
-;; can define very flexible templates without having to learn Lisp or changing
-;; your Emacs init file. This package does not help Lisp programmers to define
-;; complex macros.
-
-;; For details, check <http://emacs-template.sourceforge.net/> or, if you
-;; prefer the manual style, the documentation of the following commands and
-;; variables:
-;;
-;; * for templates: \\[template-new-file], `template-auto-insert',
-;; `template-derivation-alist', `template-default-expansion-alist' and
-;; `template-definition-start',
-;; * for comment decoration: \\[template-single-comment] and
-;; \\[template-block-comment], `template-comment-specification-alist'
-;; * for updating: \\[template-update-buffer], `template-auto-update',
-;; `template-update-buffer-alist' and `template-header-regexp-alist'.
-
-;; Bug fixes, bug reports, improvements, and suggestions for the newest version
-;; are strongly appreciated.
-
-;;; Installation:
-
-;; This file requires Emacs-20.2, XEmacs-20.2 or higher.
-
-;; Put this file into your load-path and the following into your ~/.emacs:
-;; (require 'template)
-;; (template-initialize)
-
-;; You might want to add another item to the "File" menu by (in XEmacs):
-;; (add-menu-button '("File")
-;; ["Insert and Expand Template..."
-;; template-expand-template
-;; :active (not buffer-read-only)]
-;; "Insert File...")
-
-;; To customize, use `M-x customize-group RET template RET' or the customize
-;; entry in menu Options.
-
-;;; Code:
-
-(provide 'template)
-(require 'custom)
-
-;; General Emacs/XEmacs-compatibility compile-time macros
-(eval-when-compile
- (require 'cl)
- (defmacro cond-emacs-xemacs (&rest args)
- (cond-emacs-xemacs-macfn
- args "`cond-emacs-xemacs' must return exactly one element"))
- (defun cond-emacs-xemacs-macfn (args &optional msg)
- (if (atom args) args
- (and (eq (car args) :@) (null msg) ; (:@ ...spliced...)
- (setq args (cdr args)
- msg "(:@ ....) must return exactly one element"))
- (let ((ignore (if (string-match "XEmacs" emacs-version) :EMACS :XEMACS))
- (mode :BOTH) code)
- (while (consp args)
- (if (memq (car args) '(:EMACS :XEMACS :BOTH)) (setq mode (pop args)))
- (if (atom args)
- (or args (error "Used selector %s without elements" mode))
- (or (eq ignore mode)
- (push (cond-emacs-xemacs-macfn (car args)) code))
- (pop args)))
- (cond (msg (if (or args (cdr code)) (error msg) (car code)))
- ((or (null args) (eq ignore mode)) (nreverse code))
- (t (nconc (nreverse code) args))))))
- ;; Emacs/XEmacs-compatibility `defun': remove interactive "_" for Emacs, use
- ;; existing functions when they are `fboundp', provide shortcuts if they are
- ;; known to be defined in a specific Emacs branch (for short .elc)
- (defmacro defunx (name arglist &rest definition)
- (let ((xemacsp (string-match "XEmacs" emacs-version)) reuses first)
- (while (memq (setq first (car definition))
- '(:try :emacs-and-try :xemacs-and-try
- :emacs-only :xemacs-only))
- (if (memq first (if xemacsp
- '(:xemacs-and-try :xemacs-only)
- '(:emacs-and-try :emacs-only)))
- (setq reuses (cadr definition)
- definition nil)
- (unless (memq first '(:emacs-only :xemacs-only))
- (push (cadr definition) reuses)))
- (setq definition (cddr definition)))
- (if (and reuses (symbolp reuses))
- `(defalias ',name ',reuses)
- (let* ((docstring (if (stringp (car definition)) (pop definition)))
- (spec (and (not xemacsp)
- (eq (car-safe (car definition)) 'interactive)
- (null (cddar definition))
- (cadar definition))))
- (if (and (stringp spec)
- (not (string-equal spec ""))
- (eq (aref spec 0) ?_))
- (setq definition
- (cons (if (string-equal spec "_")
- '(interactive)
- `(interactive ,(substring spec 1)))
- (cdr definition))))
- (if (null reuses)
- `(defun ,name ,arglist ,docstring
- ,@(cond-emacs-xemacs-macfn definition))
- ;; no dynamic docstring in this case
- `(eval-and-compile ; no warnings in Emacs
- (defalias ',name
- (cond ,@(mapcar (lambda (func) `((fboundp ',func) ',func))
- (nreverse reuses))
- (t ,(if definition
- `(lambda ,arglist ,docstring
- ,@(cond-emacs-xemacs-macfn definition))
- 'ignore)))))))))))
-
-(eval-when-compile
- (require 'cl)
- (defvar init-file-loaded) ; would be useful in Emacs, too...
- (defvar file-name-buffer-file-type-alist))
-
-
-\f
-;;;;##########################################################################
-;;;; User Options, Variables
-;;;;##########################################################################
-
-
-(defconst template-version "3.1c"
- "Current version of package template.
-Check <http://emacs-template.sourceforge.net/> for the newest.")
-
-
-;;;===========================================================================
-;;; Customization and initialization
-;;;===========================================================================
-
-(defgroup template nil
- "Use templates, decorate comments, auto-update buffers."
- :group 'data
- :link '(emacs-commentary-link "template.el")
- :link '(url-link "http://emacs-template.sourceforge.net/")
- :prefix "template-")
-
-(defgroup template-comments nil
- "Comment decorations in package template."
- :group 'template
- :prefix "template-")
-
-(defgroup template-updating nil
- "Updating with package template."
- :group 'template
- :prefix "template-")
-
-(defgroup template-derivation nil
- "Deriving templates for new files."
- :group 'template
- :prefix "template-")
-
-(defgroup template-expansion nil
- "Expanding the expansion forms in templates."
- :group 'template
- :prefix "template-")
-
-(defgroup template-miscellaneous nil
- "Miscellaneous configurations of package template."
- :group 'template
- :prefix "template-")
-
-;; I could imagine that a future version of package custom could make this
-;; `PACKAGE-initialize' stuff easier
-(defcustom template-use-package nil
- "Pseudo variable. Used to initialize template in custom buffer.
-Put `(template-initialize)' into your ~/.emacs to initialize package
-template in future sessions. See variable `template-initialize'."
- :group 'template
- :type '(boolean :format "%{%t%}: %[(template-initialize)%], %v\n"
- :on "in use" :off "not yet initialized"
- :help-echo "Initialize package Template."
- :action template-initialize))
-
-(defcustom template-initialize t
- "Whether/what to initialize with `template-initialize'.
-If t, do full initialization. Otherwise, the value should be a list
-with elements. To enable, include
-
- * `auto' to enable `template-auto-update' and `template-auto-insert',
- * `ffap' to make sure that `auto' works with `find-file-at-point',
- * `cc-mode' to enable correct C/C++/Java/Antlr comment filling, i.e.,
- to add `template-c-init-fill-function' to `c-mode-common-hook',
- * `de-html-helper' to disable `html-helper's template and time-stamps,
- * `keys' to setup the default key bindings,
- * `menus' to setup the menus."
- :group 'template-miscellaneous
- :type '(choice (const :tag "All" t)
- (set :value (auto cc-mode keys menus)
- (const :tag "Auto Updating/Inserting" auto)
- (const :tag "Correct Auto Inserting with Ffap" ffap)
- (const :tag "Correct C Comment Filling" cc-mode)
- (const :tag "Deactivate html-helper" de-html-helper)
- (const :tag "Setup Key Bindings" keys)
- (const :tag "Setup Menus" menus))))
-
-
-;;;===========================================================================
-;;; Menu
-;;;===========================================================================
-
-(defvar template-comment-menu
- '("Comment"
- ["Decorate Comment Line" template-single-comment
- :active (and (not buffer-read-only)
- (memq (template-comment-at-point)
- '(none delimited single cont)))]
- ["Decorate Comment Block" template-block-comment
- :active (and (not buffer-read-only)
- (memq (template-comment-at-point)
- '(single block)))]
- "---"
- ["Indent for Comment" indent-for-comment
- :active (and comment-start (not buffer-read-only))]
- ["Continue Comment" indent-new-comment-line
- :active (and comment-start (not buffer-read-only))]
- ["Comment Region" comment-region
- :active (and comment-start (not buffer-read-only) (mark))]
- ["Comment Region 2" (comment-region 2)
- :active (and comment-start (not buffer-read-only) (mark))]
- ["Comment Region 3" (comment-region 3)
- :active (and comment-start (not buffer-read-only) (mark))]
- "---"
- ["Update Buffer" template-update-buffer
- :active (and template-update-buffer-alist (not buffer-read-only))])
- "Menu for comment functions.")
-
-(defvar template-creation-menu
- '("Template Creation"
- :filter template-menu-filter
- ["Open Template" template-open-template
- :active (null (template-buffer-template-p))]
- "--"
- ["Define User Input" template-define-prompt t]
- ["Define Text Register" template-define-register t]
- ["Define Message" template-define-message t]
- "---"
- ["Insert Expansion Form" template-insert-form t])
- "Menu for template creation.")
-
-
-;;;===========================================================================
-;;; Commenting
-;;;===========================================================================
-
-(defcustom template-max-column -1
- "*Width of the separator line, to use with an empty `comment-end'.
-If the value is zero or negative, it is added to `fill-column'. See
-also `template-max-column-with-end'."
- :group 'template-comments
- :type 'integer)
-
-(defcustom template-max-column-with-end 0
- "*Width of the separator line including a non-empty `comment-end'.
-If the value is zero or negative, it is added to `fill-column'. See
-also `template-max-column'."
- :group 'template-comments
- :type 'integer)
-
-(defcustom template-alt-comment-syntax-alist
- '((t "/* " " */"))
- "Alternative comment syntax for languages with \"mixed\" comments.
-Used by function `template-comment-syntax'. Elements look like
- (MODES-OR-REGEXP COMMENT-START COMMENT-END)
-
-If the current `major-mode' has a empty `comment-end' and a commenting
-command does not work at `point' with the usual `comment-start', we
-search for the first matching alternative comment syntax in this alist.
-
-Each element must \"pass\" MODES-OR-REGEXP. If this is a list, it must
-include the current major-mode, if this is a regexp, it must match the
-`buffer-file-name' without version, otherwise it must be non-nil.
-
-Then, COMMENT-START and COMMENT-END is used as the alternative comment
-syntax if `comment-start-skip' matches COMMENT-START."
- :group 'template-comments
- :type '(repeat (group (choice (repeat :tag "In major modes" :value nil
- function)
- (regexp :tag "Buffer matching" :value "")
- (sexp :tag "Always" :value t))
- (string :tag "Alt comment start" :value "/* ")
- (string :tag "Alt comment end" :value " */"))))
-
-(defcustom template-comment-indent t
- "Non-nil means, indent single-line/block comments.
-Commands \\[template-single-comment] and \\[template-block-comment]
-indent the comment lines if this value is non-nil and the current major
-mode is not a member of `template-indent-mode-disable-list' or if this
-value is nil and the current major mode is a member of
-`template-indent-mode-enable-list'."
- :group 'template-comments
- :type 'boolean)
-
-(defcustom template-indent-mode-disable-list '(sh-mode makefile-mode)
- "Major modes not having indented single-line/block comments.
-Used if `template-comment-indent' is non-nil. Major modes in which
-pressing TAB twice is different from pressing TAB once are good
-candidates for this list."
- :group 'template-comments
- :type '(repeat (function :tag "Major mode")))
-
-(defcustom template-indent-mode-enable-list nil
- "Major modes having indented single-line/block comments.
-Used if `template-comment-indent' is nil."
- :group 'template-comments
- :type '(repeat (function :tag "Major mode")))
-
-(defcustom template-comment-specification-alist
- '(("-" "" "" 0)
- ("-" "" "" 0)
- ("=" "\n\n" "\n" 1)
- ("#" "\n\n\f\n" "\n\n" 2))
- "List of specifications for comment functions.
-Each specification at LEVEL, starting at 1, is a list
- (SEPARATOR BEFORE-BLOCK AFTER-BLOCK DELETE-LINES)
-
-SEPARATOR is the string which is inserted repeatedly by commands
-\\[template-single-comment] and \\[template-block-comment] up to
-`template-max-column'.
-
-After that, \\[template-block-comment] deletes DELETE-LINES after the
-comment block and inserts string AFTER-BLOCK at the end of the block and
-BEFORE-BLOCK at the front of the block.
-
-The specification LEVEL to use is determined by:
- (1) If the prefix argument is non-nil and its numeric value is > 0,
- this value is the LEVEL.
- (2) If the prefix argument is nil, and there is an old comment style,
- use old comment style.
- (3) If `template-comment-specification-special' is a function or the
- current major mode has a property with this name and its value is a
- function, this function returns the specification.
- (4) If `comment-end' is empty and `comment-start' is a string of length
- 1: LEVEL is number of repetitions of `comment-start' at the
- beginning of the line. Otherwise, if the correctly indented line
- starts at the beginning of the line, LEVEL=3, else LEVEL=2."
- :group 'template-comments
- :type '(repeat (group (string :tag "Separator" :value "-")
- (string :tag "Before block" :value "")
- (string :tag "After block" :value "")
- (integer :tag "Delete lines" :value 0))))
-
-(defcustom template-comment-specification-special nil
- "Function used for special commenting styles or nil.
-See `template-comment-specification-alist' for details."
- :group 'template-comments
- :type '(choice (const nil) function))
-
-
-;;;===========================================================================
-;;; Auto updating
-;;;===========================================================================
-
-(defcustom template-auto-update 'query
- "*Whether to update parts of the file when saving the buffer.
-When non-nil and `template-auto-update-disable-regexp' does not match
-the file name, automatically updates parts of the buffer, see
-`template-update-buffer-alist'. With value t or if the entry in the
-alist has no prompt, do not ask for confirmation.
-
-You should have called `template-initialize' to enable this feature."
- :group 'template-updating
- :type '(radio (const :tag "No" nil)
- (const :tag "Without confirmation" t)
- (sexp :tag "With confirmation" :format "%t" :value query)))
-
-(defcustom template-auto-update-disable-regexp nil
- "*Regexp matching files not to automatically update.
-Value nil matches no file. See `template-auto-update'."
- :group 'template-updating
- :type '(choice (const :tag "none" nil) regexp))
-
-(defcustom template-update-buffer-alist
- '((t "Update header in %s? "
- (template-update-header t)
- (file-name-sans-versions (file-name-nondirectory buffer-file-name)))
- ((html-mode) "Update date inside <address> in %s? "
- (-2000
- "\\([0-9]+[ \t]+[A-Za-z][A-Za-z][A-Za-z][ \t]+[0-9]+\\)[ \t\n]*</address>"
- 1)
- (format-time-string "%d %b %Y")))
- "Alist used how to update parts of the buffer.
-Used by function `template-update-buffer'. Elements look like
- (MODES-OR-REGEXP PROMPT TEST NEW REPLACEMENT-FUN)
-
-Each element must \"pass\" MODES-OR-REGEXP. If this is a list, it must
-include the current major-mode, if this is a regexp, it must match the
-`buffer-file-name' without version, otherwise it must be non-nil.
-
-Then, TEST is `eval'd and must return the region = (BEG . END) to be
-replaced or nil if nothing should be updated according to the current
-element. If TEST is a list and the `car' of TEST is not a function,
-`template-update-buffer-region' is used as the default function, i.e.,
-REPLACEMENT-FUN looks like (LIMIT REGEXP GROUP). Then, check first/last
-LIMIT characters in buffer and return region according to GROUP's regexp
-group in REGEXP.
-
-Then, NEW is `eval'd. If it is a string, it is considered as
-replacement for the region, otherwise REPLACE-FUN must be non-nil.
-
-Then, ask user for confirmation with PROMPT where %s is substituted by
-the buffer name if PROMPT is a string and `template-auto-update' is not
-t.
-
-Finally, REPLACEMENT-FUN is called the `eval'd NEW and the beginning and
-the end of the region returned by TEST. If REPLACEMENT-FUN is nil, just
-replace the region by the `eval'd NEW."
- :group 'template-updating
- :type '(repeat (group (choice (repeat :tag "In major modes" :value nil
- function)
- (regexp :tag "Buffer matching" :value "")
- (sexp :tag "Always" :value t))
- (string :tag "Prompt" :value "Update in %s? ")
- (choice (list :tag "Default test"
- (choice (const :tag "No limit" nil)
- (integer :tag "Limit" -1000))
- regexp
- (integer :tag "Regexp group" :value 0))
- (sexp :tag "Eval sexp"))
- (sexp :tag "Eval New string")
- (option (function :tag "Replacement function")))))
-
-(defcustom template-header-lines 3
- "*Last line number which is checked by \\[template-update-header]."
- :group 'template-updating
- :type 'integer)
-
-(put 'template-header-lines 'template-secure-value #'integerp)
-
-(defcustom template-header-regexp-alist
- '(("@(#)\\([^ \t\n]+\\)" . 1)
- ("^%s[ \t]*\\([^ \t\n%s][^ \t\n]*\\)[ \t]+--" . 1))
- "Alist of regexps matching the file name in the header.
-The `car' of each element is the REGEXP with %s, if present, substituted
-by the comment start. A second %s, if present, is substitud by a single
-letter non-alpha comment start, or the empty string otherwise.
-
-The `cdr' is the regexp group to be replaced. Used by
-\\[template-update-header].
-
-The comment start is evaluated from `comment-start', the first character
-in the buffer or \"#\". It is assumed that a non-alpha single character
-comment start may be repeated. For example, the substituted regexp in
-`emacs-lisp-mode' is \"\;+\", in `c++-mode' \"//\"."
- :group 'template-updating
- :type '(repeat (cons :format "%v"
- regexp
- (integer :tag "Regexp group" :value 0))))
-
-
-;;;===========================================================================
-;;; Templates: finding templates
-;;;===========================================================================
-
-(defcustom template-auto-insert 'query
- "*Whether to automatically use template files for new files.
-Used if the user gave a non-existent file as argument to a command in
-`template-find-file-commands'. When non-nil and a matching template
-file can be found, use a template like in `template-new-file'. File
-name refinement is never performed, see `template-derivation-alist'.
-
-With value t, do not ask for confirmation.
-
-You should have called `template-initialize' to enable this feature."
- :group 'template-derivation
- :type '(radio (const :tag "No" nil)
- (const :tag "Without confirmation" t)
- (sexp :tag "With confirmation" :format "%t" :value query)))
-
-(defcustom template-find-file-commands
- '(find-file find-file-other-frame find-file-other-screen
- find-file-other-window find-file-at-point ffap nil)
- "*Commands which use templates as last resort, see `template-auto-insert'.
-See also `template-file-select-commands'.
-
-Include nil if you want to use templates for non-existing files as
-command line arguments when starting Emacs."
- :group 'template-derivation
- :type '(repeat (function :tag "Command")))
-
-(defcustom template-file-select-commands
- '(exit-minibuffer minibuffer-complete-and-exit
- list-mode-item-mouse-selected
- list-mode-item-keyboard-selected)
- "*Commands which select the file name via minibuffer/completions.
-Checked with commands in `template-find-file-commands'."
- :group 'template-derivation
- :type '(repeat (function :tag "Command")))
-
-(defface template-message-face
- '((((class color) (background light)) (:background "pink"))
- (t (:bold t)))
- "Face for temporary message at point. This only works with XEmacs."
- :group 'template-miscellaneous)
-
-(defcustom template-extension ".tpl"
- "*Extension used for template files."
- :group 'template-derivation
- :type 'string)
-
-(defcustom template-subdirectories '("./" "Templates/")
- "*List of subdirectories for template files.
-See `template-derivation-alist' for details."
- :group 'template-derivation
- :type '(repeat directory))
-
-(defcustom template-stop-derivation
- (cond ((fboundp 'file-remote-p) 'file-remote-p)
- ((fboundp 'efs-ftp-path) 'efs-ftp-path)
- ((fboundp 'ange-ftp-ftp-path) 'ange-ftp-ftp-path))
- "If non-nil, function used to determine whether to stop derivation.
-If non-nil, function is called with argument DIR. If it returns t,
-`template-derivation' stops to search for more project specific
-templates, i\.e\., just searches in `template-default-directories'."
- :group 'template-derivation
- :type '(choice (const :tag "Never" nil)
- function))
-
-(defcustom template-default-directories
- (cons (if (and (not (file-directory-p "~/.templates/"))
- (file-directory-p "~/lib/templates"))
- (expand-file-name "~/lib/templates/")
- (expand-file-name "~/.templates/"))
- (and (fboundp 'locate-data-directory)
- (let ((dir (locate-data-directory "template")))
- (and dir (list dir)))))
- "*List of default directories for template files.
-See `template-derivation-alist' for details."
- :group 'template-derivation
- :type '(repeat directory))
-
-(defcustom template-derivation-alist
- '(;;(("00readme" "" ".txt" "\\`00") . ("00readme" "" ".txt"))
- ((t "" t))
- ((t nil null) . (nil nil t 1))
- (("TEMPLATE" "" t)))
- "Alist for template file name derivation and file name refinement.
-Template derivation searches for the most specific readable template
-file. By default, files with the same RAW part as the name of the new
-file are considered to be more specific than files with just the same
-EXT part. Also files in the same directory are considered to be more
-specific than files in their parent directory or any default template
-directory. This behavior can be changed by this alist.
-
-Each FORM in this alist has the form (TEMPLATE . REFINEMENT). If
-TEMPLATE matches, we have found a valid template file and the
-corresponding REFINEMENT is used for the file name refinement.
-
-Before the derivation, the given file name is split into the directory
-part DIR, the file name without directory FILE, and the raw part RAW of
-FILE, the numbering NUM and the extension EXT. The result is stored in
-`template-file'.
-
-TEMPLATE can have the form (FUNCTION ARG...). If TEMPLATE matches,
-FUNCTION, called with arguments ARGs, should return the split template
-file name, see `template-split-filename'.
-
-TEMPLATE can also have the form (T-RAW T-NUM T-EXT F-REGEXP) where all
-elements are optional, i.e., have value nil as default. For TEMPLATE to
-match, all conditions T-RAW, T-NUM and T-EXT must be met and F-REGEXP,
-if non-nil, should match FILE, the non-directory part of the given file
-name. If a condition is a string, the corresponding part of the
-template file must be equal to it. If t, the part must be equal to
-RAW/NUM/EXT of the given file name. If nil, any value will do it. Any
-other value acts like t when the part of the given file name is
-non-empty, as nil otherwise.
-
-REFINEMENT can have the form (FUNCTION ARG...). FUNCTION, called with
-the list of the split template filename and ARGs as arguments, should
-set `template-file' if the file name should be refined.
-
-REFINEMENT can also have the form (F-RAW F-NUM F-EXT AUTO-NUM) where all
-elements are optional, i.e., have value nil as default. If F-RAW, F-NUM
-and F-EXT are non-nil, they change RAW/NUM/EXT of `template-file'. A
-string will be used as the new part. If t, the corresponding part of
-the template name will be used.
-
-We will use auto numbering in the following two cases: if NUM is
-non-empty and the file exists already, or if NUM is empty and AUTO-NUM
-is non-nil. Auto numbering looks at the file names in DIR to generate
-the next unique number which is at least as high as NUM in the first
-case and AUTO-NUM in the second.
-
-Let us use parts of the default value as examples:
-
-Use a template with the same RAW part of the given file name and the
-same EXT part if provided, e.g., for \"exercise2\" use template
-\"exercise.tex.tpl\". Refine file name to use the extension of the
-template file, also use auto numbering, e.g., if files \"exercise2.tex\"
-and \"exercise3.tex\" exist, refine name to \"exercise4.tex\":
- ((t nil null) \. (nil nil t 1))
-
-For a file with extension EXT, use TEMPLATE.EXT:
- ((\"TEMPLATE\" \"\" t))
-
-We could define: If the given file name starts with \"00\", use template
-\"00readme.txt.tpl\". Refine file name to \"00readme.txt\":
- ((\"00readme\" \"\" \".txt\" \"\\\\`00\") \. (\"00readme\" \"\" \".txt\"))
-
-Since more than one template file could meet this conditions, the
-template derivation searches for first readable file with extension
-`template-extension' which is found by the following algorithm:
-
- forall FORMs in `template-derivation-alist' do
- for directory BASE from DIR
- while not stopped according to `template-stop-derivation' do
- forall subdirectories DIRs in `template-subdirectories'
- relative to BASE do
- forall TEMPLATEs in DIR do
- if check_form (FORM, FULL, TEMPLATE) return TEMPLATE
- forall directories DIRs in `template-default-directories' do
- forall TEMPLATEs in DIR do
- if check_form (FORM, FULL, TEMPLATE) return TEMPLATE
- if not used via `template-auto-insert'
- forall TEMPLATEs in `template-default-directories'
- where name_nondir (TEMPLATE) = \"DEFAULT.tpl\" do
- if readable (TEMPLATE) return TEMPLATE
- return TEMPLATE in first (`template-default-directories')
- where name_nondir (TEMPLATE) = \"DEFAULT.tpl\""
- :group 'template-derivation
- :type '(repeat (cons :format "%v"
- (sexp :tag "Derivation" :value ("TEMPLATE" nil t))
- (sexp :tag "Refinement" :value nil))))
-
-
-;;;===========================================================================
-;;; Templates: expanding templates
-;;;===========================================================================
-
-(defcustom template-confirm-insecure t
- "*Non-nil means, ask whether to use insecure template expansions.
-Only set this to nil if you ALWAYS check template files before using
-it!"
- :group 'template-expansion
- :type 'boolean)
-
-(put 'template-confirm-insecure 'risky-local-variable t)
-
-(defcustom template-message-buffer "*Template Message*"
- "If non-nil, name of buffer where messages are shown.
-The following messages will be displayed in definition sequence before
-the expansion has taken place:
- - :before messages, see `template-definition-start',
- - user defined prompts if `template-message-prompt-format' is non-nil,
- - user defined registers when there has been a :before message before,
- see `template-message-register-format'.
-
-The following messages will be displayed in definition sequence after
-the expansion has taken place:
- - :after messages, see `template-definition-start',
- - user defined registers, display them at point if the value of this
- variable is nil, see `template-message-register-format'."
- :group 'template-miscellaneous
- :type '(choice (const :tag "None" nil)
- (string :tag "Buffer Name")))
-
-(defcustom template-message-prompt-intro
- "Template expansion will ask for input with the following prompts:"
- "Default intro message used before listing user defined prompts.
-Used with :before messages, see `template-message-prompt-format'."
- :group 'template-miscellaneous
- :type '(choice (const :tag "None" nil)
- (string :tag "Intro text")))
-
-(defcustom template-message-prompt-format " %s"
- "If non-nil, format string for user defined prompts.
-If non-nil and `template-message-buffer' is non-nil, user defined
-prompts will be listed before starting the expansions. Prompts can be
-defined as specified in the docstring of `template-definition-start'.
-For each PROMPT, this format string will be used with substitution
-PROMPT/%s.
-
-If no :before message has been defined before, use, if non-nil,
-`template-message-prompt-intro' as the first :before message."
- :group 'template-miscellaneous
- :type '(choice (const :tag "No prompt" nil)
- (string :tag "Format string")))
-
-(defcustom template-message-register-intro
- "Template has defined the following registers:"
- "Default intro message used before listing user defined prompts.
-Used with :after messages, see `template-message-register-format'."
- :group 'template-miscellaneous
- :type '(choice (const :tag "None" nil)
- (string :tag "Intro text")))
-
-(defcustom template-message-register-format " %c:\t\"%s\"\t%s"
- "If non-nil, format string for user defined registers.
-If non-nil, user defined text registers will be listed. Registers can
-be defined as specified in the docstring of `template-definition-start'.
-For each register CHAR with contents CONTENTS and optional comment
-COMMENT, this format string will be used with substitution CHAR/%c,
-CONTENT/%s and \(COMMENT/%s or \"\"/%s).
-
-The list of register definitions will be displayed:
- - at point if `template-message-buffer' is nil,
- - with :before messages if there has been at least one :before message
- defined before and if `template-message-buffer' is non-nil,
- - with :after messages if `template-message-buffer' is non-nil.
- If no :after message has been defined before, use, if non-nil,
- `template-message-register-intro' as the first :after message."
- :group 'template-miscellaneous
- :type '(choice (const :tag "No register content" nil)
- (string :tag "Format string")))
-
-(defcustom template-message-timeout 600
- "*Maximum duration the temporary message will be displayed at point.
-Any user event will also make the temporary message disappear. The
-temporary message uses face in `template-message-face'."
- :group 'template-miscellaneous
- :type 'integer)
-
-(put 'template-message-timeout 'template-secure-value #'integerp)
-
-(defcustom template-date-format "%d %b %Y"
- "*Date/time format used with the expansion form (>>>DATE<<<).
-See `template-default-expansion-alist' and `format-time-string'. See
-also `template-time-format'."
- :group 'template-expansion
- :type 'string)
-
-(put 'template-date-format 'template-secure-value #'stringp)
-
-(defcustom template-time-format "%T"
- "*Date/time format used with the expansion form (>>>TIME<<<).
-See `template-default-expansion-alist' and `format-time-string'. See
-also `template-date-format'."
- :group 'template-expansion
- :type 'string)
-
-(put 'template-time-format 'template-secure-value #'stringp)
-
-(defcustom template-string-default "%0.0S"
- "*Format string used for non-string variable extensions.
-If SYMBOL in (\"KEY\" \. SYMBOL) is not a string, use string with
-substitution SYMBOL/%S. Default value \"%0.0S\" causes to print
-nothing. See `template-definition-start'."
- :group 'template-expansion
- :type 'string)
-
-(put 'template-string-default 'template-secure-value #'stringp)
-
-(defcustom template-expansion-format "(>>>%s<<<)"
- "Format string for expansion forms.
-Is a expansion form with substitution KEY/%s. The value should
-correspond with `template-expansion-regexp'. Used by
-`template-insert-form'."
- :group 'template-expansion
- :type 'string)
-
-(put 'template-expansion-format 'template-secure-value #'stringp)
-
-(defcustom template-expansion-regexp "(>>>\\([-A-Za-z0-9_]+\\)<<<)"
- "Regexp matching strings which are replaced by their expansions.
-The first regexp group contains the KEY used by the per-template
-expansion, see `template-definition-start' and the global expansions in
-`template-expansion-alist' and `template-default-expansion-alist'. The
-value should correspond with `template-expansion-alist'.
-
-If there is no defined expansion for the key, ask the user for a
-replacement, see `template-read'. If the key is matched by
-`template-register-regexp', store buffer position in register, see
-`template-register', .
-
-If you want to use a text literally which is matched by this regexp, use
-the zero expansion form (>>>ZERO_FORM<<<)."
- :group 'template-expansion
- :type 'regexp)
-
-(put 'template-expansion-regexp 'template-secure-value #'stringp)
-
-(defcustom template-literal-environment '("LITERAL" . "/LITERAL")
- "Environment for literal text in template.
-Looks like (OPEN . CLOSE). Text between expansion forms with keys OPEN
-and CLOSE is not expanded. If you change OPEN, you should change key
-\"LITERAL\" in `template-default-expansion-alist' accordingly."
- :group 'template-expansion
- :type '(cons (string :tag "Open tag") (string :tag "Close tag")))
-
-(defcustom template-register-regexp "\\`[0-9]\\'"
- "*Regexp matching keys for storing point positions in registers.
-These keys use `template-register' as the default expansion instead of
-`template-read'. See `template-expansion-regexp'. If a register is used
-twice, it is marked by a \"*\" in the echo area after the expansion."
- :group 'template-expansion
- :type 'regexp)
-
-(put 'template-register-regexp 'template-secure-value #'stringp)
-
-(defcustom template-expansion-alist nil
- "User defined expansions forms.
-Predefined expansion forms for `template-expansion-regexp'. Each entry
-has the form (KEY . SEXP). These expansion forms shadow those in
-`template-default-expansion-alist' and are shadowed by those in the
-per-template definition section. See `template-definition-start'."
- :group 'template-expansion
- :type '(repeat (cons :format "%v"
- (string :tag "Key" :value "")
- (repeat :tag "Evaluate all" sexp))))
-
-(put 'template-expansion-alist 'risky-local-variable t)
-
-(defvar template-default-expansion-alist
- '(("POINT" (setq template-point (point-marker))) ; point
- ("MARK" (setq template-mark (point-marker))) ; mark
- ("DIR" (insert (car template-file))) ; directory
- ("FILE" (insert (cadr template-file))) ; file name without directory
- ("FILE_SANS" (insert (nth 2 template-file)
- (nth 3 template-file)))
- ("FILE_RAW" (insert (nth 2 template-file))) ; raw file name without number
- ("FILE_NUM" (insert (nth 3 template-file))) ; number
- ("FILE_UPCASE" (insert (upcase (nth 2 template-file))
- (nth 3 template-file)))
- ("FILE_EXT" (or (string= (nth 4 template-file) "") ; extension
- (insert (substring (nth 4 template-file) 1))))
- ("DATE" (template-insert-time template-date-format))
- ("TIME" (template-insert-time template-time-format))
- ("VC_DATE" (set-time-zone-rule "UTC")
- (template-insert-time "%Y/%m/%d %T" "0000/00/00 00:00:00")
- ;; using saved `current-time-zone' doesn't work, but nil does
- (set-time-zone-rule nil))
- ("YEAR" (template-insert-time "%Y" "0000"))
- ("ISO_DATE" (template-insert-time "%Y-%m-%d" "0000-00-00"))
- ("COMMENT" (template-read "Initial comment: ")) ; comment
- ("AUTHOR" (insert (or user-mail-address ; author
- (and (fboundp 'user-mail-address)
- (user-mail-address))
- (concat (user-login-name) "@" (system-name)))))
- ("USER_NAME" (insert (or (and (boundp 'user-full-name) ; user name
- user-full-name)
- (user-full-name))))
- ("LOGIN_NAME" (insert (user-login-name))) ; login name
- ("HOST_ADDR" (insert (or (and (boundp 'mail-host-address) ; host address
- (stringp mail-host-address)
- mail-host-address)
- (system-name))))
- ("LITERAL" (if (search-forward (format template-expansion-format
- (cdr template-literal-environment))
- nil 'limit)
- (delete-region (match-beginning 0) (match-end 0))))
- ("ZERO_FORM")) ; zero form
- "Predefined default expansions forms.
-Predefined expansion forms for `template-expansion-regexp'. Each entry
-has the form (KEY . SEXP). These expansion forms are shadowed by those
-in `template-expansion-alist' and by those in the per-template
-definition section. See `template-definition-start'.
-
-The default predefined expansion forms are --default is inserting--:
- (>>>POINT<<<) set point
- (>>>MARK<<<) set mark, jump to it with \\[exchange-point-and-mark]
- (>>>DIR<<<) directory: /home/clstaff/wedler/lib/
- (>>>FILE<<<) file w/o directory: text1.txt
- (>>>FILE_SANS<<<) file name w/o extension: text1
- (>>>FILE_RAW<<<) raw file name: text
- (>>>FILE_NUM<<<) number in name: 1
- (>>>FILE_EXT<<<) extension: txt
- (>>>FILE_UPCASE<<<) upcase file name w/o extension: TEXT1
- (>>>DATE<<<) date using `template-date-format': 11 Jan 1999
- (>>>TIME<<<) time using `template-time-format': 11:58:49
- (>>>YEAR<<<) the year: 1999
- (>>>ISO_DATE<<<) ISO 8601 date: 1999-01-11
- (>>>VC_DATE<<<) UTC date/time for vc: 1999/01/11 10:58:49
- (>>>COMMENT<<<) ask user for initial comment
- (>>>AUTHOR<<<) author, i.e., `user-mail-address'
- (>>>USER_NAME<<<) user name: Christoph Wedler
- (>>>LOGIN_NAME<<<) login name: wedler
- (>>>HOST_ADDR<<<) Host address: fmi.uni-passau.de
- (>>>LITERAL<<<) literal text up to (>>>/LITERAL<<<)
- (>>>ZERO_FORM<<<) zero form, i.e., insert nothing. Useful to insert
- a text part matched by `template-expansion-regexp' literally.
-
-There are aliases with one-letter keys, see `template-key-alias-alist'.
-
-It is useful to follow the following conventions: upper case keys for
-predefined extensions, lower case and digits for per-template and the
-following default expansions:
- (>>>0<<<) to (>>>9<<<) set registers 0 to 9, jump to it with
- \\[jump-to-register] 0 etc., see `template-register-regexp'
- (>>>x<<<) where x is any unused letter sequence: ask user.")
-
-(put 'template-default-expansion-alist 'risky-local-variable t)
-
-(defvar template-key-alias-alist
- '(("P" . "POINT")
- ("M" . "MARK")
- ("D" . "DIR")
- ("F" . "FILE")
- ("R" . "FILE_RAW")
- ("N" . "FILE_NUM")
- ("B" . "FILE_UPCASE")
- ("E" . "FILE_EXT")
- ("T" . "DATE")
- ("V" . "VC_DATE")
- ("Y" . "YEAR")
- ("I" . "ISO_DATE")
- ("C" . "COMMENT")
- ("A" . "AUTHOR")
- ("U" . "USER_NAME")
- ("L" . "LOGIN_NAME")
- ("H" . "HOST_ADDR")
- ("Z" . "ZERO_FORM"))
- "Alist to support the old one-letter predefined expansion forms.
-Used for `template-expansion-alist' and
-`template-default-expansion-alist'.")
-
-(defcustom template-definition-start
- ">>>TEMPLATE-DEFINITION-SECTION<<<"
- "Header for the per-template definition section.
-The region following the the first match of this regexp defines the
-per-template definition section. The region will be deleted before the
-actual expansion, see `template-new-file'. If you use the \"Local
-Variables:\" section, define it before this region.
-
-The definition section defines expansion forms for strings KEYs matched
-by `template-expansion-regexp' which might shadow those in
-`template-expansion-alist' and `template-default-expansion-alist':
-
- (\"KEY\"): zero form, same as (>>>ZERO_FORM<<<) in default value of
-`template-default-expansion-alist', useful for inserting text matched by
-`template-expansion-regexp' literally.
-
- (\"KEY\". CHAR): CHAR is the register where the current buffer
-position is stored, see `template-register-regexp'.
-
- (\"KEY\" \"PROMPT\" \"PREFIX\" \"SUFFIX\" \"DEFAULT\" AGAIN-P) where
-the last four arguments are optional: ask user with PROMPT for a STRING.
-If STRING is not \"\", insert PREFIX STRING SUFFIX, otherwise DEFAULT.
-For AGAIN-P, see `template-read'. To define, use
-\\[template-define-prompt].
-
- (\"KEY\" \"PROMPT\" (\"ANSWER\" \. \"TEXT\")...): ask user with PROMPT
-for an input with completion over all ANSWERs and insert corresponding
-TEXT. Expansion forms in TEXT will be expanded.
-
- (\"KEY\" \"PROMPT\" (t \. \"TEXT-y\") (nil \. \"TEXT-n\")): ask user
-with PROMPT a \"y or n\" question with `y-or-n-p' and insert TEXT-y or
-TEXT-n, correspondingly. Expansion forms in TEXT-X will be expanded.
-The y-case and the n-case are optional and can be exchanged.
-
- (\"KEY\" \. SYMBOL): insert value of SYMBOL; if value is no string at
-the time of the replacement, use `template-string-default' as format
-string for SYMBOL.
-
- (\"KEY\" COMMAND \. PREFIX): COMMAND is a symbol or a vector and is
-called with `command-execute' after setting `prefix-arg' to PREFIX, not
-evaluated. If COMMANDs symbol property `template-secure-command' is
-nil, the form is insecure. If that symbol property is a function, it is
-called with PREFIX to check whether COMMAND could be called directly
-with PREFIX as remaining arguments.
-
- (\"KEY\" SEXPR...): evaluate SEXPR during the expansion, see
-`template-expansion-alist' for examples. This form is insecure.
-
-There are other per-template definitions:
-
- \"MESSAGE\": additional line displayed at point until first user event
-or after `template-message-timeout' seconds. The lines are displayed
-with face in `template-message-face'. With active form selector
-:before, define a message which is displayed in
-`template-message-buffer' before the exansion has started. With active
-form selector :after, define a message which is displayed in
-`template-message-buffer' after the exansion has taken place. To
-define interactively, use \\[template-define-message].
-
- (CHAR \. \"CONTENTS\"): Set register CHAR to have contents CONTENTS.
-CONTENTS can then be inserted into a buffer with \\[insert-register] CHAR.
-
- (CHAR \"CONTENTS\" COMMENT) where COMMENT is optional: Set register
-CHAR to have contents CONTENTS. CONTENTS can then be inserted into a
-buffer with \\[insert-register] CHAR. Also display an additional line
-at point to show the contents with COMMENT. To define, use
-\\[template-define-register].
-
-The following forms depend on the active form selector which is the last
-of the following expansion forms:
- - :before: \"MESSAGE\" will be displayed before the expansion
- - :after: \"MESSAGE\" will be displayed after the expansion
- - :eval-before: execute COMMAND and SEXPR before expansion
- - :eval-after: execute COMMAND and SEXPR after expansion
- - nil, deprecated: with the first form, the active form selector is
- :eval-before, with the second, it is :eval-after.
-
- (VARIABLE . VALUE): set SYMBOL's local value to VALUE, not evaluated.
-This form is only secure if VARIABLE has a symbol property
-`template-secure-value' which returns non-nil when applied to VALUE, not
-evaluated. This form is useful for variables which determine the
-expansion, like `template-time-format' and `template-date-format'. For
-local variables in your new file, use the normal way via the \"Local
-Variables:\" section. The active form selector must not be :eval-before
-or :eval-after.
-
- COMMAND: COMMAND is a symbol or a vector and is called with
-`command-execute' before the expansion with form selector :eval-before,
-and after the expansion with form selector :eval-after. If COMMANDs
-symbol property `template-secure-command' is nil, the form is insecure.
-You should use the safe command `normal-mode' in the pre-expansion forms
-if the expansion forms depend on the correct major mode.
-
- SEXPR: evaluate SEXPR before the expansion with form selector
-:eval-before, and after the expansion with form selector :eval-after.
-This form is insecure.
-
-If any insecure forms have been used, the user of the template will be
-asked whether to use the template, see `template-confirm-insecure'."
- :group 'template-expansion
- :type 'string)
-
-
-\f
-;;;;##########################################################################
-;;;; Commenting
-;;;;##########################################################################
-
-
-(defunx template-point-at-bol (&optional count)
- :emacs-only line-beginning-position
- :xemacs-only point-at-bol)
-
-(defunx template-point-at-eol (&optional count)
- :emacs-only line-end-position
- :xemacs-only point-at-eol)
-
-(defunx template-char-or-char-int-p (object)
- :emacs-only integerp
- :xemacs-only char-or-char-int-p)
-
-(defunx template-char-or-int-to-char (object)
- :emacs-only identity
- "Convert character or integer OBJECT into the equivalent character."
- (if (characterp object) object (int-to-char object)))
-
-
-;;;===========================================================================
-;;; Main functions
-;;;===========================================================================
-
-;;;###autoload
-(defun template-single-comment (&optional arg)
- "Decorate the comment in the current line with dashes and alike.
-The line must be a comment-only line or must contain a comment ending by
-eol. That is, jump to the end of the current line and insert the dashes
-and the final comment end-string up-to the fill position. Prefix
-argument ARG and `template-comment-specification' determines the comment
-style to use. The length of the resulting line is determined by
-`template-max-column' and `template-max-column-with-end'."
- (interactive "*P")
- (let* ((orig (point-marker))
- (syntax0 (and comment-start comment-start-skip
- (condition-case nil
- (template-comment-syntax orig 'boc)
- (error nil))))
- (syntax (cond ((cdr syntax0)
- (template-comment-syntax orig))
- (syntax0
- (condition-case nil
- (template-comment-syntax (point-marker))
- (error syntax0)))
- (t
- (back-to-indentation)
- nil)))
- (sep (template-comment-separator-regexp syntax))
- (end (template-point-at-eol))
- old)
- (save-excursion
- (cond ((re-search-forward sep end t)
- ;; with sep in current line
- (setq old (buffer-substring (match-beginning 1) (match-end 1)))
- (delete-region (match-beginning 0) (match-end 0)))
- ((cdr syntax) ; with start-end comment
- (if (looking-at (concat "[ \t]*\\(.+\\)?"
- (regexp-quote (cadr syntax))
- "[ \t]*\\(.+\\)?$"))
- (if (or (match-beginning 1) (match-beginning 2))
- (error "This line contains non-separator chars and %S"
- (cadr syntax))
- ;; Delete comment-end. Don't delete its first char if it is
- ;; the same as the second of comment-start.
- (delete-region (if (and (= (length (car syntax)) 2)
- (= (length (cadr syntax)) 2)
- (eq (aref (car syntax) 1)
- (aref (cadr syntax) 0)))
- (1+ (match-beginning 0))
- (match-beginning 0))
- (match-end 0))))
- (goto-char (cddr syntax))
- (if (re-search-forward sep end t)
- ;; sep in line between comment-start and point-at-eol
- (setq old (buffer-substring (match-beginning 1)
- (match-end 1)))))))
- (template-insert-separator
- (car (template-comment-specification arg old syntax))
- nil syntax)))
-(put 'template-single-comment 'template-secure-command t)
-
-;;;###autoload
-(defun template-block-comment (&optional arg)
- "Decorate the current block of comment-only lines with dashes and alike.
-That is, surround the the contiguous comment-only lines around point
-with extra lines containing dashes and alike and to put the correct
-number of newlines around the block.
-
-Barf if the comment syntax at point has a non-empty `comment-end' or if
-point is not in a comment-only line.
-
-A block comment consists of all neighboring lines which start with
-spaces and `comment-start'. If `comment-start' is a string of length 1,
-the number of repetitions of `comment-start' must be the same or larger
-than in the line where the command is invoked from, too.
-
-Prefix argument ARG and `template-comment-specification' determines the
-comment style to use. The length of the separator line is determined by
-`template-max-column'.
-
-This command can also be used with point in an empty line after a block
-comment. A second invocation of this command directly after a
-successful invocation deletes the remaining empty lines from the current
-line on."
- (interactive "*P")
- (let* ((orig (point-marker))
- (syntax (progn
- (end-of-line)
- (skip-chars-backward " \t\n\f")
- (template-comment-syntax orig))))
- (when (cdr syntax)
- (goto-char orig)
- (error "Command only works with comments terminated by end-of-line"))
-
- (if (and (eq last-command 'template-block-comment-success)
- (looking-at "[ \t]*$"))
- (template-insert-newline "" nil (1- (template-point-at-bol)))
- (let* ((prefix (concat "[ \t]*" (regexp-quote (car syntax))))
- (sepline (concat prefix "[ \t]*"
- (template-comment-separator-regexp syntax)))
- old block-beg block-end def)
- ;; go to the first line with same comment prefix ---------------------
- (beginning-of-line)
- (while (and (not (bobp)) (looking-at prefix))
- (beginning-of-line 0))
- (or (looking-at prefix) (beginning-of-line 2))
- (while (looking-at sepline)
- (setq old (buffer-substring (1- (match-end 0)) (match-end 0)))
- (kill-line 1))
- (setq block-beg (point-marker))
- ;; go to the last line with same comment prefix ----------------------
- (while (looking-at prefix)
- (template-indent-according-to-mode)
- (beginning-of-line 2))
- (if (eobp) (newline))
- (setq block-end (copy-marker (point) t))
- (while (progn (forward-line -1) (looking-at sepline))
- (setq old (buffer-substring (1- (match-end 0)) (match-end 0)))
- (kill-line 1))
- ;; insert separator lines --------------------------------------------
- (goto-char block-beg)
- (set-marker block-beg nil)
- (back-to-indentation)
- (setq def (template-comment-specification arg old syntax))
- (beginning-of-line)
- (template-insert-newline (cadr def))
- (template-insert-separator (car def) (car syntax) syntax)
- (goto-char block-end)
- (set-marker block-end nil)
- (template-insert-separator (car def) (car syntax) syntax)
- (template-insert-newline (caddr def)
- (and (cadddr def)
- (save-excursion
- (forward-line (cadddr def))
- (point))))
- (setq this-command 'template-block-comment-success)))
- (template-indent-according-to-mode)
- (back-to-indentation)))
-(put 'template-block-comment 'template-secure-command t)
-
-
-;;;===========================================================================
-;;; Check comment start, return specification
-;;;===========================================================================
-
-(defun template-indent-according-to-mode ()
- "Indent line according to `template-comment-indent'."
- (if (if template-comment-indent
- (not (memq major-mode template-indent-mode-disable-list))
- (memq major-mode template-indent-mode-enable-list))
- (indent-according-to-mode)))
-
-(defun template-default-comment ()
- "Return default comment according to current position."
- (if comment-start
- (substring comment-start 0 (string-match "[ \t]\\'" comment-start))
- (if (eolp) "#"
- (let ((default (buffer-substring (point) (1+ (point)))))
- (if (string-match "[A-Za-z]" default) "#" default)))))
-
-(defun template-comment-at-point ()
- "Return the comment syntax at the current position.
-Return nil, if no commenting command can be used, i.e., if point is not
-in a comment-only line. Return `none' if the `major-mode' doesn't
-define a comment syntax. Return `delimited' if point is between
-`comment-start' and a non-empty `comment-end'. Return `single' if point
-is in a comment line where the comment syntax has a empty `comment-end',
-return `block' if point is in an empty line after such a comment line."
- (if (and comment-start comment-start-skip)
- (save-excursion
- (let ((orig (point)))
- (condition-case nil
- (progn
- (end-of-line)
- (skip-chars-backward " \t\n\f")
- (if (cdr (template-comment-syntax orig t)) 'delimited
- (if (< (template-point-at-eol) orig) 'block 'single)))
- (error
- (condition-case nil
- (progn
- (goto-char orig)
- (beginning-of-line)
- (when (re-search-forward comment-start-skip
- (template-point-at-eol) t)
- (goto-char (or (match-end 1) (match-beginning 0)))
- (unless (or (cdr (template-comment-syntax orig 'boc))
- (< (template-point-at-eol) orig))
- 'cont)))
- (error nil))))))
- 'none))
-
-(defun template-comment-syntax (orig &optional no-indent)
- "Return the comment syntax at ORIG. Signal error if not in comment.
-Return (COMMENT-START) if the comment syntax has an empty `comment-end'.
-Return (COMMENT-START COMMENT-END . START-POS) if the comment syntax has
-a non-empty `comment-end' where START-POS is the position of the first
-character inside the comment. Move point to first character after the
-comment start or the first non-whitespace character on this line.
-
-ORIG should be the same as `point' or in a empty line after `point'.
-
-If optional argument NO-INDENT is nil, indents the current line
-according to `template-comment-indent' and `indent-according-to-mode'.
-If NO-INDENT is `boc', move point to the beginning of the comment.
-
-COMMENT-START is stripped off its final spaces, COMMENT-END off its
-initial spaces."
- (unless (and comment-start comment-start-skip)
- (error "No comment syntax has been defined for %s" major-mode))
- (if (eq no-indent 'boc)
- (progn
- (beginning-of-line)
- (if (re-search-forward comment-start-skip (template-point-at-eol) t)
- (goto-char (or (match-end 1) (match-beginning 0)))))
- (or no-indent (template-indent-according-to-mode))
- (back-to-indentation))
- (let* ((string (template-default-comment)))
- (if (string= comment-end "")
- (if (looking-at (concat (regexp-quote string)
- (and (= (length string) 1)
- (not (eq no-indent 'boc))
- "+")))
- (progn
- (goto-char (match-end 0))
- (list (buffer-substring (match-beginning 0) (point))))
- (let ((alist template-alt-comment-syntax-alist)
- elem c-start c-end)
- (while alist
- (setq elem (pop alist))
- (and (template-match-modes-or-regexp (car elem))
- (string-match comment-start-skip (cadr elem))
- (setq c-start (cadr elem)
- c-end (caddr elem)
- alist nil)))
- (template-comment-syntax-0 orig c-start c-end string)))
- (template-comment-syntax-0 orig comment-start comment-end))))
-
-(defun template-comment-syntax-0 (orig c-start c-end &optional single)
- ;; checkdoc-params: (orig c-start c-end single)
- "Internal function for `template-comment-syntax'."
- (unless (and (stringp c-start) (stringp c-end) (not (string= c-end "")))
- (goto-char orig)
- (error "Line does not start with %S"
- (or single (template-default-comment))))
- (setq c-start (substring c-start 0 (string-match "[ \t]\\'" c-start))
- c-end (if (string-match "\\`[ \t]+" c-end)
- (substring c-end (match-end 0))
- c-end))
- (cond ((looking-at (regexp-quote c-start))
- (goto-char (match-end 0))
- (cons c-start (cons c-end (point))))
- ((save-excursion
- (when (re-search-backward (concat "^[ \t]*" (regexp-quote c-start))
- nil t)
- (goto-char (match-end 0))
- (let ((match (point)))
- (unless (when (search-forward c-end orig t)
- (skip-chars-forward " \t")
- (< (point) orig))
- (cons c-start (cons c-end match)))))))
- (t
- (goto-char orig)
- (if single
- (error "Not inside a comment (%S or %S-%S) starting in new line"
- single c-start c-end)
- (error "Not inside a comment (%S-%S) starting in new line"
- c-start c-end)))))
-
-
-;;;===========================================================================
-;;; Comment specification
-;;;===========================================================================
-
-;; A simple `mapconcat' is likely to slow down Emacs' regexp search algorithm
-;; considerably (backtracking => near-infloop).
-(defun template-comment-separator-regexp (syntax)
- "Return regexp matching separator comment lines.
-The regexp also matches if the lines ends with parts of COMMENT-END in
-argument SYNTAX, see `template-comment-syntax'."
- (let ((estring (cadr syntax))
- (alist template-comment-specification-alist)
- (chars nil)
- str i c)
- (while alist
- (setq str (car (pop alist)))
- (when str
- (setq i (length str))
- (while (>= (decf i) 0)
- ;; (pushnew (aref str i) chars), but requires cl at runtime:
- (or (memq (setq c (aref str i)) chars) (push c chars)))))
- (concat "\\("
- (mapconcat (lambda (c) (regexp-quote (char-to-string c)))
- (or chars "#")
- "\\|")
- (if estring
- (concat "\\)+[ \t]*"
- (mapconcat (lambda (c)
- (regexp-quote (char-to-string c)))
- estring
- "?")
- "?[ \t]*$")
- "\\)+[ \t]*$"))))
-
-(defun template-comment-specification (arg old syntax)
- "Return the comment specification to use.
-See `template-comment-specification-alist' for details. ARG is the
-prefix argument, OLD the SEPARATOR of the old comment style and SYNTAX
-is the comment syntax returned by `template-comment-syntax'."
- (and arg (setq arg (prefix-numeric-value arg)))
- ;; assumes point-at-indentation
- (or (and arg (> arg 0)
- (if (< (length template-comment-specification-alist) arg)
- (car (last template-comment-specification-alist))
- (nth (1- arg) template-comment-specification-alist)))
- (and (null arg) old
- (assoc old template-comment-specification-alist))
- (and (functionp template-comment-specification-special)
- (funcall template-comment-specification-special))
- (and (functionp (get major-mode 'template-comment-specification-special))
- (funcall (get major-mode 'template-comment-specification-special)))
- (and syntax
- (template-comment-specification
- (if (or (cdr syntax) (> (length comment-start) 1))
- (save-excursion
- (if (cddr syntax) (goto-char (cddr syntax)))
- (beginning-of-line)
- (if (looking-at "[ \t]") 2 3))
- (length (car syntax)))
- nil nil))
- '("-" "" "" 0)))
-
-
-;;;===========================================================================
-;;; Inserting
-;;;===========================================================================
-
-(defun template-insert-newline (string &optional limit start-limit)
- "Deletes blank lines around point and insert STRING.
-After optional LIMIT and before optional START-LIMIT, no character will
-be deleted."
- (let ((start (save-excursion
- (skip-chars-backward " \t\n\f" start-limit)
- (or (bobp) (forward-line 1))
- (point)))
- (end (save-excursion
- (skip-chars-forward " \t\n\f" limit)
- (beginning-of-line)
- (point))))
- (if (> end start) (delete-region start end)))
- (or (bobp) (insert string)))
-
-(defun template-insert-separator (separator &optional cstring syntax)
- "Insert separator line at point.
-If CSTRING is not nil, insert in special line which starts with CSTRING.
-Insert SEPARATOR repeatedly. End the line with COMMENT-END as specified
-in `template-comment-syntax'."
- (when separator
- (when cstring
- (open-line 1)
- (insert cstring)
- (template-indent-according-to-mode))
- (end-of-line)
- (let* ((estring (cadr syntax))
- (max-column (if estring
- template-max-column-with-end
- template-max-column))
- (max (- (if (> max-column 0) max-column (+ fill-column max-column))
- (length separator)
- (length estring))))
- (while (<= (current-column) max) (insert separator))
- (if (>= (length separator) (- (current-column) max))
- (insert (substring separator 0 (- max (current-column)))))
- (if estring (insert estring))
- (if cstring (forward-line 1)))))
-
-
-;;;===========================================================================
-;;; Adaptations: cc-mode
-;;;===========================================================================
-
-;; There isn't really anything I can do against the filling of "/**" in C, C++
-;; and Antlr mode (it is correct in Java), it should be done in the cc-mode
-;; package. Similar for filling "*/" with the previous line...
-
-(defun template-c-fill-paragraph (&optional arg)
- ;; checkdoc-params: (arg)
- "Like \\[c-fill-paragraph] but handles comment separator lines."
- (let* ((regexp (concat "\\|[ \t]*\\(/[*/]\\|\\*\\)[ \t]*"
- (template-comment-separator-regexp '("/*" "*/"))))
- (paragraph-start (concat paragraph-start regexp)) ;#dynamic
- (paragraph-separate (concat paragraph-separate regexp)))
- (c-fill-paragraph arg)))
-
-(defun template-c-init-fill-function ()
- "Set `fill-paragraph-function' to use `template-c-fill-paragraph'."
- (when (boundp 'fill-paragraph-function)
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'template-c-fill-paragraph)))
-
-
-\f
-;;;;##########################################################################
-;;;; Updating (File Name in Header)
-;;;;##########################################################################
-
-
-;;;===========================================================================
-;;; General updating
-;;;===========================================================================
-
-(defun template-update-buffer-region (limit regexp group)
- "Return region = (BEG . END) in buffer to be updated.
-If LIMIT is positive, check first LIMIT characters in buffer, otherwise
-check last -LIMIT characters in buffer for a text to be matched by
-REGEXP. Return region according to GROUP's regexp group in REGEXP."
- (let ((case-fold-search nil))
- (goto-char (if limit
- (if (natnump limit) (point-min) (+ (point-max) limit))
- (point-min)))
- (when (re-search-forward regexp
- (if (natnump limit)
- (+ (point-min) limit)
- (point-max))
- t)
- (cons (match-beginning group) (match-end group)))))
-
-(defun template-match-modes-or-regexp (modes-or-regexp)
- "Return non-nil, if the current buffer passes MODES-OR-REGEXP.
-If MODES-OR-REGEXP is a list, it must include the current `major-mode',
-if it is a regexp, it must match the `buffer-file-name' without version,
-otherwise it must be non-nil."
- (if (stringp modes-or-regexp)
- (and buffer-file-name
- (string-match modes-or-regexp
- (file-name-sans-versions buffer-file-name)))
- (or (nlistp modes-or-regexp) (memq major-mode modes-or-regexp))))
-
-(defun template-update-buffer (&optional arg)
- "Update buffer according to `template-update-buffer-alist'.
-Do not do anything if `template-auto-update-disable-regexp' matches the
-file name or if `template-auto-update' is nil. When optional ARG is
-non-nil, i.e., if called interactively *without* prefix arg, always
-update."
- (interactive (list (null current-prefix-arg)))
- (when (or arg
- (and template-auto-update buffer-file-name
- (null (and template-auto-update-disable-regexp
- (string-match template-auto-update-disable-regexp
- buffer-file-name)))))
- (save-excursion
- (save-restriction
- (widen)
- (let ((alist template-update-buffer-alist)
- (case-fold-search (memq system-type '(vax-vms ms-dos windows-nt)))
- stamp prompt region new)
- (while alist
- (setq stamp (pop alist))
- (condition-case nil
- (and (template-match-modes-or-regexp (pop stamp))
- ;; Run TEST ---------------------------------------------
- (setq prompt (pop stamp)
- region (pop stamp) ; TEST
- region (eval (if (or (atom region)
- (functionp (car region)))
- region
- (cons 'template-update-buffer-region
- region))))
- (if (stringp (setq new (eval (pop stamp))))
- (null (string= (buffer-substring (car region)
- (cdr region))
- new))
- (car stamp))
- ;; user confirmation, replacement -----------------------
- (or (null prompt)
- arg
- (eq template-auto-update t)
- (y-or-n-p (format prompt (buffer-name))))
- (progn
- (goto-char (car region))
- (if (car stamp)
- (funcall (car stamp) new (car region) (cdr region))
- (delete-region (car region) (cdr region))
- (insert new))))
- (error nil))))))))
-
-
-;;;===========================================================================
-;;; Update header
-;;;===========================================================================
-
-;;;###autoload
-(defun template-update-header (&optional show)
- "Replace old file name in header with current file name.
-If SHOW is t, just return region of the filename or nil. Otherwise,
-replace filename if possible and signal an error if SHOW is nil and
-there is no filename in the header. See `template-header-lines' and
-`template-header-regexp-alist'."
- (interactive "*P")
- (if buffer-file-name
- (save-excursion
- (goto-char (point-min))
- (let ((case-fold-search nil)
- (comment-regexp (template-default-comment)) ; at `point-min'!
- (end (progn (forward-line template-header-lines) (point)))
- (alist template-header-regexp-alist)
- (disallowed "")
- group)
- (if (string-match "[A-Za-z]\\|.." comment-regexp)
- (setq comment-regexp (regexp-quote comment-regexp)
- disallowed "")
- (or (eq comment-regexp '(?\]))
- (setq disallowed comment-regexp))
- (setq comment-regexp (concat (regexp-quote comment-regexp) "+")))
- (while alist
- (goto-char (point-min))
- (if (re-search-forward (format (caar alist)
- comment-regexp disallowed)
- end t)
- (setq group (cdar alist)
- alist nil)
- (setq alist (cdr alist))))
- (if (and group (match-beginning group))
- (if (eq show t)
- (cons (match-beginning group) (match-end group))
- (goto-char (match-beginning group))
- (delete-region (point) (match-end group))
- (insert (file-name-sans-versions
- (file-name-nondirectory buffer-file-name)))
- t)
- (if show nil (error "No file name in header")))))
- (if show nil (error "Buffer is not visiting a file"))))
-
-
-\f
-;;;;##########################################################################
-;;;; Templates
-;;;;##########################################################################
-
-
-(defvar template-history nil
- "History, used by `template-read'.")
-
-(defvar template-choice-history nil
- "History, used by `template-choice'.")
-
-(put 'normal-mode 'template-secure-command t)
-
-(defvar template-all-templates nil
- "Internal variable. Template files used for template derivation.")
-(defvar template-file nil
- "Partitioned name of new file: (DIR FILE RAW NUMBER EXT).
-Internal variable. DIR is the directory part, FILE the file name
-without directory part. FILE consists of its extension EXT, RAW and a
-numbering NUMBER just in front of the extension. It is used by the
-expansions DIR, FILE, FILE_SANS, FILE_EXT and others in
-`template-expansion-alist'. Also useful for user defined functions in
-`template-derivation-alist' and the per-template definition section.")
-
-(defvar template-modified nil
- "Internal variable. Whether user is asked during the expansion process.")
-(defvar template-secure t
- "Internal variable. Whether all per-template definitions are secure.")
-(defvar template-point-messages nil
- "Internal variable. List of lines for temporary message at point.")
-(defvar template-before-messages nil
- "Internal variable. List of lines for temporary message before expansion.")
-(defvar template-after-messages nil
- "Internal variable. List of lines for temporary message after expansion.")
-
-(defvar template-point nil
- "Internal variable. Position of point. Set with expansion form P.")
-(defvar template-mark nil
- "Internal variable. Position of mark. Set with expansion form M.")
-
-(defvar template-current nil
- "Internal variable. Current key of expansion form.")
-(defvar template-string-alist nil
- "Internal variable. Alist of user inputs for `template-read'.")
-(defvar template-register-alist nil
- "Internal variable. Alist of used registers.")
-(defvar template-local-alist nil
- "Internal variable. Alist of per-template defined expansions.")
-
-(defvar template-ffap-file-finder nil
- "Value used inside `template-ffap-find-file'.
-If nil, initialize it to the value of `ffap-file-finder', i.e., this
-variable holds the original value of that variable which will be set to
-`template-ffap-find-file' in `template-initialize'.")
-
-
-;;;===========================================================================
-;;; Functions: `find-file'/`insert-file-contents', hooking into `find-file'
-;;;===========================================================================
-
-(defun template-find-template (filename &optional replace)
- "Switch to a buffer visiting template file FILENAME.
-If optional REPLACE is non-nil, replace the current buffer contents with
-the contents of file FILENAME.
-
-This function always considers template files as text files."
- (let ((file-name-buffer-file-type-alist nil)) ; Emacs on DOS/NT
- (if replace
- (insert-file-contents filename nil nil nil
- ;; 5th arg not t with empty accessible part
- ;; (XEmacs bug workaround: would infloop)
- (> (point-max) (point-min)))
- (let ((template-auto-insert nil))
- (switch-to-buffer (find-file-noselect filename))))))
-
-(defun template-not-found-function ()
- "Use a template when visiting a non-existent file.
-See `template-auto-insert' and `template-find-file-commands'. Function
-in `find-file-not-found-hooks'."
- (and template-auto-insert (not buffer-read-only) (bobp) (eobp)
- (or (memq this-command template-find-file-commands)
- (and (memq this-command template-file-select-commands)
- ;; thanks to Dave Love <d.loveNOSPAMdl.ac.uk>:
- (memq (car-safe (car command-history))
- ;; To always include `find-file-at-point', use ffap
- ;; initialization (see `template-ffap-find-file')
- template-find-file-commands)))
- (let ((template (cdr (template-derivation buffer-file-name t t))))
- (and template
- (file-readable-p template)
- (or (eq template-auto-insert t)
- (y-or-n-p
- (format "Use template %s? "
- (cond-emacs-xemacs
- (abbreviate-file-name template :XEMACS t)))))
- (progn
- (template-new-file nil template)
- (setq this-command 'session-disable)
- t)))))
-
-(defun template-ffap-find-file (filename)
- "Function to use in `ffap-file-finder'.
-Add an entry to `command-history' if necessary and call function in
-`template-ffap-file-finder' with argument FILENAME."
- (or (memq (car-safe (car command-history))
- '(ffap find-file-at-point))
- (setq command-history
- (cons (list 'find-file-at-point filename) command-history)))
- (if (eq template-ffap-file-finder 'template-ffap-find-file)
- (find-file filename)
- (funcall template-ffap-file-finder filename)))
-
-
-;;;===========================================================================
-;;; Main function
-;;;===========================================================================
-
-(defun template-expand-template-interactive ()
- (let* ((use (template-derivation (expand-file-name
- (or buffer-file-name "NONE"))
- t))
- (tpl (read-file-name "Insert and expand template: "
- (file-name-directory (cdr use))
- (file-name-nondirectory (cdr use))
- t
- (file-name-nondirectory (cdr use)))))
- (if (string= tpl "")
- (error "No template file provided"))
- (list (expand-file-name tpl (file-name-directory (cdr use))))))
-
-;;;###autoload
-(defun template-expand-template (template)
- "Expand template file TEMPLATE and insert result in current buffer.
-Using a template for inserting some text consists of:
- 1. Template derivation: suggest a reasonable template file to the user
- according to `buffer-file-name', see `template-derivation-alist'.
- 2. Template insertion: insert the template file at point into the
- current buffer.
- 3.. as steps 6.. of `template-new-file'."
- (interactive (template-expand-template-interactive))
- (save-restriction
- (narrow-to-region (point) (point))
- (template-new-file nil template t)))
-
-(defun template-new-file-interactive ()
- "Interactive specification for `template-new-file'.
-Return \(FILE TEMPLATE)."
- (let* ((inp (read-file-name (if current-prefix-arg
- "New file (+template, no name change): "
- "New file (+template): ")
- nil ""))
- (use (cond ((equal inp "")
- (error "Empty/no input"))
- ((file-directory-p inp)
- (error "%S is a directory" inp))
- (t (template-derivation (expand-file-name inp)
- current-prefix-arg))))
- (tpl (read-file-name (format "File %s uses template: "
- (file-name-nondirectory (car use)))
- (file-name-directory (cdr use))
- (file-name-nondirectory (cdr use))
- t
- (file-name-nondirectory (cdr use)))))
- (list (car use)
- (if (string= tpl "")
- nil
- (expand-file-name tpl (file-name-directory (cdr use)))))))
-
-;;;###autoload
-(defun template-new-file (file template &optional with-undo)
- "Open a new file FILE by using a TEMPLATE.
-Using a template for creating a new file consists of, steps 1 to 3 are
-only executed when called interactively:
- 1. Prompt for the name of the new file.
- 2. Template derivation: suggest a reasonable template file to the user
- see `template-derivation-alist'.
- 3. File name refinement: e.g., if the given file name is \"exercise\"
- and there are two files \"exercise1.tex\" and \"exercise2.tex\" in
- the same directory and if we have a template \"exercise.tex.tpl\",
- the file name is refined to \"exercise3.tex\". This is turned off
- when \\[template-new-file] is called with a prefix argument.
- 4. Template insertion: insert the template file into the empty buffer.
- 5. Read per-template expansion definition section starting at
- `template-definition-start' and delete it.
- 6. Display :before message in `template-message-buffer'.
- 7. Execute pre-expansion commands defined in the definition section.
- 8. Set local variables defined in the definition section.
- 9. Expansion: expand the expansion forms (text matched by
- `template-expansion-regexp') They are defined in the definition
- section, in `template-expansion-alist', or provided by default, see
- `template-expansion-regexp' and `template-register-regexp'.
- 10. Execute post-expansion commands defined in the definition section.
- 11. Run `normal-mode' and functions in `find-file-hooks'.
- 12. Update header according to `template-update-header' with argument
- `if-exists'.
- 13. Display :after message in `template-message-buffer'.
- 14. Report: display a temporary message at point defined in the
- definition section and an automatically generated message in the
- minibuffer area, see `template-message-timeout'.
-
-If optional WITH-UNDO is non-nil, store corresponding changes in
-`buffer-undo-list'. If FILE is nil, the buffer for FILE has already
-been created and the accessible part will be replaced by the expanded
-template. If TEMPLATE is nil (empty input when called interactively),
-do not use a template."
- (interactive (template-new-file-interactive))
- ;; check template and file name --------------------------------------------
- (if template
- (if (file-readable-p template)
- (if (file-directory-p template)
- (error "Template %s is a directory" template))
- (if (null (yes-or-no-p (format "Template %s does not exist. Create? "
- template)))
- (error "No template file to use")
- (template-make-directory (file-name-directory template))
- (template-find-template template)
- (error "You should create this template first"))))
- (if (not file)
- (switch-to-buffer (current-buffer))
- (and (or (get-file-buffer file) (file-exists-p file))
- (null (yes-or-no-p (format "File %s exists. Delete contents? " file)))
- (error "Cannot use templates for existing files"))
- (let ((auto-mode-alist nil)
- (enable-local-variables nil)
- (find-file-not-found-hooks nil)
- (enable-local-eval nil))
- (switch-to-buffer (find-file-noselect file))))
- (when template
- (or with-undo (setq buffer-undo-list t))
- (template-find-template template t)
- (template-new-file-0 with-undo)))
-
-(defun template-new-file-0 (with-undo)
- "Perform template replacements in current buffer.
-If WITH-UNDO is non-nil, store corresponding changes in
-`buffer-undo-list'."
- ;; start replacement -------------------------------------------------------
- (or with-undo (set-buffer-modified-p nil))
- (goto-char (point-min))
- (setq template-secure t
- template-point nil
- template-mark nil
- template-modified nil
- template-point-messages nil
- template-before-messages nil
- template-after-messages nil
- template-local-alist nil
- template-register-alist nil
- template-string-alist nil)
- (let ((form-selector nil)
- (pre-command-list nil)
- (post-command-list nil)
- (local-variable-list nil)
- val)
- ;; read per-template definition section ----------------------------------
- (goto-char (point-min))
- (when (re-search-forward
- (concat "^[ \t]*" template-definition-start "[ \t]*$") nil t)
- (condition-case ()
- (while t
- (setq val (read (current-buffer)))
- (cond (;; ("KEY" . xxx): ask user --------------------------------
- (and (consp val) (stringp (car val)))
- (let* ((def (cdr val)) ; expansion forms
- (msg (cond ((null template-message-prompt-format)
- nil)
- ((stringp def) def)
- ((and (consp def) (stringp (car def)))
- (car def)))))
- (when msg ; list prompts in before-messages
- (or template-before-messages
- (null template-message-prompt-intro)
- (push template-message-prompt-intro
- template-before-messages))
- (push (format template-message-prompt-format msg)
- template-before-messages))
- (push (cons (car val) (template-translate-definition def))
- template-local-alist)))
- ;; :before, :after, :eval-before, :eval-after --------------
- ((null val) ; nil is deprecated
- (setq form-selector
- (cond ((null form-selector) :old-before)
- ((eq form-selector :old-before) :old-after)
- ((eq form-selector :old-after)
- (error "More than two (obsolete) nil forms"))
- (t
- (error "Used obsolete nil form with new form selectors")))))
- ((memq val '(:before :after :eval-before :eval-after))
- (setq form-selector val))
- ;; "MESSAGE" -----------------------------------------------
- ((stringp val)
- (cond ((eq form-selector :before)
- (push val template-before-messages))
- ((eq form-selector :after)
- (push val template-after-messages))
- (t
- (push val template-point-messages))))
- ;; (CHAR . xxx): set register ------------------------------
- ((and (consp val) (template-char-or-char-int-p (car val)))
- (let ((reg (template-char-or-int-to-char (car val))))
- (if (atom (cdr val))
- (set-register reg (cdr val))
- (set-register reg (cadr val))
- (when template-message-register-format
- (let ((msg (format template-message-register-format
- reg (cadr val)
- (or (caddr val) ""))))
- (if template-message-buffer
- (progn
- (if template-before-messages
- (push msg template-before-messages))
- (or template-after-messages
- (null template-message-register-intro)
- (push template-message-register-intro
- template-after-messages))
- (push msg template-after-messages))
- (push msg template-point-messages)))))))
- ;; set var, execute command and sexpr ----------------------
- ((and (memq form-selector '(nil :before :after))
- (consp val)
- (symbolp (car val)))
- (or (and (functionp (get (car val) 'template-secure-value))
- (funcall (get (car val) 'template-secure-value)
- (cdr val)))
- (setq template-secure nil))
- (push val local-variable-list))
- ((memq form-selector '(:eval-before :old-before))
- (push (template-elisp-in-definition val)
- pre-command-list))
- ((memq form-selector '(:eval-after :old-after))
- (push (template-elisp-in-definition val)
- post-command-list))
- (t
- (error "Illegal form"))))
- (error nil))
- (skip-chars-forward " \t\n\f")
- (or (eobp)
- (error "Invalid definition in line %d (pos %d) of the template file"
- (count-lines 1 (point)) (point)))
- (or template-secure
- (null (default-value template-confirm-insecure))
- (y-or-n-p "Have you checked the template functions? ")
- (error "Failed security check"))
- (delete-region (match-beginning 0) (point-max)))
- ;; expand ----------------------------------------------------------------
- (template-display-messages template-before-messages)
- (eval (cons 'progn (nreverse pre-command-list)))
- (while local-variable-list
- (make-local-variable (caar local-variable-list))
- (set (caar local-variable-list) (cdar local-variable-list))
- (setq local-variable-list (cdr local-variable-list)))
- (goto-char (point-min))
- (while (re-search-forward template-expansion-regexp nil t)
- (setq template-current (buffer-substring (match-beginning 1)
- (match-end 1))
- val (assoc template-current template-local-alist))
- (unless val
- (if (setq val (assoc template-current template-key-alias-alist))
- (setq template-current (cdr val)))
- (setq val (or (assoc template-current template-expansion-alist)
- (assoc template-current
- template-default-expansion-alist))))
- (delete-region (match-beginning 0) (match-end 0))
- (cond (val
- (eval (cons 'progn (cdr val))))
- ((string-match template-register-regexp template-current)
- (template-register))
- (t
- (template-read (format "Replacement for `%s': "
- template-current)))))
- (eval (cons 'progn (nreverse post-command-list)))
- (save-restriction
- (widen)
- (normal-mode t)
- (or with-undo (template-update-header 'if-exists))
- (run-hooks 'find-file-hooks))
- ;; message ---------------------------------------------------------------
- (template-display-messages template-after-messages)
- (cond ((null template-register-alist)
- (message "%s, no buffer location in register"
- (if template-mark "Mark set" "No mark")))
- (t (message "%s, buffer location in register: %s"
- (if template-mark "Mark set" "No mark")
- (mapconcat (function
- (lambda (x)
- (if (cdr x)
- (concat (char-to-string (car x)) "*")
- (char-to-string (car x)))))
- (nreverse template-register-alist)
- ", "))))
- (or with-undo (set-buffer-modified-p template-modified))
- (goto-char (point-min))
- (when template-point
- (goto-char template-point)
- (set-marker template-point nil))
- (when template-mark
- (push-mark template-mark)
- (set-marker template-mark nil)
- (if (fboundp 'zmacs-activate-region) (zmacs-activate-region)))
- (when (and template-point-messages
- (or (cdr template-point-messages)
- (not (string-equal (car template-point-messages) ""))))
- (let ((beg (point))
- end)
- (if (cdr template-point-messages)
- (insert (mapconcat 'identity
- (nreverse template-point-messages)
- "\n")
- "\n")
- (insert (car template-point-messages)))
- (setq end (point))
- (goto-char beg)
- (and (fboundp 'make-extent) (fboundp 'set-extent-face)
- (set-extent-face (make-extent beg end) 'template-message-face))
- (recenter)
- (sit-for template-message-timeout)
- (delete-region beg end))))
- (recenter)
- (unless with-undo
- (setq buffer-undo-list nil)
- (set-buffer-modified-p template-modified)))
-
-(defun template-display-messages (messages)
- (when (and messages template-message-buffer)
- (setq messages (nreverse messages))
- (with-output-to-temp-buffer template-message-buffer
- (while messages
- (princ (pop messages))
- (if messages (princ "\n"))))))
-
-
-;;;===========================================================================
-;;; Determine name of the new file and the template
-;;;===========================================================================
-
-(defun template-derivation (full arg &optional no-default)
- "Derive template file name and do file name refinement.
-Return (REFINED . TEMPLATE) where REFINED is the refined version of FULL
-and TEMPLATE and template file name, see `template-derivation-alist'.
-FULL is the initial file name given by the user. File name refinement
-is turned off when ARG is non-nil. If optional argument NO-DEFAULT is
-non-nil, return nil instead (FULL \. \"~/.templates/DEFAULT.tpl\") if no
-matching entry can be found in `template-derivation-alist'."
- ;; Get all templates -------------------------------------------------------
- (setq template-all-templates nil)
- (let* ((dir (file-name-directory full))
- (len (length dir))
- (case-fold-search (memq system-type '(vax-vms ms-dos windows-nt))))
- (while (and dir
- (not (and template-stop-derivation
- (fboundp template-stop-derivation)
- (funcall template-stop-derivation dir))))
- (template-all-templates template-subdirectories dir)
- (setq dir (file-name-directory (directory-file-name dir)))
- (or (> len (setq len (length dir)))
- (setq dir nil)))
- (template-all-templates template-default-directories)
- (setq template-all-templates (nreverse template-all-templates)))
- ;; Get template file -------------------------------------------------------
- (if (string= (file-name-nondirectory full) "")
- (error "You cannot use templates for directories"))
- (setq template-file (template-split-filename full))
- (let ((tests template-derivation-alist)
- test template file)
- (while tests
- (setq test (caar tests)
- file (cdar tests))
- (if (setq template
- (if (functionp (car test))
- (apply (car test) (cdr test))
- (apply 'template-default-template test)))
- (setq tests nil)
- (setq tests (cdr tests))))
- (if template
- (or arg
- (if (functionp (car file))
- (apply (car file) template (cdr file))
- (apply 'template-unique-file template file)))
- (or no-default
- (setq template (template-split-filename
- "DEFAULT"
- (template-default-directory)))))
- (if template
- (cons (expand-file-name (cadr template-file) (car template-file))
- (expand-file-name (concat (cadr template) template-extension)
- (car template))))))
-
-(defun template-default-directory ()
- "Return directory of file \"DEFAULT.tpl\"."
- (let ((dirs template-default-directories)
- (name (concat "DEFAULT" template-extension))
- dir)
- (while dirs
- (setq dir (pop dirs))
- (if (file-readable-p (expand-file-name name dir))
- (setq dirs nil)
- (setq dir nil)))
- (or dir
- (car template-default-directories)
- (expand-file-name "~/.templates/"))))
-
-
-;;;===========================================================================
-;;; Small functions
-;;;===========================================================================
-
-(defun template-make-directory (dir)
- "Create DIR if it does not exists yet."
- (cond ((file-exists-p dir))
- ((yes-or-no-p (format "The directory %s does not exist. Create? " dir))
- (make-directory dir t))
- (t (error "You should create a directory \"%s\"" dir)))
- dir)
-
-(defun template-split-filename (file &optional dir)
- "Split file name into its parts.
-If DIR is nil, FILE is a fully expanded file name, otherwise FILE is a
-file name without its directory part DIR. See `template-file'."
- (or dir (setq dir (template-make-directory (file-name-directory file))
- file (file-name-nondirectory file)))
- (let* ((ext (string-match "\\.[^.]*\\'" file))
- (raw (substring file 0 ext))
- (num (string-match "[^0-9][0-9]+\\'" raw)))
- (if num
- (list dir file
- (substring raw 0 (1+ num))
- (substring raw (1+ num))
- (if ext (substring file ext) ""))
- (list dir file raw "" (if ext (substring file ext) "")))))
-
-(defun template-translate-definition (def)
- "Translate DEF of expansion and set `template-secure' accordingly."
- (cond ((null def) ; zero form
- nil)
- ((template-char-or-char-int-p def)
- `((template-register ,def)))
- ((stringp def)
- `((template-read ,def nil nil nil t)))
- ((symbolp def)
- `((insert (if (stringp ,def) ,def template-string-default))))
- ((and (consp def) (stringp (car def)))
- (if (consp (car-safe (cdr def)))
- `((template-choice ,(car def) (quote ,(cdr def))))
- `((apply (quote template-read) (quote ,def)))))
- ((consp (car-safe def))
- (setq template-secure nil)
- def)
- (t
- (list (template-elisp-in-definition (car def) (cdr def))))))
-
-(defun template-elisp-in-definition (def &optional prefix)
- "Return valid elisp definition and set `template-secure' accordingly.
-DEF is the elisp form, PREFIX would be the prefix argument if DEF is a
-command."
- (cond ((consp def)
- (setq template-secure nil)
- def)
- ((or (symbolp def) (vectorp def))
- (or (and (symbolp def) (get def 'template-secure-command))
- (setq template-secure nil))
- (if (and (symbolp def)
- (functionp (get def 'template-secure-command))
- (listp prefix)
- (funcall (get def 'template-secure-command) prefix))
- `(apply (quote ,def) (quote ,prefix))
- `(progn (setq prefix-arg (quote ,prefix))
- (command-execute (quote ,def)))))
- (t
- (error "Illegal form"))))
-
-
-;;;===========================================================================
-;;; Compute template name
-;;;===========================================================================
-
-(defun template-all-templates (dirs &optional base)
- "Read names of template files in DIRS relatively to BASE.
-Insert the names to internal variable `template-all-templates'."
- (let ((regexp (concat (regexp-quote template-extension) "\\'"))
- (endpos (- (length template-extension)))
- dir templates)
- (while dirs
- (setq dir (expand-file-name (car dirs) base)
- dirs (cdr dirs))
- (cond-emacs-xemacs
- (and (file-accessible-directory-p dir)
- (file-readable-p dir)
- (setq templates (directory-files dir t regexp :XEMACS nil t))
- (while templates
- (and :EMACS
- (not (file-directory-p (car templates)))
- :BOTH
- (file-readable-p (car templates))
- (push (template-split-filename (substring (car templates)
- 0
- endpos))
- template-all-templates))
- (setq templates (cdr templates))))))))
-
-(defun template-set-template-part (part file-part)
- "Set template part according to definition PART and FILE-PART.
-See `template-derivation-alist' for details."
- (when part
- (cond ((stringp part) part)
- ((eq part t) file-part)
- ((null (string= file-part "")) file-part))))
-
-(defun template-default-template (&optional raw num ext regexp)
- "Return template according to RAW, NUM, EXT and REGEXP.
-See `template-derivation-alist' for details."
- (if (or (null regexp) (string-match regexp (cadr template-file)))
- (let ((templates template-all-templates)
- (file-rne (cddr template-file))
- result template-rne)
- (setq raw (template-set-template-part raw (car file-rne))
- num (template-set-template-part num (cadr file-rne))
- ext (template-set-template-part ext (caddr file-rne)))
- (while templates
- (setq template-rne (cddar templates))
- (if (and (or (null raw) (string= (car template-rne) raw))
- (or (null num) (string= (cadr template-rne) num))
- (or (null ext) (string= (caddr template-rne) ext)))
- (setq result (car templates)
- templates nil)
- (setq templates (cdr templates))))
- result)))
-
-
-;;;===========================================================================
-;;; File name refinement
-;;;===========================================================================
-
-(defun template-default-file (template &optional raw num ext)
- "Refine file name according to TEMPLATE, RAW, NUM and EXT.
-The result is in `template-file'. See `template-derivation-alist'."
- (let ((template-rne (cddr template))
- (file-rne (cddr template-file)))
- (if raw
- (if (eq raw t) (setq raw (car template-rne)))
- (setq raw (car file-rne)))
- (if num
- (if (eq num t) (setq num (cadr template-rne)))
- (setq num (cadr file-rne)))
- (if ext
- (if (eq ext t) (setq ext (caddr template-rne)))
- (setq ext (caddr file-rne)))
- (setcdr template-file (list (concat raw num ext) raw num ext))))
-
-(defunx template-unique-file (template &optional raw num ext auto-num)
- "Refine file name according to TEMPLATE, RAW, NUM, EXT and AUTO-NUM.
-Use auto numbering if NUM is not \"\" or AUTO-NUM is non-nil. The
-result is in `template-file'. See `template-derivation-alist'."
- (template-default-file template raw num ext)
- (let* ((dir (car template-file))
- (full (expand-file-name (cadr template-file) dir)))
- (when (if (string= (fourth template-file) "")
- auto-num
- (setq auto-num
- (and (or (get-file-buffer full)
- (file-readable-p full))
- (string-to-int (fourth template-file)))))
- (setq auto-num (1- auto-num)
- raw (third template-file)
- ext (fifth template-file))
- (let ((list (buffer-list))
- file1 dir1)
- (while list
- (and (setq file1 (buffer-file-name (car list)))
- (setq dir1 (file-name-directory file1))
- (string= dir1 dir)
- (setq auto-num
- (max (template-filename-number
- (cddr (template-split-filename
- (file-name-nondirectory file1)
- dir1))
- raw ext)
- auto-num)))
- (setq list (cdr list)))
- (setq list (directory-files dir nil nil t :XEMACS t))
- (while list
- (unless (:EMACS file-directory-p (car list))
- (setq auto-num
- (max (template-filename-number
- (cddr (template-split-filename (car list) dir))
- raw ext)
- auto-num)
- list (cdr list))))
- (template-default-file template raw
- (int-to-string (1+ auto-num))
- ext)))))
-
-(defun template-filename-number (file-rne raw ext)
- "Return numbering in FILE-RNE if the RAW and EXT parts are equal."
- (or (and (string= (car file-rne) raw)
- (string= (caddr file-rne) ext)
- (string-to-int (cadr file-rne)))
- 0))
-
-
-;;;===========================================================================
-;;; Safe commands for per-template expansions
-;;;===========================================================================
-
-(defun template-insert-time (&optional format default)
- "Insert time into current buffer using time format FORMAT.
-If FORMAT is not a string, it uses DEFAULT or `current-time-string'."
- (interactive)
- (insert (if (and (stringp format) (fboundp 'format-time-string))
- (format-time-string format (current-time))
- (or default (current-time-string)))))
-(put 'template-insert-time 'template-secure-command
- (lambda (args)
- (or (null args) (and (stringp (car args)) (null (cdr args))))))
-
-
-;;;===========================================================================
-;;; Functions for the predefined expansions
-;;;===========================================================================
-
-(defun template-register (&optional register)
- "Set current location in register REGISTER.
-That is, \\[jump-to-register] REGISTER jumps to the current position.
-If REGISTER is nil, use register corresponding to the last character in
-`template-current'."
- (let* ((char (if register
- (template-char-or-int-to-char register)
- (aref template-current (1- (length template-current)))))
- (elem (assoc char template-register-alist)))
- (point-to-register char)
- (if elem
- (setcdr elem t)
- (push (list char) template-register-alist))))
-
-(defun template-read (prompt &optional prefix suffix default again-p)
- "Ask user with PROMPT for a STRING to be inserted.
-If STRING is not \"\", insert PREFIX STRING SUFFIX, otherwise DEFAULT.
-If AGAIN-P is nil, do not ask if `template-current' appears another time
-as key in a expansion form. If AGAIN-P is `expand', the inserted region
-is searched for expansion forms where STRING is marked as a literal
-environment, see `template-literal-environment'."
- (setq template-modified t)
- (let ((pos (point))
- (elem (and (null again-p)
- (assoc template-current template-string-alist))))
- (if elem
- (setq elem (cdr elem))
- (setq elem (read-from-minibuffer prompt nil nil nil
- 'template-history)
- elem (cond ((string= elem "") (or default ""))
- ((eq again-p 'expand)
- (concat prefix
- (format template-expansion-format
- (car template-literal-environment))
- elem
- (format template-expansion-format
- (cdr template-literal-environment))
- suffix
- (format template-expansion-format
- (car template-literal-environment))
- (format template-expansion-format
- (cdr template-literal-environment))))
- (t
- (concat prefix elem suffix))))
- (or again-p (push (cons template-current elem) template-string-alist)))
- (insert elem)
- (if (eq again-p 'expand) (goto-char pos))))
-
-(defun template-choice (prompt table)
- "Ask user with PROMPT for a choice and insert it.
-Each element in TABLE looks like (ANSWER . TEXT). Ask for an input with
-completion over all ANSWERs and insert corresponding TEXT if ANSWER is a
-string, otherwise ask a \"y or n\" question and use the result of
-`y-or-n-p' as ANSWER. Expansion forms in TEXT will be expanded."
- (setq template-modified t)
- (let ((pos (point)))
- (insert (or (cdr (assoc (if (stringp (caar table))
- (completing-read prompt table nil t nil
- 'template-choice-history)
- (y-or-n-p prompt))
- table))
- "")
- (format template-expansion-format
- (car template-literal-environment))
- (format template-expansion-format
- (cdr template-literal-environment)))
- (goto-char pos)))
-
-
-;;;===========================================================================
-;;; Menu filter
-;;;===========================================================================
-
-(defun template-menu-filter (menu-items)
- ;; checkdoc-params: (menu-items)
- "Menu filter for `template-creation-menu'."
- (let ((alist (append template-expansion-alist
- template-default-expansion-alist))
- menu used key)
- (while alist
- (unless (member (setq key (car (pop alist))) used)
- (push key used)
- (push (vector (concat "Insert " key)
- (list 'template-insert-form current-prefix-arg key)
- t)
- menu)))
- (append menu-items (nreverse menu))))
-
-
-;;;===========================================================================
-;;; Insert and define forms
-;;;===========================================================================
-
-(defun template-buffer-template-p ()
- "Return non-nil, if current buffer is likely to be a template file."
- (and buffer-file-name
- (string-match (concat (regexp-quote template-extension) "\\'")
- (file-name-sans-versions buffer-file-name))))
-
-(defun template-open-template ()
- "If current buffer is no template file, open a new one."
- (interactive)
- (if (template-buffer-template-p)
- (barf-if-buffer-read-only)
- (let (name
- (dir (and (car template-subdirectories)
- (expand-file-name (car template-subdirectories)))))
- (if (null buffer-file-name)
- (setq name (concat "TEMPLATE" template-extension))
- (setq name (file-name-sans-versions
- (file-name-nondirectory buffer-file-name)))
- (if (string-match ".\\.[^.]*\\'" name)
- (setq name (concat "TEMPLATE"
- (substring name (1+ (match-beginning 0)))
- template-extension))
- (setq name (concat name template-extension)
- ;; dot file => template not specific for directory
- dir (car template-default-directories))))
- (setq name (read-file-name "Open template file (empty=none): "
- dir nil nil name))
- (or (string= name "")
- (template-find-template name)))))
-
-(defun template-insert-form (arg key)
- "Insert an expansion form according to KEY into template.
-When called interactively, allow completion over all keys in
-`template-expansion-alist' and `template-default-expansion-alist'.
-If prefix ARG is nil, run `template-open-template' first."
- (interactive
- (list current-prefix-arg
- (completing-read "Insert key (0-9 for register position): "
- (append template-expansion-alist
- template-default-expansion-alist))))
- (or arg (template-open-template))
- (insert (format template-expansion-format key))
- (if (equal key (car template-literal-environment))
- (let ((pos (point)))
- (insert (format template-expansion-format
- (cdr template-literal-environment)))
- (goto-char pos))))
-
-(defun template-define-start (arg &rest args)
- "Insert a definition section and definition into template.
-See `template-definition-start'. If ARGS is non-nil, pass ARGS to
-`format' for a new definition. If prefix ARG is nil, run
-`template-open-template' first."
- (interactive "P")
- (or arg (template-open-template))
- (save-excursion
- (goto-char (point-min))
- (unless (re-search-forward (concat "^[ \t]*"
- template-definition-start
- "[ \t]*$") nil t)
- (goto-char (point-max))
- (or (bolp) (insert "\n"))
- (insert template-definition-start))
- (goto-char (point-max))
- (or (bolp) (insert "\n"))
- (if args (insert (apply 'format args) "\n")))
- (message "Put definition at the end of the template"))
-
-(defun template-define-message (arg message)
- "Insert a temporary message MESSAGE definition into template.
-For ARG, see `template-define-start'."
- (interactive "P\nsTemporary message: ")
- (template-define-start arg "%S" message))
-
-(defun template-define-prompt (arg key prompt &optional prefix suffix default)
- "Insert a definition for KEY as PROMPT into template.
-For ARG, see `template-define-start'."
- (interactive "P\nsExpansion key: \nsExpansion prompt: \nsPrefix for non-empty input: \nsSuffix for non-empty input: \nsDefault for empty input: ")
- (template-define-start arg "(%S %S %S %S %S)"
- key prompt prefix suffix default))
-
-(defun template-define-register (arg register)
- "Insert a setting of REGISTER into template.
-For ARG, see `template-define-start'."
- (interactive "P\ncDefine register: ")
- (let* ((old (get-register register))
- (contents (read-from-minibuffer "Register contents: "
- (and (stringp old)
- (not (string-match "\n" old))
- old)))
- (comment (read-from-minibuffer "Comment (empty=none): ")))
- (if (string= comment "")
- (template-define-start arg "(%S %S)" register contents)
- (template-define-start arg "(%S %S %S)" register contents comment))))
-
-
-;;;===========================================================================
-;;; Initialization
-;;;===========================================================================
-
-;; easymenu.el is for top-level menus only...
-(defunx template-add-submenu (menu &optional where)
- "Add the submenu MENU to the end of a menu in WHERE in the menubar.
-WHERE is a list of menus tried to add MENU to. If no such menu exist,
-no menu is added. When using Emacs, always add to the \"Edit\" menu.
-See `easy-menu-define' for the format of MENU."
- (and menu
- :EMACS
- (>= emacs-major-version 21)
- (boundp 'menu-bar-edit-menu)
- (let ((keymap (easy-menu-create-menu (car menu) (cdr menu))))
- ;; `easy-menu-get-map' doesn't get the right one => use hard-coded
- (define-key-after menu-bar-edit-menu (vector (intern (car menu)))
- (cons 'menu-item
- (cons (car menu)
- (if (not (symbolp keymap))
- (list keymap)
- (cons (symbol-function keymap)
- (get keymap 'menu-prop)))))))
- :XEMACS
- (featurep 'menubar)
- (let ((current-menubar default-menubar) path)
- (while where
- (setq path (list (pop where)))
- (if (find-menu-item default-menubar path)
- (setq where nil)
- (setq path nil)))
- (when path (add-submenu path menu)))))
-
-;;;###autoload
-(defunx template-initialize (&rest dummies)
- ;; checkdoc-params: (dummies)
- "Initialized package template. See variable `template-initialize'."
- (interactive)
- (setq template-use-package t)
- (let ((regexp (concat (regexp-quote template-extension) "\\'")))
- (or (assoc regexp auto-mode-alist)
- (push (list regexp nil 'template-new-file) auto-mode-alist)))
- (when (or (eq template-initialize t)
- (memq 'cc-mode template-initialize))
- (add-hook 'c-mode-common-hook 'template-c-init-fill-function)
- (add-hook 'antlr-mode-hook 'template-c-init-fill-function))
- (when (or (eq template-initialize t)
- (memq 'de-html-helper template-initialize))
- (setq html-helper-build-new-buffer nil)
- (setq html-helper-do-write-file-hooks nil))
- (when (or (eq template-initialize t)
- (memq 'keys template-initialize))
- (condition-case nil ; older Emacses don't understand all
- (progn
- (define-key ctl-x-map "t" 'template-new-file)
- (define-key ctl-x-map [(control =)] 'template-single-comment)
- (define-key ctl-x-map [(control ?\;)] 'template-block-comment))
- (error nil)))
- (when (or (eq template-initialize t)
- (memq 'menus template-initialize))
- (template-add-submenu template-comment-menu :XEMACS '("Edit"))
- (template-add-submenu template-creation-menu :XEMACS '("Cmds" "Edit"))
- :EMACS
- (and (boundp 'menu-bar-files-menu)
- (define-key-after menu-bar-files-menu [template-new-file]
- '(menu-item "New File Using Template..." template-new-file
- :enable (not (window-minibuffer-p
- (frame-selected-window
- menu-updating-frame)))
- :help "Create a new file, using a template")
- 'dired))
- :XEMACS
- (and (featurep 'menubar)
- (find-menu-item default-menubar '("File"))
- (let ((current-menubar default-menubar))
- ;; XEmacs-20.4 `add-submenu' does not have 4th arg IN-MENU
- (add-menu-button '("File")
- ["New File Using Template..." template-new-file
- :active t]
- "Insert File..."))))
- (if (and (boundp 'init-file-loaded) init-file-loaded)
- ;; doesn't exist in Emacs
- (template-after-init)
- (add-hook 'after-init-hook 'template-after-init t)))
-
-(defun template-after-init ()
- "Late initialization for package template.
-See function and variable `template-initialize'."
- (when (or (eq template-initialize t)
- (memq 'auto template-initialize))
- (add-hook 'write-file-hooks 'template-update-buffer)
- (add-hook 'find-file-not-found-hooks 'template-not-found-function t))
- (when (or (eq template-initialize t)
- (memq 'ffap template-initialize))
- (or template-ffap-file-finder
- (setq template-ffap-file-finder
- (if (boundp 'ffap-file-finder)
- ffap-file-finder
- (or (get 'ffap-file-finder 'saved-value) 'find-file))))
- (setq ffap-file-finder 'template-ffap-find-file)))
-
-;;; Local IspellPersDict: .ispell_template
-;;; template.el ends here
+++ /dev/null
-;;; yaml-mode.el --- Major mode for editing YAML files
-
-;; Copyright (C) 2010-2013 Yoshiki Kurihara
-
-;; Author: Yoshiki Kurihara <clouderNOSPAMgmail.com>
-;; Marshall T. Vandegrift <llasramNOSPAMgmail.com>
-;; Keywords: data yaml
-;; Version: 0.0.9
-
-;; This file is not part of 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 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 is a major mode for editing files in the YAML data
-;; serialization format. It was initially developed by Yoshiki
-;; Kurihara and many features were added by Marshall Vandegrift. As
-;; YAML and Python share the fact that indentation determines
-;; structure, this mode provides indentation and indentation command
-;; behavior very similar to that of python-mode.
-
-;;; Installation:
-
-;; To install, just drop this file into a directory in your
-;; `load-path' and (optionally) byte-compile it. To automatically
-;; handle files ending in '.yml', add something like:
-;;
-;; (require 'yaml-mode)
-;; (add-to-list 'auto-mode-alist '("\\.yml$" . yaml-mode))
-;;
-;; to your .emacs file.
-;;
-;; Unlike python-mode, this mode follows the Emacs convention of not
-;; binding the ENTER key to `newline-and-indent'. To get this
-;; behavior, add the key definition to `yaml-mode-hook':
-;;
-;; (add-hook 'yaml-mode-hook
-;; '(lambda ()
-;; (define-key yaml-mode-map "\C-m" 'newline-and-indent)))
-
-;;; Known Bugs:
-
-;; YAML is easy to write but complex to parse, and this mode doesn't
-;; even really try. Indentation and highlighting will break on
-;; abnormally complicated structures.
-
-;;; Code:
-
-\f
-;; User definable variables
-
-;;;###autoload
-(defgroup yaml nil
- "Support for the YAML serialization format"
- :group 'languages
- :prefix "yaml-")
-
-(defcustom yaml-mode-hook nil
- "*Hook run by `yaml-mode'."
- :type 'hook
- :group 'yaml)
-
-(defcustom yaml-indent-offset 2
- "*Amount of offset per level of indentation."
- :type 'integer
- :group 'yaml)
-
-(defcustom yaml-backspace-function 'backward-delete-char-untabify
- "*Function called by `yaml-electric-backspace' when deleting backwards.
-It will receive one argument, the numeric prefix value."
- :type 'function
- :group 'yaml)
-
-(defcustom yaml-block-literal-search-lines 100
- "*Maximum number of lines to search for start of block literals."
- :type 'integer
- :group 'yaml)
-
-(defcustom yaml-block-literal-electric-alist
- '((?| . "") (?> . "-"))
- "*Characters for which to provide electric behavior.
-The association list key should be a key code and the associated value
-should be a string containing additional characters to insert when
-that key is pressed to begin a block literal."
- :type 'alist
- :group 'yaml)
-
-(defface yaml-tab-face
- '((((class color)) (:background "red" :foreground "red" :bold t))
- (t (:reverse-video t)))
- "Face to use for highlighting tabs in YAML files."
- :group 'faces
- :group 'yaml)
-
-(defcustom yaml-imenu-generic-expression
- '((nil "^\\(:?[a-zA-Z_-]+\\):" 1))
- "The imenu regex to parse an outline of the yaml file."
- :type 'string
- :group 'yaml)
-
-\f
-;; Constants
-
-(defconst yaml-mode-version "0.0.9" "Version of `yaml-mode'.")
-
-(defconst yaml-blank-line-re "^ *$"
- "Regexp matching a line containing only (valid) whitespace.")
-
-(defconst yaml-comment-re "\\(?:^\\|\\s-+\\)\\(#.*\\)"
- "Regexp matching a line containing a YAML comment or delimiter.")
-
-(defconst yaml-directive-re "^\\(?:--- \\)? *%\\(\\w+\\)"
- "Regexp matching a line contatining a YAML directive.")
-
-(defconst yaml-document-delimiter-re "^ *\\(?:---\\|[.][.][.]\\)"
- "Rexexp matching a YAML document delimiter line.")
-
-(defconst yaml-node-anchor-alias-re "[&*][a-zA-Z0-9_-]+"
- "Regexp matching a YAML node anchor or alias.")
-
-(defconst yaml-tag-re "!!?[^ \n]+"
- "Rexexp matching a YAML tag.")
-
-(defconst yaml-bare-scalar-re
- "\\(?:[^-:,#!\n{\\[ ]\\|[^#!\n{\\[ ]\\S-\\)[^#\n]*?"
- "Rexexp matching a YAML bare scalar.")
-
-(defconst yaml-hash-key-re
- (concat "\\(?:^\\(?:--- \\)?\\|{\\|\\(?:[-,] +\\)+\\) *"
- "\\(?:" yaml-tag-re " +\\)?"
- "\\(" yaml-bare-scalar-re "\\) *:"
- "\\(?: +\\|$\\)")
- "Regexp matching a single YAML hash key.")
-
-(defconst yaml-scalar-context-re
- (concat "\\(?:^\\(?:--- \\)?\\|{\\|\\(?:[-,] +\\)+\\) *"
- "\\(?:" yaml-bare-scalar-re " *: \\)?")
- "Regexp indicating the begininng of a scalar context.")
-
-(defconst yaml-nested-map-re
- (concat ".*: *\\(?:&.*\\|{ *\\|" yaml-tag-re " *\\)?$")
- "Regexp matching a line beginning a YAML nested structure.")
-
-(defconst yaml-block-literal-base-re " *[>|][-+0-9]* *\\(?:\n\\|\\'\\)"
- "Regexp matching the substring start of a block literal.")
-
-(defconst yaml-block-literal-re
- (concat yaml-scalar-context-re
- "\\(?:" yaml-tag-re "\\)?"
- yaml-block-literal-base-re)
- "Regexp matching a line beginning a YAML block literal.")
-
-(defconst yaml-nested-sequence-re
- (concat "^\\(?: *- +\\)+"
- "\\(?:" yaml-bare-scalar-re " *:\\(?: +.*\\)?\\)?$")
- "Regexp matching a line containing one or more nested YAML sequences.")
-
-(defconst yaml-constant-scalars-re
- (concat "\\(?:^\\|\\(?::\\|-\\|,\\|{\\|\\[\\) +\\) *"
- (regexp-opt
- '("~" "null" "Null" "NULL"
- ".nan" ".NaN" ".NAN"
- ".inf" ".Inf" ".INF"
- "-.inf" "-.Inf" "-.INF"
- "y" "Y" "yes" "Yes" "YES" "n" "N" "no" "No" "NO"
- "true" "True" "TRUE" "false" "False" "FALSE"
- "on" "On" "ON" "off" "Off" "OFF") t)
- " *$")
- "Regexp matching certain scalar constants in scalar context.")
-
-\f
-;; Mode setup
-
-(defvar yaml-mode-map ()
- "Keymap used in `yaml-mode' buffers.")
-(if yaml-mode-map
- nil
- (setq yaml-mode-map (make-sparse-keymap))
- (define-key yaml-mode-map "|" 'yaml-electric-bar-and-angle)
- (define-key yaml-mode-map ">" 'yaml-electric-bar-and-angle)
- (define-key yaml-mode-map "-" 'yaml-electric-dash-and-dot)
- (define-key yaml-mode-map "." 'yaml-electric-dash-and-dot)
- (define-key yaml-mode-map [backspace] 'yaml-electric-backspace)
- (define-key yaml-mode-map "\C-j" 'newline-and-indent))
-
-(defvar yaml-mode-syntax-table nil
- "Syntax table in use in `yaml-mode' buffers.")
-(if yaml-mode-syntax-table
- nil
- (setq yaml-mode-syntax-table (make-syntax-table))
- (modify-syntax-entry ?\' "\"" yaml-mode-syntax-table)
- (modify-syntax-entry ?\" "\"" yaml-mode-syntax-table)
- (modify-syntax-entry ?# "<" yaml-mode-syntax-table)
- (modify-syntax-entry ?\n ">" yaml-mode-syntax-table)
- (modify-syntax-entry ?\\ "\\" yaml-mode-syntax-table)
- (modify-syntax-entry ?- "w" yaml-mode-syntax-table)
- (modify-syntax-entry ?_ "_" yaml-mode-syntax-table)
- (modify-syntax-entry ?\( "." yaml-mode-syntax-table)
- (modify-syntax-entry ?\) "." yaml-mode-syntax-table)
- (modify-syntax-entry ?\{ "(}" yaml-mode-syntax-table)
- (modify-syntax-entry ?\} "){" yaml-mode-syntax-table)
- (modify-syntax-entry ?\[ "(]" yaml-mode-syntax-table)
- (modify-syntax-entry ?\] ")[" yaml-mode-syntax-table))
-
-;;;###autoload
-(define-derived-mode yaml-mode fundamental-mode "YAML"
- "Simple mode to edit YAML.
-
-\\{yaml-mode-map}"
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-start-skip) "#+ *")
- (set (make-local-variable 'indent-line-function) 'yaml-indent-line)
- (set (make-local-variable 'indent-tabs-mode) nil)
- (set (make-local-variable 'font-lock-defaults)
- '(yaml-font-lock-keywords
- nil nil nil nil
- (font-lock-syntactic-keywords . yaml-font-lock-syntactic-keywords))))
-
-\f
-;; Font-lock support
-
-(defvar yaml-font-lock-keywords
- (list
- (cons yaml-comment-re '(1 font-lock-comment-face))
- (cons yaml-constant-scalars-re '(1 font-lock-constant-face))
- (cons yaml-tag-re '(0 font-lock-type-face))
- (cons yaml-node-anchor-alias-re '(0 font-lock-function-name-face t))
- (cons yaml-hash-key-re '(1 font-lock-variable-name-face t))
- (cons yaml-document-delimiter-re '(0 font-lock-comment-face))
- (cons yaml-directive-re '(1 font-lock-builtin-face))
- '(yaml-font-lock-block-literals 0 font-lock-string-face t)
- '("^[\t]+" 0 'yaml-tab-face t))
- "Additional expressions to highlight in YAML mode.")
-
-(defvar yaml-font-lock-syntactic-keywords
- (list '(yaml-syntactic-block-literals 0 "." t))
- "Additional syntax features to highlight in YAML mode.")
-
-
-(defun yaml-font-lock-block-literals (bound)
- "Find lines within block literals.
-Find the next line of the first (if any) block literal after point and
-prior to BOUND. Returns the beginning and end of the block literal
-line in the match data, as consumed by `font-lock-keywords' matcher
-functions. The function begins by searching backwards to determine
-whether or not the current line is within a block literal. This could
-be time-consuming in large buffers, so the number of lines searched is
-artificially limitted to the value of
-`yaml-block-literal-search-lines'."
- (if (eolp) (goto-char (1+ (point))))
- (unless (or (eobp) (>= (point) bound))
- (let ((begin (point))
- (end (min (1+ (point-at-eol)) bound)))
- (goto-char (point-at-bol))
- (while (and (looking-at yaml-blank-line-re) (not (bobp)))
- (forward-line -1))
- (let ((nlines yaml-block-literal-search-lines)
- (min-level (current-indentation)))
- (forward-line -1)
- (while (and (/= nlines 0)
- (/= min-level 0)
- (not (looking-at yaml-block-literal-re))
- (not (bobp)))
- (set 'nlines (1- nlines))
- (unless (looking-at yaml-blank-line-re)
- (set 'min-level (min min-level (current-indentation))))
- (forward-line -1))
- (cond
- ((and (< (current-indentation) min-level)
- (looking-at yaml-block-literal-re))
- (goto-char end) (set-match-data (list begin end)) t)
- ((progn
- (goto-char begin)
- (re-search-forward (concat yaml-block-literal-re
- " *\\(.*\\)\n")
- bound t))
- (set-match-data (nthcdr 2 (match-data))) t))))))
-
-(defun yaml-syntactic-block-literals (bound)
- "Find quote characters within block literals.
-Finds the first quote character within a block literal (if any) after
-point and prior to BOUND. Returns the position of the quote character
-in the match data, as consumed by matcher functions in
-`font-lock-syntactic-keywords'. This allows the mode to treat ['\"]
-characters in block literals as punctuation syntax instead of string
-syntax, preventing unmatched quotes in block literals from painting
-the entire buffer in `font-lock-string-face'."
- (let ((found nil))
- (while (and (not found)
- (/= (point) bound)
- (yaml-font-lock-block-literals bound))
- (let ((begin (match-beginning 0)) (end (match-end 0)))
- (goto-char begin)
- (cond
- ((re-search-forward "['\"]" end t) (setq found t))
- ((goto-char end)))))
- found))
-
-\f
-;; Indentation and electric keys
-
-(defun yaml-compute-indentation ()
- "Calculate the maximum sensible indentation for the current line."
- (save-excursion
- (beginning-of-line)
- (if (looking-at yaml-document-delimiter-re) 0
- (forward-line -1)
- (while (and (looking-at yaml-blank-line-re)
- (> (point) (point-min)))
- (forward-line -1))
- (+ (current-indentation)
- (if (looking-at yaml-nested-map-re) yaml-indent-offset 0)
- (if (looking-at yaml-nested-sequence-re) yaml-indent-offset 0)
- (if (looking-at yaml-block-literal-re) yaml-indent-offset 0)))))
-
-(defun yaml-indent-line ()
- "Indent the current line.
-The first time this command is used, the line will be indented to the
-maximum sensible indentation. Each immediately subsequent usage will
-back-dent the line by `yaml-indent-offset' spaces. On reaching column
-0, it will cycle back to the maximum sensible indentation."
- (interactive "*")
- (let ((ci (current-indentation))
- (cc (current-column))
- (need (yaml-compute-indentation)))
- (save-excursion
- (beginning-of-line)
- (delete-horizontal-space)
- (if (and (equal last-command this-command) (/= ci 0))
- (indent-to (* (/ (- ci 1) yaml-indent-offset) yaml-indent-offset))
- (indent-to need)))
- (if (< (current-column) (current-indentation))
- (forward-to-indentation 0))))
-
-(defun yaml-electric-backspace (arg)
- "Delete characters or back-dent the current line.
-If invoked following only whitespace on a line, will back-dent to the
-immediately previous multiple of `yaml-indent-offset' spaces."
- (interactive "*p")
- (if (or (/= (current-indentation) (current-column)) (bolp))
- (funcall yaml-backspace-function arg)
- (let ((ci (current-column)))
- (beginning-of-line)
- (delete-horizontal-space)
- (indent-to (* (/ (- ci (* arg yaml-indent-offset))
- yaml-indent-offset)
- yaml-indent-offset)))))
-
-(defun yaml-electric-bar-and-angle (arg)
- "Insert the bound key and possibly begin a block literal.
-Inserts the bound key. If inserting the bound key causes the current
-line to match the initial line of a block literal, then inserts the
-matching string from `yaml-block-literal-electric-alist', a newline,
-and indents appropriately."
- (interactive "*P")
- (self-insert-command (prefix-numeric-value arg))
- (let ((extra-chars
- (assoc last-command-event
- yaml-block-literal-electric-alist)))
- (cond
- ((and extra-chars (not arg) (eolp)
- (save-excursion
- (beginning-of-line)
- (looking-at yaml-block-literal-re)))
- (insert (cdr extra-chars))
- (newline-and-indent)))))
-
-(defun yaml-electric-dash-and-dot (arg)
- "Insert the bound key and possibly de-dent line.
-Inserts the bound key. If inserting the bound key causes the current
-line to match a document delimiter, de-dent the line to the left
-margin."
- (interactive "*P")
- (self-insert-command (prefix-numeric-value arg))
- (save-excursion
- (beginning-of-line)
- (if (and (not arg) (looking-at yaml-document-delimiter-re))
- (delete-horizontal-space))))
-
-
-(defun yaml-set-imenu-generic-expression ()
- (make-local-variable 'imenu-generic-expression)
- (make-local-variable 'imenu-create-index-function)
- (setq imenu-create-index-function 'imenu-default-create-index-function)
- (setq imenu-generic-expression yaml-imenu-generic-expression))
-
-(add-hook 'yaml-mode-hook 'yaml-set-imenu-generic-expression)
-
-
-(defun yaml-mode-version ()
- "Diplay version of `yaml-mode'."
- (interactive)
- (message "yaml-mode %s" yaml-mode-version)
- yaml-mode-version)
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.ya?ml$" . yaml-mode))
-
-(provide 'yaml-mode)
-
-;;; yaml-mode.el ends here
projects / emacsconfig.git / commitdiff