diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/filladapt.el | 981 | ||||
| -rw-r--r-- | lisp/promela-mode.el | 985 | ||||
| -rw-r--r-- | lisp/template.el | 2609 | ||||
| -rw-r--r-- | lisp/themes/color-themes-alex.el | 48 | ||||
| -rw-r--r-- | lisp/themes/color-themes-monokai-alex.el | 33 | ||||
| -rw-r--r-- | lisp/winring.el | 597 |
6 files changed, 5253 insertions, 0 deletions
diff --git a/lisp/filladapt.el b/lisp/filladapt.el new file mode 100644 index 0000000..4ae63ab --- /dev/null +++ b/lisp/filladapt.el @@ -0,0 +1,981 @@ +;;; Adaptive fill +;;; Copyright (C) 1989, 1995-1998 Kyle E. Jones +;;; +;;; 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. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to kyle@uunet.uu.net) or from +;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +;;; 02139, USA. +;;; +;;; Send bug reports to kyle_jones@wonderworks.com + +;; LCD Archive Entry: +;; filladapt|Kyle Jones|kyle_jones@wonderworks.com| +;; Minor mode to adaptively set fill-prefix and overload filling functions| +;; 28-February-1998|2.12|~/packages/filladapt.el| + +;; These functions enhance the default behavior of Emacs' Auto Fill +;; mode and the commands fill-paragraph, lisp-fill-paragraph, +;; fill-region-as-paragraph and fill-region. +;; +;; The chief improvement is that the beginning of a line to be +;; filled is examined and, based on information gathered, an +;; appropriate value for fill-prefix is constructed. Also the +;; boundaries of the current paragraph are located. This occurs +;; only if the fill prefix is not already non-nil. +;; +;; The net result of this is that blurbs of text that are offset +;; from left margin by asterisks, dashes, and/or spaces, numbered +;; examples, included text from USENET news articles, etc. are +;; generally filled correctly with no fuss. +;; +;; Since this package replaces existing Emacs functions, it cannot +;; be autoloaded. Save this in a file named filladapt.el in a +;; Lisp directory that Emacs knows about, byte-compile it and put +;; (require 'filladapt) +;; in your .emacs file. +;; +;; Note that in this release Filladapt mode is a minor mode and it is +;; _off_ by default. If you want it to be on by default, use +;; (setq-default filladapt-mode t) +;; +;; M-x filladapt-mode toggles Filladapt mode on/off in the current +;; buffer. +;; +;; Use +;; (add-hook 'text-mode-hook 'turn-on-filladapt-mode) +;; to have Filladapt always enabled in Text mode. +;; +;; Use +;; (add-hook 'c-mode-hook 'turn-off-filladapt-mode) +;; to have Filladapt always disabled in C mode. +;; +;; In many cases, you can extend Filladapt by adding appropriate +;; entries to the following three `defvar's. See `postscript-comment' +;; or `texinfo-comment' as a sample of what needs to be done. +;; +;; filladapt-token-table +;; filladapt-token-match-table +;; filladapt-token-conversion-table + +(and (featurep 'filladapt) + (error "filladapt cannot be loaded twice in the same Emacs session.")) + +(provide 'filladapt) + +(defvar filladapt-version "2.12" + "Version string for filladapt.") + +;; BLOB to make custom stuff work even without customize +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) + nil ;; We've got what we needed + ;; We have the old custom-library, hack around it! + (defmacro defgroup (&rest args) + nil) + (defmacro defcustom (var value doc &rest args) + (` (defvar (, var) (, value) (, doc)))))) + +(defgroup filladapt nil + "Enhanced filling" + :group 'fill) + +(defvar filladapt-mode nil + "Non-nil means that Filladapt minor mode is enabled. +Use the filladapt-mode command to toggle the mode on/off.") +(make-variable-buffer-local 'filladapt-mode) + +(defcustom filladapt-mode-line-string " Filladapt" + "*String to display in the modeline when Filladapt mode is active. +Set this to nil if you don't want a modeline indicator for Filladapt." + :type 'string + :group 'filladapt) + +(defcustom filladapt-fill-column-tolerance nil + "*Tolerate filled paragraph lines ending this far from the fill column. +If any lines other than the last paragraph line end at a column +less than fill-column - filladapt-fill-column-tolerance, fill-column will +be adjusted using the filladapt-fill-column-*-fuzz variables and +the paragraph will be re-filled until the tolerance is achieved +or filladapt runs out of fuzz values to try. + +A nil value means behave normally, that is, don't try refilling +paragraphs to make filled line lengths fit within any particular +range." + :type '(choice (const nil) + integer) + :group 'filladapt) + +(defcustom filladapt-fill-column-forward-fuzz 5 + "*Try values from fill-column to fill-column plus this variable +when trying to make filled paragraph lines fall with the tolerance +range specified by filladapt-fill-column-tolerance." + :type 'integer + :group 'filladapt) + +(defcustom filladapt-fill-column-backward-fuzz 5 + "*Try values from fill-column to fill-column minus this variable +when trying to make filled paragraph lines fall with the tolerance +range specified by filladapt-fill-column-tolerance." + :type 'integer + :group 'filladapt) + +;; install on minor-mode-alist +(or (assq 'filladapt-mode minor-mode-alist) + (setq minor-mode-alist (cons (list 'filladapt-mode + 'filladapt-mode-line-string) + minor-mode-alist))) + +(defcustom filladapt-token-table + '( + ;; this must be first + ("^" beginning-of-line) + ;; Included text in news or mail replies + (">+" citation->) + ;; Included text generated by SUPERCITE. We can't hope to match all + ;; the possible variations, your mileage may vary. + ("\\(\\w\\|[0-9]\\)[^'`\"< \t\n]*>[ \t]*" supercite-citation) + ;; Lisp comments + (";+" lisp-comment) + ;; UNIX shell comments + ("#+" sh-comment) + ;; Postscript comments + ("%+" postscript-comment) + ;; C++ comments + ("///*" c++-comment) + ;; Texinfo comments + ("@c[ \t]" texinfo-comment) + ("@comment[ \t]" texinfo-comment) + ;; Bullet types. + ;; + ;; LaTex \item + ;; + ("\\\\item[ \t]" bullet) + ;; + ;; 1. xxxxx + ;; xxxxx + ;; + ("[0-9]+\\.[ \t]" bullet) + ;; + ;; 2.1.3 xxxxx xx x xx x + ;; xxx + ;; + ("[0-9]+\\(\\.[0-9]+\\)+[ \t]" bullet) + ;; + ;; a. xxxxxx xx + ;; xxx xxx + ;; + ("[A-Za-z]\\.[ \t]" bullet) + ;; + ;; 1) xxxx x xx x xx or (1) xx xx x x xx xx + ;; xx xx xxxx xxx xx x x xx x + ;; + ("(?[0-9]+)[ \t]" bullet) + ;; + ;; a) xxxx x xx x xx or (a) xx xx x x xx xx + ;; xx xx xxxx xxx xx x x xx x + ;; + ("(?[A-Za-z])[ \t]" bullet) + ;; + ;; 2a. xx x xxx x x xxx + ;; xxx xx x xx x + ;; + ("[0-9]+[A-Za-z]\\.[ \t]" bullet) + ;; + ;; 1a) xxxx x xx x xx or (1a) xx xx x x xx xx + ;; xx xx xxxx xxx xx x x xx x + ;; + ("(?[0-9]+[A-Za-z])[ \t]" bullet) + ;; + ;; - xx xxx xxxx or * xx xx x xxx xxx + ;; xxx xx xx x xxx x xx x x x + ;; + ("[-~*+]+[ \t]" bullet) + ;; + ;; o xx xxx xxxx xx x xx xxx x xxx xx x xxx + ;; xxx xx xx + ;; + ("o[ \t]" bullet) + ;; don't touch + ("[ \t]+" space) + ("$" end-of-line) + ) + "Table of tokens filladapt knows about. +Format is + + ((REGEXP SYM) ...) + +filladapt uses this table to build a tokenized representation of +the beginning of the current line. Each REGEXP is matched +against the beginning of the line until a match is found. +Matching is done case-sensitively. The corresponding SYM is +added to the list, point is moved to (match-end 0) and the +process is repeated. The process ends when there is no REGEXP in +the table that matches what is at point." + :type '(repeat (list regexp symbol)) + :group 'filladapt) + +(defcustom filladapt-not-token-table + '( + "[Ee]\\.g\\.[ \t,]" + "[Ii]\\.e\\.[ \t,]" + ;; end-of-line isn't a token if whole line is empty + "^$" + ) + "List of regexps that can never be a token. +Before trying the regular expressions in filladapt-token-table, +the regexps in this list are tried. If any regexp in this list +matches what is at point then the token generator gives up and +doesn't try any of the regexps in filladapt-token-table. + +Regexp matching is done case-sensitively." + :type '(repeat regexp) + :group 'filladapt) + +(defcustom filladapt-token-match-table + '( + (citation-> citation->) + (supercite-citation supercite-citation) + (lisp-comment lisp-comment) + (sh-comment sh-comment) + (postscript-comment postscript-comment) + (c++-comment c++-comment) + (texinfo-comment texinfo-comment) + (bullet) + (space bullet space) + (beginning-of-line beginning-of-line) + ) + "Table describing what tokens a certain token will match. + +To decide whether a line belongs in the current paragraph, +filladapt creates a token list for the fill prefix of both lines. +Tokens and the columns where tokens end are compared. This table +specifies what a certain token will match. + +Table format is + + (SYM [SYM1 [SYM2 ...]]) + +The first symbol SYM is the token, subsequent symbols are the +tokens that SYM will match." + :type '(repeat (repeat symbol)) + :group 'filladapt) + +(defcustom filladapt-token-match-many-table + '( + space + ) + "List of tokens that can match multiple tokens. +If one of these tokens appears in a token list, it will eat all +matching tokens in a token list being matched against it until it +encounters a token that doesn't match or a token that ends on +a greater column number." + :type '(repeat symbol) + :group 'filladapt) + +(defcustom filladapt-token-paragraph-start-table + '( + bullet + ) + "List of tokens that indicate the start of a paragraph. +If parsing a line generates a token list containing one of +these tokens, then the line is considered to be the start of a +paragraph." + :type '(repeat symbol) + :group 'filladapt) + +(defcustom filladapt-token-conversion-table + '( + (citation-> . exact) + (supercite-citation . exact) + (lisp-comment . exact) + (sh-comment . exact) + (postscript-comment . exact) + (c++-comment . exact) + (texinfo-comment . exact) + (bullet . spaces) + (space . exact) + (end-of-line . exact) + ) + "Table that specifies how to convert a token into a fill prefix. +Table format is + + ((SYM . HOWTO) ...) + +SYM is the symbol naming the token to be converted. +HOWTO specifies how to do the conversion. + `exact' means copy the token's string directly into the fill prefix. + `spaces' means convert all characters in the token string that are + not a TAB or a space into spaces and copy the resulting string into + the fill prefix." + :type '(repeat (cons symbol (choice (const exact) + (const spaces)))) + :group 'filladapt) + +(defvar filladapt-function-table + (let ((assoc-list + (list (cons 'fill-paragraph (symbol-function 'fill-paragraph)) + (cons 'fill-region (symbol-function 'fill-region)) + (cons 'fill-region-as-paragraph + (symbol-function 'fill-region-as-paragraph)) + (cons 'do-auto-fill (symbol-function 'do-auto-fill))))) + ;; v18 Emacs doesn't have lisp-fill-paragraph + (if (fboundp 'lisp-fill-paragraph) + (nconc assoc-list + (list (cons 'lisp-fill-paragraph + (symbol-function 'lisp-fill-paragraph))))) + assoc-list ) + "Table containing the old function definitions that filladapt usurps.") + +(defcustom filladapt-fill-paragraph-post-hook nil + "Hooks run after filladapt runs fill-paragraph." + :type 'hook + :group 'filladapt) + +(defvar filladapt-inside-filladapt nil + "Non-nil if the filladapt version of a fill function executing. +Currently this is only checked by the filladapt version of +fill-region-as-paragraph to avoid this infinite recursion: + + fill-region-as-paragraph -> fill-paragraph -> fill-region-as-paragraph ...") + +(defcustom filladapt-debug nil + "Non-nil means filladapt debugging is enabled. +Use the filladapt-debug command to turn on debugging. + +With debugging enabled, filladapt will + + a. display the proposed indentation with the tokens highlighted + using filladapt-debug-indentation-face-1 and + filladapt-debug-indentation-face-2. + b. display the current paragraph using the face specified by + filladapt-debug-paragraph-face." + :type 'boolean + :group 'filladapt) + +(if filladapt-debug + (add-hook 'post-command-hook 'filladapt-display-debug-info-maybe)) + +(defvar filladapt-debug-indentation-face-1 'highlight + "Face used to display the indentation when debugging is enabled.") + +(defvar filladapt-debug-indentation-face-2 'secondary-selection + "Another face used to display the indentation when debugging is enabled.") + +(defvar filladapt-debug-paragraph-face 'bold + "Face used to display the current paragraph when debugging is enabled.") + +(defvar filladapt-debug-indentation-extents nil) +(make-variable-buffer-local 'filladapt-debug-indentation-extents) +(defvar filladapt-debug-paragraph-extent nil) +(make-variable-buffer-local 'filladapt-debug-paragraph-extent) + +;; kludge city, see references in code. +(defvar filladapt-old-line-prefix) + +(defun do-auto-fill () + (catch 'done + (if (and filladapt-mode (null fill-prefix)) + (save-restriction + (let ((paragraph-ignore-fill-prefix nil) + ;; if the user wanted this stuff, they probably + ;; wouldn't be using filladapt-mode. + (adaptive-fill-mode nil) + (adaptive-fill-regexp nil) + ;; need this or Emacs 19 ignores fill-prefix when + ;; inside a comment. + (comment-multi-line t) + (filladapt-inside-filladapt t) + fill-prefix retval) + (if (filladapt-adapt nil nil) + (progn + (setq retval (filladapt-funcall 'do-auto-fill)) + (throw 'done retval)))))) + (filladapt-funcall 'do-auto-fill))) + +(defun filladapt-fill-paragraph (function arg) + (catch 'done + (if (and filladapt-mode (null fill-prefix)) + (save-restriction + (let ((paragraph-ignore-fill-prefix nil) + ;; if the user wanted this stuff, they probably + ;; wouldn't be using filladapt-mode. + (adaptive-fill-mode nil) + (adaptive-fill-regexp nil) + ;; need this or Emacs 19 ignores fill-prefix when + ;; inside a comment. + (comment-multi-line t) + fill-prefix retval) + (if (filladapt-adapt t nil) + (progn + (if filladapt-fill-column-tolerance + (let* ((low (- fill-column + filladapt-fill-column-backward-fuzz)) + (high (+ fill-column + filladapt-fill-column-forward-fuzz)) + (old-fill-column fill-column) + (fill-column fill-column) + (lim (- high low)) + (done nil) + (sign 1) + (delta 0)) + (while (not done) + (setq retval (filladapt-funcall function arg)) + (if (filladapt-paragraph-within-fill-tolerance) + (setq done 'success) + (setq delta (1+ delta) + sign (* sign -1) + fill-column (+ fill-column (* delta sign))) + (while (and (<= delta lim) + (or (< fill-column low) + (> fill-column high))) + (setq delta (1+ delta) + sign (* sign -1) + fill-column (+ fill-column + (* delta sign)))) + (setq done (> delta lim)))) + ;; if the paragraph lines never fell + ;; within the tolerances, refill using + ;; the old fill-column. + (if (not (eq done 'success)) + (let ((fill-column old-fill-column)) + (setq retval (filladapt-funcall function arg))))) + (setq retval (filladapt-funcall function arg))) + (run-hooks 'filladapt-fill-paragraph-post-hook) + (throw 'done retval)))))) + ;; filladapt-adapt failed, so do fill-paragraph normally. + (filladapt-funcall function arg))) + +(defun fill-paragraph (arg) + "Fill paragraph at or after point. Prefix arg means justify as well. + +(This function has been overloaded with the `filladapt' version.) + +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there. + +If `fill-paragraph-function' is non-nil, we call it (passing our +argument to it), and if it returns non-nil, we simply return its value." + (interactive "*P") + (let ((filladapt-inside-filladapt t)) + (filladapt-fill-paragraph 'fill-paragraph arg))) + +(defun lisp-fill-paragraph (&optional arg) + "Like \\[fill-paragraph], but handle Emacs Lisp comments. + +(This function has been overloaded with the `filladapt' version.) + +If any of the current line is a comment, fill the comment or the +paragraph of it that point is in, preserving the comment's indentation +and initial semicolons." + (interactive "*P") + (let ((filladapt-inside-filladapt t)) + (filladapt-fill-paragraph 'lisp-fill-paragraph arg))) + +(defun fill-region-as-paragraph (beg end &optional justify + nosqueeze squeeze-after) + "Fill the region as one paragraph. + +(This function has been overloaded with the `filladapt' version.) + +It removes any paragraph breaks in the region and extra newlines at the end, +indents and fills lines between the margins given by the +`current-left-margin' and `current-fill-column' functions. +It leaves point at the beginning of the line following the paragraph. + +Normally performs justification according to the `current-justification' +function, but with a prefix arg, does full justification instead. + +From a program, optional third arg JUSTIFY can specify any type of +justification. Fourth arg NOSQUEEZE non-nil means not to make spaces +between words canonical before filling. Fifth arg SQUEEZE-AFTER, if non-nil, +means don't canonicalize spaces before that position. + +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there." + (interactive "*r\nP") + (if (and filladapt-mode (not filladapt-inside-filladapt)) + (save-restriction + (narrow-to-region beg end) + (let ((filladapt-inside-filladapt t) + line-start last-token) + (goto-char beg) + (while (equal (char-after (point)) ?\n) + (delete-char 1)) + (end-of-line) + (while (zerop (forward-line)) + (if (setq last-token + (car (filladapt-tail (filladapt-parse-prefixes)))) + (progn + (setq line-start (point)) + (move-to-column (nth 1 last-token)) + (delete-region line-start (point)))) + ;; Dance... + ;; + ;; Do this instead of (delete-char -1) to keep + ;; markers on the correct side of the whitespace. + (goto-char (1- (point))) + (insert " ") + (delete-char 1) + + (end-of-line)) + (goto-char beg) + (fill-paragraph justify)) + ;; In XEmacs 19.12 and Emacs 18.59 fill-region relies on + ;; fill-region-as-paragraph to do this. If we don't do + ;; it, fill-region will spin in an endless loop. + (goto-char (point-max))) + (condition-case nil + ;; five args for Emacs 19.31 + (filladapt-funcall 'fill-region-as-paragraph beg end + justify nosqueeze squeeze-after) + (wrong-number-of-arguments + (condition-case nil + ;; four args for Emacs 19.29 + (filladapt-funcall 'fill-region-as-paragraph beg end + justify nosqueeze) + ;; three args for the rest of the world. + (wrong-number-of-arguments + (filladapt-funcall 'fill-region-as-paragraph beg end justify))))))) + +(defun fill-region (beg end &optional justify nosqueeze to-eop) + "Fill each of the paragraphs in the region. + +(This function has been overloaded with the `filladapt' version.) + +Prefix arg (non-nil third arg, if called from program) means justify as well. + +Noninteractively, fourth arg NOSQUEEZE non-nil means to leave +whitespace other than line breaks untouched, and fifth arg TO-EOP +non-nil means to keep filling to the end of the paragraph (or next +hard newline, if `use-hard-newlines' is on). + +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there." + (interactive "*r\nP") + (if (and filladapt-mode (not filladapt-inside-filladapt)) + (save-restriction + (narrow-to-region beg end) + (let ((filladapt-inside-filladapt t) + start) + (goto-char beg) + (while (not (eobp)) + (setq start (point)) + (while (and (not (eobp)) (not (filladapt-parse-prefixes))) + (forward-line 1)) + (if (not (equal start (point))) + (progn + (save-restriction + (narrow-to-region start (point)) + (fill-region start (point) justify nosqueeze to-eop) + (goto-char (point-max))) + (if (and (not (bolp)) (not (eobp))) + (forward-line 1)))) + (if (filladapt-parse-prefixes) + (progn + (save-restriction + ;; for the clipping region + (filladapt-adapt t t) + (fill-paragraph justify) + (goto-char (point-max))) + (if (and (not (bolp)) (not (eobp))) + (forward-line 1))))))) + (condition-case nil + (filladapt-funcall 'fill-region beg end justify nosqueeze to-eop) + (wrong-number-of-arguments + (condition-case nil + (filladapt-funcall 'fill-region beg end justify nosqueeze) + (wrong-number-of-arguments + (filladapt-funcall 'fill-region beg end justify))))))) + +(defvar zmacs-region-stays) ; for XEmacs + +(defun filladapt-mode (&optional arg) + "Toggle Filladapt minor mode. +With arg, turn Filladapt mode on iff arg is positive. When +Filladapt mode is enabled, auto-fill-mode and the fill-paragraph +command are both smarter about guessing a proper fill-prefix and +finding paragraph boundaries when bulleted and indented lines and +paragraphs are used." + (interactive "P") + ;; don't deactivate the region. + (setq zmacs-region-stays t) + (setq filladapt-mode (or (and arg (> (prefix-numeric-value arg) 0)) + (and (null arg) (null filladapt-mode)))) + (if (fboundp 'force-mode-line-update) + (force-mode-line-update) + (set-buffer-modified-p (buffer-modified-p)))) + +(defun turn-on-filladapt-mode () + "Unconditionally turn on Filladapt mode in the current buffer." + (filladapt-mode 1)) + +(defun turn-off-filladapt-mode () + "Unconditionally turn off Filladapt mode in the current buffer." + (filladapt-mode -1)) + +(defun filladapt-funcall (function &rest args) + "Call the old definition of a function that filladapt has usurped." + (apply (cdr (assoc function filladapt-function-table)) args)) + +(defun filladapt-paragraph-start (list) + "Returns non-nil if LIST contains a paragraph starting token. +LIST should be a token list as returned by filladapt-parse-prefixes." + (catch 'done + (while list + (if (memq (car (car list)) filladapt-token-paragraph-start-table) + (throw 'done t)) + (setq list (cdr list))))) + +(defun filladapt-parse-prefixes () + "Parse all the tokens after point and return a list of them. +The tokens regular expressions are specified in +filladapt-token-table. The list returned is of this form + + ((SYM COL STRING) ...) + +SYM is a token symbol as found in filladapt-token-table. +COL is the column at which the token ended. +STRING is the token's text." + (save-excursion + (let ((token-list nil) + (done nil) + (old-point (point)) + (case-fold-search nil) + token-table not-token-table moved) + (catch 'done + (while (not done) + (setq not-token-table filladapt-not-token-table) + (while not-token-table + (if (looking-at (car not-token-table)) + (throw 'done t)) + (setq not-token-table (cdr not-token-table))) + (setq token-table filladapt-token-table + done t) + (while token-table + (if (null (looking-at (car (car token-table)))) + (setq token-table (cdr token-table)) + (goto-char (match-end 0)) + (setq token-list (cons (list (nth 1 (car token-table)) + (current-column) + (buffer-substring + (match-beginning 0) + (match-end 0))) + token-list) + moved (not (eq (point) old-point)) + token-table (if moved nil (cdr token-table)) + done (not moved) + old-point (point)))))) + (nreverse token-list)))) + +(defun filladapt-tokens-match-p (list1 list2) + "Compare two token lists and return non-nil if they match, nil otherwise. +The lists are walked through in lockstep, comparing tokens. + +When two tokens A and B are compared, they are considered to +match if + + 1. A appears in B's list of matching tokens or + B appears in A's list of matching tokens +and + 2. A and B both end at the same column + or + A can match multiple tokens and ends at a column > than B + or + B can match multiple tokens and ends at a column > than A + +In the case where the end columns differ the list pointer for the +token with the greater end column is not moved forward, which +allows its current token to be matched against the next token in +the other list in the next iteration of the matching loop. + +All tokens must be matched in order for the lists to be considered +matching." + (let ((matched t) + (done nil)) + (while (and (not done) list1 list2) + (let* ((token1 (car (car list1))) + (token1-matches-many-p + (memq token1 filladapt-token-match-many-table)) + (token1-matches (cdr (assq token1 filladapt-token-match-table))) + (token1-endcol (nth 1 (car list1))) + (token2 (car (car list2))) + (token2-matches-many-p + (memq token2 filladapt-token-match-many-table)) + (token2-matches (cdr (assq token2 filladapt-token-match-table))) + (token2-endcol (nth 1 (car list2))) + (tokens-match (or (memq token1 token2-matches) + (memq token2 token1-matches)))) + (cond ((not tokens-match) + (setq matched nil + done t)) + ((and token1-matches-many-p token2-matches-many-p) + (cond ((= token1-endcol token2-endcol) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< token1-endcol token2-endcol) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (token1-matches-many-p + (cond ((= token1-endcol token2-endcol) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< token1-endcol token2-endcol) + (setq matched nil + done t)) + (t + (setq list2 (cdr list2))))) + (token2-matches-many-p + (cond ((= token1-endcol token2-endcol) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< token2-endcol token1-endcol) + (setq matched nil + done t)) + (t + (setq list1 (cdr list1))))) + ((= token1-endcol token2-endcol) + (setq list1 (cdr list1) + list2 (cdr list2))) + (t + (setq matched nil + done t))))) + (and matched (null list1) (null list2)) )) + +(defun filladapt-make-fill-prefix (list) + "Build a fill-prefix for a token LIST. +filladapt-token-conversion-table specifies how this is done." + (let ((prefix-list nil) + (conversion-spec nil)) + (while list + (setq conversion-spec (cdr (assq (car (car list)) + filladapt-token-conversion-table))) + (cond ((eq conversion-spec 'spaces) + (setq prefix-list + (cons + (filladapt-convert-to-spaces (nth 2 (car list))) + prefix-list))) + ((eq conversion-spec 'exact) + (setq prefix-list + (cons + (nth 2 (car list)) + prefix-list)))) + (setq list (cdr list))) + (apply (function concat) (nreverse prefix-list)) )) + +(defun filladapt-paragraph-within-fill-tolerance () + (catch 'done + (save-excursion + (let ((low (- fill-column filladapt-fill-column-tolerance)) + (shortline nil)) + (goto-char (point-min)) + (while (not (eobp)) + (if shortline + (throw 'done nil) + (end-of-line) + (setq shortline (< (current-column) low)) + (forward-line 1))) + t )))) + +(defun filladapt-convert-to-spaces (string) + "Return a copy of STRING, with all non-tabs and non-space changed to spaces." + (let ((i 0) + (space-list '(?\ ?\t)) + (space ?\ ) + (lim (length string))) + (setq string (copy-sequence string)) + (while (< i lim) + (if (not (memq (aref string i) space-list)) + (aset string i space)) + (setq i (1+ i))) + string )) + +(defun filladapt-adapt (paragraph debugging) + "Set fill-prefix based on the contents of the current line. + +If the first arg PARAGRAPH is non-nil, also set a clipping region +around the current paragraph. + +If the second arg DEBUGGING is non-nil, don't do the kludge that's +necessary to make certain paragraph fills work properly." + (save-excursion + (beginning-of-line) + (let ((token-list (filladapt-parse-prefixes)) + curr-list done) + (if (null token-list) + nil + (setq fill-prefix (filladapt-make-fill-prefix token-list)) + (if paragraph + (let (beg end) + (if (filladapt-paragraph-start token-list) + (setq beg (point)) + (save-excursion + (setq done nil) + (while (not done) + (cond ((not (= 0 (forward-line -1))) + (setq done t + beg (point))) + ((not (filladapt-tokens-match-p + token-list + (setq curr-list (filladapt-parse-prefixes)))) + (forward-line 1) + (setq done t + beg (point))) + ((filladapt-paragraph-start curr-list) + (setq done t + beg (point))))))) + (save-excursion + (setq done nil) + (while (not done) + (cond ((not (= 0 (progn (end-of-line) (forward-line 1)))) + (setq done t + end (point))) + ((not (filladapt-tokens-match-p + token-list + (setq curr-list (filladapt-parse-prefixes)))) + (setq done t + end (point))) + ((filladapt-paragraph-start curr-list) + (setq done t + end (point)))))) + (narrow-to-region beg end) + ;; Multiple spaces after the bullet at the start of + ;; a hanging list paragraph get squashed by + ;; fill-paragraph. We kludge around this by + ;; replacing the line prefix with the fill-prefix + ;; used by the rest of the lines in the paragraph. + ;; fill-paragraph will not alter the fill prefix so + ;; we win. The post hook restores the old line prefix + ;; after fill-paragraph has been called. + (if (and paragraph (not debugging)) + (let (col) + (setq col (nth 1 (car (filladapt-tail token-list)))) + (goto-char (point-min)) + (move-to-column col) + (setq filladapt-old-line-prefix + (buffer-substring (point-min) (point))) + (delete-region (point-min) (point)) + (insert fill-prefix) + (add-hook 'filladapt-fill-paragraph-post-hook + 'filladapt-cleanup-kludge-at-point-min))))) + t )))) + +(defun filladapt-cleanup-kludge-at-point-min () + "Cleanup the paragraph fill kludge. +See filladapt-adapt." + (save-excursion + (goto-char (point-min)) + (insert filladapt-old-line-prefix) + (delete-char (length fill-prefix)) + (remove-hook 'filladapt-fill-paragraph-post-hook + 'filladapt-cleanup-kludge-at-point-min))) + +(defun filladapt-tail (list) + "Returns the last cons in LIST." + (if (null list) + nil + (while (consp (cdr list)) + (setq list (cdr list))) + list )) + +(defun filladapt-delete-extent (e) + (if (fboundp 'delete-extent) + (delete-extent e) + (delete-overlay e))) + +(defun filladapt-make-extent (beg end) + (if (fboundp 'make-extent) + (make-extent beg end) + (make-overlay beg end))) + +(defun filladapt-set-extent-endpoints (e beg end) + (if (fboundp 'set-extent-endpoints) + (set-extent-endpoints e beg end) + (move-overlay e beg end))) + +(defun filladapt-set-extent-property (e prop val) + (if (fboundp 'set-extent-property) + (set-extent-property e prop val) + (overlay-put e prop val))) + +(defun filladapt-debug () + "Toggle filladapt debugging on/off in the current buffer." +;; (interactive) + (make-local-variable 'filladapt-debug) + (setq filladapt-debug (not filladapt-debug)) + (if (null filladapt-debug) + (progn + (mapcar (function (lambda (e) (filladapt-set-extent-endpoints e 1 1))) + filladapt-debug-indentation-extents) + (if filladapt-debug-paragraph-extent + (progn + (filladapt-delete-extent filladapt-debug-paragraph-extent) + (setq filladapt-debug-paragraph-extent nil))))) + (add-hook 'post-command-hook 'filladapt-display-debug-info-maybe)) + +(defun filladapt-display-debug-info-maybe () + (cond ((null filladapt-debug) nil) + (fill-prefix nil) + (t + (if (null filladapt-debug-paragraph-extent) + (let ((e (filladapt-make-extent 1 1))) + (filladapt-set-extent-property e 'detachable nil) + (filladapt-set-extent-property e 'evaporate nil) + (filladapt-set-extent-property e 'face + filladapt-debug-paragraph-face) + (setq filladapt-debug-paragraph-extent e))) + (save-excursion + (save-restriction + (let ((ei-list filladapt-debug-indentation-extents) + (ep filladapt-debug-paragraph-extent) + (face filladapt-debug-indentation-face-1) + fill-prefix token-list) + (if (null (filladapt-adapt t t)) + (progn + (filladapt-set-extent-endpoints ep 1 1) + (while ei-list + (filladapt-set-extent-endpoints (car ei-list) 1 1) + (setq ei-list (cdr ei-list)))) + (filladapt-set-extent-endpoints ep (point-min) (point-max)) + (beginning-of-line) + (setq token-list (filladapt-parse-prefixes)) + (message "(%s)" (mapconcat (function + (lambda (q) (symbol-name (car q)))) + token-list + " ")) + (while token-list + (if ei-list + (setq e (car ei-list) + ei-list (cdr ei-list)) + (setq e (filladapt-make-extent 1 1)) + (filladapt-set-extent-property e 'detachable nil) + (filladapt-set-extent-property e 'evaporate nil) + (setq filladapt-debug-indentation-extents + (cons e filladapt-debug-indentation-extents))) + (filladapt-set-extent-property e 'face face) + (filladapt-set-extent-endpoints e (point) + (progn + (move-to-column + (nth 1 + (car token-list))) + (point))) + (if (eq face filladapt-debug-indentation-face-1) + (setq face filladapt-debug-indentation-face-2) + (setq face filladapt-debug-indentation-face-1)) + (setq token-list (cdr token-list))) + (while ei-list + (filladapt-set-extent-endpoints (car ei-list) 1 1) + (setq ei-list (cdr ei-list)))))))))) diff --git a/lisp/promela-mode.el b/lisp/promela-mode.el new file mode 100644 index 0000000..3ab4da7 --- /dev/null +++ b/lisp/promela-mode.el @@ -0,0 +1,985 @@ +;; promela-mode.el --- major mode for editing PROMELA program files +;; $Revision: 1.11 $ $Date: 2001/07/09 18:36:45 $ $Author: engstrom $ + +;; Author: Eric Engstrom <eric.engstrom@honeywell.com> +;; Maintainer: Eric Engstrom +;; Keywords: spin, promela, tools + +;; Copyright (C) 1998-2003 Eric Engstrom / Honeywell Laboratories + +;; ... Possibly insert GPL here someday ... + +;;; Commentary: + +;; This file contains code for a GNU Emacs major mode for editing +;; PROMELA (SPIN) program files. + +;; Type "C-h m" in Emacs (while in a buffer in promela-mode) for +;; information on how to configure indentation and fontification, +;; or look at the configuration variables below. + +;; To use, place promela-mode.el in a directory in your load-path. +;; Then, put the following lines into your .emacs and promela-mode +;; will be automatically loaded when editing a PROMELA program. + +;; (autoload 'promela-mode "promela-mode" "PROMELA mode" nil t) +;; (setq auto-mode-alist +;; (append +;; (list (cons "\\.promela$" 'promela-mode) +;; (cons "\\.spin$" 'promela-mode) +;; (cons "\\.pml$" 'promela-mode) +;; ;; (cons "\\.other-extensions$" 'promela-mode) +;; ) +;; auto-mode-alist)) + +;; If you wish for promela-mode to be used for files with other +;; extensions you add your own patterned after the code above. + +;; Note that promela-mode adhears to the font-lock "standards" and +;; defines several "levels" of fontification or colorization. The +;; default is fairly gaudy, so I can imagine that some folks would +;; like a bit less. FMI: see `font-lock-maximum-decoration' + +;; This mode is known to work under the following versions of emacs: +;; - XEmacs: 19.16, 20.x, 21.x +;; - FSF/GNU Emacs: 19.34 +;; - NTEmacs (FSF): 20.[67] +;; That is not to say there are no bugs specific to one of those versions :-) + +;; Please send any comments, bugs, patches or other requests to +;; Eric Engstrom at engstrom@htc.honeywell.com + +;; To-Do: +;; - compile/syntax-check/verify? (suggested by R.Goldman) +;; - indentation - splitting lines at logical operators (M. Rangarajan) +;; [ This might "devolve" to indentation after "->" or ";" +;; being as is, but anything else indent even more? ] +;; :: SomeReallyLongArrayRef[this].typedefField != SomeReallyLongConstant -> /* some-comment */ +;; [ Suggestion would be to break the first line after the !=, therefore: ] +;; :: SomeReallyLongArrayRef[this].typedefField +;; != SomeReallyLongConstant -> /* some-comment */ +;; [ at this point I'm not so sure about this change... EE: 2001/05/19 ] + +;;; ------------------------------------------------------------------------- +;;; Code: + +;; NOTE: same as CVS revision: +(defconst promela-mode-version "$Revision: 1.11 $" + "Promela-mode version number.") + +;; ------------------------------------------------------------------------- +;; The following constant values can be modified by the user in a .emacs file + +(defconst promela-block-indent 2 + "*Controls indentation of lines within a block (`{') construct") + +(defconst promela-selection-indent 2 + "*Controls indentation of options within a selection (`if') +or iteration (`do') construct") + +(defconst promela-selection-option-indent 3 + "*Controls indentation of lines after options within selection or +iteration construct (`::')") + +(defconst promela-comment-col 32 + "*Defines the desired comment column for comments to the right of text.") + +(defconst promela-tab-always-indent t + "*Non-nil means TAB in Promela mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defconst promela-auto-match-delimiter t + "*Non-nil means typing an open-delimiter (i.e. parentheses, brace, quote, etc) +should also insert the matching closing delmiter character.") + +;; That should be about it for most users... +;; unless you wanna hack elisp, the rest of this is probably uninteresting + + +;; ------------------------------------------------------------------------- +;; help determine what emacs we have here... + +(defconst promela-xemacsp (string-match "XEmacs" (emacs-version)) + "Non-nil if we are running in the XEmacs environment.") + +;;;(defconst promela-xemacs20p (and promela-xemacsp (>= emacs-major-version 20)) +;; "Non-nil if we are running in an XEmacs environment version 20 or greater.") + +;; ------------------------------------------------------------------------- +;; promela-mode font faces/definitions + +;; make use of font-lock stuff, so say that explicitly +(require 'font-lock) + +;; BLECH! YUCK! I just wish these guys could agree to something.... +;; Faces available in: ntemacs emacs xemacs xemacs xemacs +;; font-lock- xxx -face 20.6 19.34 19.16 20.x 21.x +;; -builtin- X +;; -constant- X +;; -comment- X X X X X +;; -doc-string- X X X +;; -function-name- X X X X X +;; -keyword- X X X X X +;; -preprocessor- X X X +;; -reference- X X X X +;; -signal-name- X X!20.0 +;; -string- X X X X X +;; -type- X X X X X +;; -variable-name- X X X X X +;; -warning- X X + +;;; Compatibility on faces between versions of emacs-en +(unless promela-xemacsp + + (defvar font-lock-preprocessor-face 'font-lock-preprocessor-face + "Face name to use for preprocessor statements.") + ;; For consistency try to define the preprocessor face == builtin face + (condition-case nil + (copy-face 'font-lock-builtin-face 'font-lock-preprocessor-face) + (error + (defface font-lock-preprocessor-face + '((t (:foreground "blue" :italic nil :underline t))) + "Face Lock mode face used to highlight preprocessor statements." + :group 'font-lock-highlighting-faces))) + + (defvar font-lock-reference-face 'font-lock-reference-face + "Face name to use for constants and reference and label names.") + ;; For consistency try to define the reference face == constant face + (condition-case nil + (copy-face 'font-lock-constant-face 'font-lock-reference-face) + (error + (defface font-lock-reference-face + '((((class grayscale) (background light)) + (:foreground "LightGray" :bold t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray50" :bold t :underline t)) + (((class color) (background light)) (:foreground "CadetBlue")) + (((class color) (background dark)) (:foreground "Aquamarine")) + (t (:bold t :underline t))) + "Font Lock mode face used to highlight constancs, references and labels." + :group 'font-lock-highlighting-faces))) + + ) + +;; send-poll "symbol" face is custom to promela-mode +;; but check for existence to allow someone to override it +(defvar promela-fl-send-poll-face 'promela-fl-send-poll-face + "Face name to use for Promela Send or Poll symbols: `!' or `?'") +(copy-face (if promela-xemacsp 'modeline 'region) + 'promela-fl-send-poll-face) + +;; some emacs-en don't define or have regexp-opt available. +(unless (functionp 'regexp-opt) + (defmacro regexp-opt (strings) + "Cheap imitation of `regexp-opt' since it's not availble in this emacs" + `(mapconcat 'identity ,strings "\\|"))) + + +;; ------------------------------------------------------------------------- +;; promela-mode font lock specifications/regular-expressions +;; - for help, look at definition of variable 'font-lock-keywords +;; - some fontification ideas from -- [engstrom:20010309.1435CST] +;; Pat Tullman (tullmann@cs.utah.edu) and +;; Ny Aina Razermera Mamy (ainarazr@cs.uoregon.edu) +;; both had promela-mode's that I discovered after starting this one... +;; (but neither did any sort of indentation ;-) + +(defconst promela-font-lock-keywords-1 nil + "Subdued level highlighting for Promela mode.") + +(defconst promela-font-lock-keywords-2 nil + "Medium level highlighting for Promela mode.") + +(defconst promela-font-lock-keywords-3 nil + "Gaudy level highlighting for Promela mode.") + +;; set each of those three variables now.. +(let ((promela-keywords + (eval-when-compile + (regexp-opt + '("active" "assert" "atomic" "break" "d_step" + "do" "dproctype" "else" "empty" "enabled" + "eval" "fi" "full" "goto" "hidden" "if" "init" + "inline" "len" "local" "mtype" "nempty" "never" + "nfull" "od" "of" "pcvalue" "printf" "priority" + "proctype" "provided" "run" "show" "skip" + "timeout" "trace" "typedef" "unless" "xr" "xs")))) + (promela-types + (eval-when-compile + (regexp-opt '("bit" "bool" "byte" "short" + "int" "unsigned" "chan"))))) + + ;; really simple fontification (strings and comments come for "free") + (setq promela-font-lock-keywords-1 + (list + ;; Keywords: + (cons (concat "\\<\\(" promela-keywords "\\)\\>") + 'font-lock-keyword-face) + ;; Types: + (cons (concat "\\<\\(" promela-types "\\)\\>") + 'font-lock-type-face) + ;; Special constants: + '("\\<_\\(np\\|pid\\|last\\)\\>" . font-lock-reference-face))) + + ;; more complex fontification + ;; add function (proctype) names, lables and goto statements + ;; also add send/receive/poll fontification + (setq promela-font-lock-keywords-2 + (append promela-font-lock-keywords-1 + (list + ;; ANY Pre-Processor directive (lazy method: any line beginning with "#[a-z]+") + '("^\\(#[ \t]*[a-z]+\\)" 1 'font-lock-preprocessor-face t) + + ;; "Functions" (proctype-s and inline-s) + (list (concat "\\<\\(" + (eval-when-compile + (regexp-opt '("run" "dproctype" "proctype" "inline"))) + "\\)\\>[ \t]*\\(\\sw+\\)?") + ;;'(1 'font-lock-keyword-face nil) + '(2 'font-lock-function-name-face nil t)) + + ;; Labels and GOTO labels + '("^\\(\\sw+\\):" 1 'font-lock-reference-face) + '("\\<\\(goto\\)\\>[ \t]+\\(\\sw+\\)" + ;;(1 'font-lock-keyword-face nil) + (2 'font-lock-reference-face nil t)) + + ;; Send, Receive and Poll + '("\\(\\sw+\\)\\(\\[[^\\?!]+\\]\\)?\\(\\??\\?\\|!?!\\)\\(\\sw+\\)" + (1 'font-lock-variable-name-face nil t) + (3 'promela-fl-send-poll-face nil t) + (4 'font-lock-reference-face nil t) + ) + ))) + + ;; most complex fontification + ;; add pre-processor directives, typed variables and hidden/typedef decls. + (setq promela-font-lock-keywords-3 + (append promela-font-lock-keywords-2 + (list + ;; ANY Pre-Processor directive (lazy method: any line beginning with "#[a-z]+") + ;;'("^\\(#[ \t]*[a-z]+\\)" 1 'font-lock-preprocessor-face t) + ;; "defined" in an #if or #elif and associated macro names + '("^#[ \t]*\\(el\\)?if\\>" + ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)" nil nil + (1 'font-lock-preprocessor-face nil t) + (2 'font-lock-reference-face nil t))) + '("^#[ \t]*ifn?def\\>" + ("[ \t]*\\(\\sw+\\)" nil nil + (1 'font-lock-reference-face nil t))) + ;; Filenames in #include <...> directives + '("^#[ \t]*include[ \t]+<\\([^>\"\n]+\\)>" 1 'font-lock-string-face nil t) + ;; Defined functions and constants/types (non-functions) + '("^#[ \t]*define[ \t]+" + ("\\(\\sw+\\)(" nil nil (1 'font-lock-function-name-face nil t)) + ("\\(\\sw+\\)[ \t]+\\(\\sw+\\)" nil nil (1 'font-lock-variable-name-face) + (2 'font-lock-reference-face nil t)) + ("\\(\\sw+\\)[^(]?" nil nil (1 'font-lock-reference-face nil t))) + + ;; Types AND variables + ;; - room for improvement: (i.e. don't currently): + ;; highlight user-defined types and asociated variable declarations + (list (concat "\\<\\(" promela-types "\\)\\>") + ;;'(1 'font-lock-type-face) + ;; now match the variables after the type definition, if any + '(promela-match-variable-or-declaration + nil nil + (1 'font-lock-variable-name-face) ;; nil t) + (2 font-lock-reference-face nil t))) + + ;; Typedef/hidden types and declarations + '("\\<\\(typedef\\|hidden\\)\\>[ \t]*\\(\\sw+\\)?" + ;;(1 'font-lock-keyword-face nil) + (2 'font-lock-type-face nil t) + ;; now match the variables after the type definition, if any + (promela-match-variable-or-declaration + nil nil + (1 'font-lock-variable-name-face nil t) + (2 'font-lock-reference-face nil t))) + ))) + ) + +(defvar promela-font-lock-keywords promela-font-lock-keywords-1 + "Default expressions to highlight in Promela mode.") + +;; Font-lock matcher functions: +(defun promela-match-variable-or-declaration (limit) + "Match, and move over, any declaration/definition item after point. +Matches after point, but ignores leading whitespace characters. +Does not move further than LIMIT. + +The expected syntax of a declaration/definition item is `word' (preceded +by optional whitespace) optionally followed by a `= value' (preceded and +followed by more optional whitespace) + +Thus the regexp matches after point: word [ = value ] + ^^^^ ^^^^^ +Where the match subexpressions are: 1 2 + +The item is delimited by (match-beginning 1) and (match-end 1). +If (match-beginning 2) is non-nil, the item is followed by a `value'." + (when (looking-at "[ \t]*\\(\\sw+\\)[ \t]*=?[ \t]*\\(\\sw+\\)?[ \t]*,?") + (goto-char (min limit (match-end 0))))) + + +;; ------------------------------------------------------------------------- +;; "install" promela-mode font lock specifications + +;; FMI: look up 'font-lock-defaults +(defconst promela-font-lock-defaults + '( + (promela-font-lock-keywords + promela-font-lock-keywords-1 + promela-font-lock-keywords-2 + promela-font-lock-keywords-3) ;; font-lock stuff (keywords) + nil ;; keywords-only flag + nil ;; case-fold keyword searching + ;;((?_ . "w") (?$ . ".")) ;; mods to syntax table + nil ;; mods to syntax table (see below) + nil ;; syntax-begin + (font-lock-mark-block-function . mark-defun)) +) + +;; "install" the font-lock-defaults based upon version of emacs we have +(cond (promela-xemacsp + (put 'promela-mode 'font-lock-defaults promela-font-lock-defaults)) + ((not (assq 'promela-mode font-lock-defaults-alist)) + (setq font-lock-defaults-alist + (cons + (cons 'promela-mode promela-font-lock-defaults) + font-lock-defaults-alist)))) + + +;; ------------------------------------------------------------------------- +;; other promela-mode specific definitions + +(defconst promela-defun-prompt-regexp + "^[ \t]*\\(\\(active \\)?d?proctype\\|init\\|inline\\|never\\|trace\\|typedef\\|mtype\\s-+=\\)[ \t][^{]*" + "Regexp describing the beginning of a Promela top-level definition.") + +(defvar promela-mode-syntax-table nil + "Syntax table in use in PROMELA-mode buffers.") +(if promela-mode-syntax-table + () + (setq promela-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\\ "\\" promela-mode-syntax-table) + (modify-syntax-entry ?/ ". 14" promela-mode-syntax-table) + (modify-syntax-entry ?* ". 23" promela-mode-syntax-table) + (modify-syntax-entry ?+ "." promela-mode-syntax-table) + (modify-syntax-entry ?- "." promela-mode-syntax-table) + (modify-syntax-entry ?= "." promela-mode-syntax-table) + (modify-syntax-entry ?% "." promela-mode-syntax-table) + (modify-syntax-entry ?< "." promela-mode-syntax-table) + (modify-syntax-entry ?> "." promela-mode-syntax-table) + (modify-syntax-entry ?& "." promela-mode-syntax-table) + (modify-syntax-entry ?| "." promela-mode-syntax-table) + (modify-syntax-entry ?. "_" promela-mode-syntax-table) + (modify-syntax-entry ?_ "w" promela-mode-syntax-table) + (modify-syntax-entry ?\' "\"" promela-mode-syntax-table) + ) + +(defvar promela-mode-abbrev-table nil + "*Abbrev table in use in promela-mode buffers.") +(if promela-mode-abbrev-table + nil + (define-abbrev-table 'promela-mode-abbrev-table + '( +;; Commented out for now - need to think about what abbrevs make sense +;; ("assert" "ASSERT" promela-check-expansion 0) +;; ("d_step" "D_STEP" promela-check-expansion 0) +;; ("break" "BREAK" promela-check-expansion 0) +;; ("do" "DO" promela-check-expansion 0) +;; ("proctype" "PROCTYPE" promela-check-expansion 0) + ))) + +(defvar promela-mode-map nil + "Keymap for promela-mode.") +(if promela-mode-map + nil + (setq promela-mode-map (make-sparse-keymap)) + (define-key promela-mode-map "\t" 'promela-indent-command) + (define-key promela-mode-map "\C-m" 'promela-newline-and-indent) + ;(define-key promela-mode-map 'backspace 'backward-delete-char-untabify) + (define-key promela-mode-map "\C-c\C-p" 'promela-beginning-of-block) + ;(define-key promela-mode-map "\C-c\C-n" 'promela-end-of-block) + (define-key promela-mode-map "\M-\C-a" 'promela-beginning-of-defun) + ;(define-key promela-mode-map "\M-\C-e" 'promela-end-of-defun) + (define-key promela-mode-map "\C-c(" 'promela-toggle-auto-match-delimiter) + (define-key promela-mode-map "{" 'promela-open-delimiter) + (define-key promela-mode-map "}" 'promela-close-delimiter) + (define-key promela-mode-map "(" 'promela-open-delimiter) + (define-key promela-mode-map ")" 'promela-close-delimiter) + (define-key promela-mode-map "[" 'promela-open-delimiter) + (define-key promela-mode-map "]" 'promela-close-delimiter) + (define-key promela-mode-map ";" 'promela-insert-and-indent) + (define-key promela-mode-map ":" 'promela-insert-and-indent) + ;; + ;; this is preliminary at best - use at your own risk: + (define-key promela-mode-map "\C-c\C-s" 'promela-syntax-check) + ;; + ;;(define-key promela-mode-map "\C-c\C-d" 'promela-mode-toggle-debug) + ;;(define-key promela-mode-map "\C-c\C-r" 'promela-mode-revert-buffer) + ) + +(defvar promela-matching-delimiter-alist + '( (?( . ?)) + (?[ . ?]) + (?{ . "\n}") + ;(?< . ?>) + (?\' . ?\') + (?\` . ?\`) + (?\" . ?\") ) + "List of pairs of matching open/close delimiters - for auto-insert") + + +;; ------------------------------------------------------------------------- +;; Promela-mode itself + +(defun promela-mode () + "Major mode for editing PROMELA code. +\\{promela-mode-map} + +Variables controlling indentation style: + promela-block-indent + Relative offset of lines within a block (`{') construct. + + promela-selection-indent + Relative offset of option lines within a selection (`if') + or iteration (`do') construct. + + promela-selection-option-indent + Relative offset of lines after/within options (`::') within + selection or iteration constructs. + + promela-comment-col + Defines the desired comment column for comments to the right of text. + + promela-tab-always-indent + Non-nil means TAB in PROMELA mode should always reindent the current + line, regardless of where in the line the point is when the TAB + command is used. + + promela-auto-match-delimiter + Non-nil means typing an open-delimiter (i.e. parentheses, brace, + quote, etc) should also insert the matching closing delmiter + character. + +Turning on PROMELA mode calls the value of the variable promela-mode-hook with +no args, if that value is non-nil. + +For example: ' + (setq promela-mode-hook '(lambda () + (setq promela-block-indent 2) + (setq promela-selection-indent 0) + (setq promela-selection-option-indent 2) + (local-set-key \"\\C-m\" 'promela-indent-newline-indent) + ))' + +will indent block two steps, will make selection options aligned with DO/IF +and sub-option lines indent to a column after the `::'. Also, lines will +be reindented when you hit RETURN. + +Note that promela-mode adhears to the font-lock \"standards\" and +defines several \"levels\" of fontification or colorization. The +default is fairly gaudy, so if you would prefer a bit less, please see +the documentation for the variable: `font-lock-maximum-decoration'. +" + (interactive) + (kill-all-local-variables) + (setq mode-name "Promela") + (setq major-mode 'promela-mode) + (use-local-map promela-mode-map) + (set-syntax-table promela-mode-syntax-table) + (setq local-abbrev-table promela-mode-abbrev-table) + + ;; Make local variables + (make-local-variable 'case-fold-search) + (make-local-variable 'paragraph-start) + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-ignore-fill-prefix) + (make-local-variable 'indent-line-function) + (make-local-variable 'indent-region-function) + (make-local-variable 'parse-sexp-ignore-comments) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (make-local-variable 'comment-column) + (make-local-variable 'comment-start-skip) + (make-local-variable 'comment-indent-hook) + (make-local-variable 'defun-prompt-regexp) + (make-local-variable 'compile-command) + ;; Now set their values + (setq case-fold-search t + paragraph-start (concat "^$\\|" page-delimiter) + paragraph-separate paragraph-start + paragraph-ignore-fill-prefix t + indent-line-function 'promela-indent-command + ;;indent-region-function 'promela-indent-region + parse-sexp-ignore-comments t + comment-start "/* " + comment-end " */" + comment-column 32 + comment-start-skip "/\\*+ *" + ;;comment-start-skip "/\\*+ *\\|// *" + ;;comment-indent-hook 'promela-comment-indent + defun-prompt-regexp promela-defun-prompt-regexp + ) + + ;; Turn on font-lock mode + ;; (and promela-font-lock-mode (font-lock-mode)) + (font-lock-mode) + + ;; Finally, run the hooks and be done. + (run-hooks 'promela-mode-hook)) + + +;; ------------------------------------------------------------------------- +;; Interactive functions +;; + +(defun promela-mode-version () + "Print the current version of promela-mode in the minibuffer" + (interactive) + (message (concat "Promela-Mode: " promela-mode-version))) + +(defun promela-beginning-of-block () + "Move backward to start of containing block. +Containing block may be `{', `do' or `if' construct, or comment." + (interactive) + (goto-char (promela-find-start-of-containing-block-or-comment))) + +(defun promela-beginning-of-defun (&optional arg) + "Move backward to the beginning of a defun. +With argument, do it that many times. +Negative arg -N means move forward to Nth following beginning of defun. +Returns t unless search stops due to beginning or end of buffer. + +See also 'beginning-of-defun. + +This is a Promela-mode specific version since default (in xemacs 19.16 and +NT-Emacs 20) don't seem to skip comments - they will stop inside them. + +Also, this makes sure that the beginning of the defun is actually the +line which starts the proctype/init/etc., not just the open-brace." + (interactive "p") + (beginning-of-defun arg) + (if (not (looking-at promela-defun-prompt-regexp)) + (re-search-backward promela-defun-prompt-regexp nil t)) + (if (promela-inside-comment-p) + (goto-char (promela-find-start-of-containing-comment)))) + +(defun promela-indent-command () + "Indent the current line as PROMELA code." + (interactive) + (if (and (not promela-tab-always-indent) + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (tab-to-tab-stop) + (promela-indent-line))) + +(defun promela-newline-and-indent () + "Promela-mode specific newline-and-indent which expands abbrevs before +running a regular newline-and-indent." + (interactive) + (if abbrev-mode + (expand-abbrev)) + (newline-and-indent)) + +(defun promela-indent-newline-indent () + "Promela-mode specific newline-and-indent which expands abbrevs and +indents the current line before running a regular newline-and-indent." + (interactive) + (save-excursion (promela-indent-command)) + (if abbrev-mode + (expand-abbrev)) + (newline-and-indent)) + +(defun promela-insert-and-indent () + "Insert the last character typed and re-indent the current line" + (interactive) + (insert last-command-char) + (save-excursion (promela-indent-command))) + +(defun promela-open-delimiter () + "Inserts the open and matching close delimiters, indenting as appropriate." + (interactive) + (insert last-command-char) + (if (and promela-auto-match-delimiter (not (promela-inside-comment-p))) + (save-excursion + (insert (cdr (assq last-command-char promela-matching-delimiter-alist))) + (promela-indent-command)))) + +(defun promela-close-delimiter () + "Inserts and indents a close delimiter." + (interactive) + (insert last-command-char) + (if (not (promela-inside-comment-p)) + (save-excursion (promela-indent-command)))) + +(defun promela-toggle-auto-match-delimiter () + "Toggle auto-insertion of parens and other delimiters. +See variable `promela-auto-insert-matching-delimiter'" + (interactive) + (setq promela-auto-match-delimiter + (not promela-auto-match-delimiter)) + (message (concat "Promela auto-insert matching delimiters " + (if promela-auto-match-delimiter + "enabled" "disabled")))) + + +;; ------------------------------------------------------------------------- +;; Compilation/Verification functions + +;; all of this is in serious "beta" mode - don't trust it ;-) +(setq + promela-compile-command "spin " + promela-syntax-check-args "-a -v " +) + +;;(setq compilation-error-regexp-alist +;; (append compilation-error-regexp-alist +;; '(("spin: +line +\\([0-9]+\\) +\"\\([^\"]+\\)\"" 2 1)))) + +(defun promela-syntax-check () + (interactive) + (compile (concat promela-compile-command + promela-syntax-check-args + (buffer-name)))) + + +;; ------------------------------------------------------------------------- +;; Indentation support functions + +(defun promela-indent-around-label () + "Indent the current line as PROMELA code, +but make sure to consider the label at the beginning of the line." + (beginning-of-line) + (delete-horizontal-space) ; delete any leading whitespace + (if (not (looking-at "\\sw+:\\([ \t]*\\)")) + (error "promela-indent-around-label: no label on this line") + (goto-char (match-beginning 1)) + (let* ((space (length (match-string 1))) + (indent (promela-calc-indent)) + (wanted (max 0 (- indent (current-column))))) + (if (>= space wanted) + (delete-region (point) (+ (point) (- space wanted))) + (goto-char (+ (point) space)) + (indent-to-column indent))))) + +;; Note that indentation is based ENTIRELY upon the indentation of the +;; previous line(s), esp. the previous non-blank line and the line +;; starting the current containgng block... +(defun promela-indent-line () + "Indent the current line as PROMELA code. +Return the amount the by which the indentation changed." + (beginning-of-line) + (if (looking-at "[ \t]*\\sw+:") + (promela-indent-around-label) + (let ((indent (promela-calc-indent)) + beg + shift-amt + (pos (- (point-max) (point)))) + (setq beg (point)) + (skip-chars-forward " \t") + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + (delete-region beg (point)) + (indent-to indent) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))) + shift-amt))) + +(defun promela-calc-indent () + "Return the appropriate indentation for this line as an int." + (save-excursion + (beginning-of-line) + (let* ((orig-point (point)) + (state (promela-parse-partial-sexp)) + (paren-depth (nth 0 state)) + (paren-point (or (nth 1 state) 1)) + (paren-char (char-after paren-point))) + ;;(what-cursor-position) + (cond + ;; Indent not-at-all - inside a string + ((nth 3 state) + (current-indentation)) + ;; Indent inside a comment + ((nth 4 state) + (promela-calc-indent-within-comment)) + ;; looking at a pre-processor directive - indent=0 + ((looking-at "[ \t]*#\\(define\\|if\\(n?def\\)?\\|else\\|endif\\)") + 0) + ;; If we're not inside a "true" block (i.e. "{}"), then indent=0 + ;; I think this is fair, since no (indentable) code in promela + ;; exists outside of a proctype or similar "{ .. }" structure. + ((zerop paren-depth) + 0) + ;; Indent relative to non curly-brace "paren" + ;; [ NOTE: I'm saving this, but don't use it any more. + ;; Now, we let parens be indented like curly braces + ;;((and (>= paren-depth 1) (not (char-equal ?\{ paren-char))) + ;; (goto-char paren-point) + ;; (1+ (current-column))) + ;; + ;; Last option: indent relative to contaning block(s) + (t + (goto-char orig-point) + (promela-calc-indent-within-block paren-point)))))) + +(defun promela-calc-indent-within-block (&optional limit) + "Return the appropriate indentation for this line, assume within block. +with optional arg, limit search back to `limit'" + (save-excursion + (let* ((stop (or limit 1)) + (block-point (promela-find-start-of-containing-block stop)) + (block-type (promela-block-type-after block-point)) + (indent-point (point)) + (indent-type (promela-block-type-after indent-point))) + (if (not block-type) 0 + ;;(message "paren: %d (%d); block: %s (%d); indent: %s (%d); stop: %d" + ;; paren-depth paren-point block-type block-point + ;; indent-type indent-point stop) + (goto-char block-point) + (cond + ;; Indent (options) inside "if" or "do" + ((memq block-type '(selection iteration)) + (if (re-search-forward "\\(do\\|if\\)[ \t]*::" indent-point t) + (- (current-column) 2) + (+ (current-column) promela-selection-indent))) + ;; indent (generic code) inside "::" option + ((eq 'option block-type) + (if (and (not indent-type) + (re-search-forward "::.*->[ \t]*\\sw" + (save-excursion (end-of-line) (point)) + t)) + (1- (current-column)) + (+ (current-column) promela-selection-option-indent)) + ) + ;; indent code inside "{" + ((eq 'block block-type) + (cond + ;; if we are indenting the end of a block, + ;; use indentation of start-of-block + ((equal 'block-end indent-type) + (current-indentation)) + ;; if the start of the code inside the block is not at eol + ;; then indent to the same column as the block start +some + ;; [ but ignore comments after "{" ] + ((and (not (promela-effective-eolp (1+ (point)))) + (not (looking-at "{[ \t]*/\\*"))) + (forward-char) ; skip block-start + (skip-chars-forward "{ \t") ; skip whitespace, if any + (current-column)) + ;; anything else we indent +promela-block-indent from + ;; the indentation of the start of block (where we are now) + (t + (+ (current-indentation) + promela-block-indent)))) + ;; dunno what kind of block this is - sound an error + (t + (error "promela-calc-indent-within-block: unknown block type: %s" block-type) + (current-indentation))))))) + +(defun promela-calc-indent-within-comment () + "Return the indentation amount for line, assuming that the +current line is to be regarded as part of a block comment." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (let ((indenting-end-of-comment (looking-at "\\*/")) + (indenting-blank-line (eolp))) + ;; if line is NOT blank and next char is NOT a "*' + (if (not (or indenting-blank-line (= (following-char) ?\*))) + ;; leave indent alone + (current-column) + ;; otherwise look back for _PREVIOUS_ possible nested comment start + (let ((comment-start (save-excursion + (re-search-backward comment-start-skip)))) + ;; and see if there is an appropriate middle-comment "*" + (if (re-search-backward "^[ \t]+\\*" comment-start t) + (current-indentation) + ;; guess not, so indent relative to comment start + (goto-char comment-start) + (if indenting-end-of-comment + (current-column) + (1+ (current-column))))))))) + + +;; ------------------------------------------------------------------------- +;; Misc other support functions + +(defun promela-parse-partial-sexp (&optional start limit) + "Return the partial parse state of current defun or from optional start +to end limit" + (save-excursion + (let ((end (or limit (point)))) + (if start + (goto-char start) + (promela-beginning-of-defun)) + (parse-partial-sexp (point) end)))) + +;;(defun promela-at-end-of-block-p () +;; "Return t if cursor is at the end of a promela block" +;; (save-excursion +;; (let ((eol (progn (end-of-line) (point)))) +;; (beginning-of-line) +;; (skip-chars-forward " \t") +;; ;;(re-search-forward "\\(}\\|\\b\\(od\\|fi\\)\\b\\)" eol t)))) +;; (looking-at "[ \t]*\\(od\\|fi\\)\\b")))) + +(defun promela-inside-comment-p () + "Check if the point is inside a comment block." + (save-excursion + (let ((origpoint (point)) + state) + (goto-char 1) + (while (> origpoint (point)) + (setq state (parse-partial-sexp (point) origpoint 0))) + (nth 4 state)))) + +(defun promela-inside-comment-or-string-p () + "Check if the point is inside a comment or a string." + (save-excursion + (let ((origpoint (point)) + state) + (goto-char 1) + (while (> origpoint (point)) + (setq state (parse-partial-sexp (point) origpoint 0))) + (or (nth 3 state) (nth 4 state))))) + + +(defun promela-effective-eolp (&optional point) + "Check if we are at the effective end-of-line, ignoring whitespace" + (save-excursion + (if point (goto-char point)) + (skip-chars-forward " \t") + (eolp))) + +(defun promela-check-expansion () + "If abbrev was made within a comment or a string, de-abbrev!" + (if promela-inside-comment-or-string-p + (unexpand-abbrev))) + +(defun promela-block-type-after (&optional point) + "Return the type of block after current point or parameter as a symbol. +Return one of 'iteration `do', 'selection `if', 'option `::', +'block `{' or `}' or nil if none of the above match." + (save-excursion + (goto-char (or point (point))) + (skip-chars-forward " \t") + (cond + ((looking-at "do\\b") 'iteration) + ;;((looking-at "od\\b") 'iteration-end) + ((looking-at "if\\b") 'selection) + ;;((looking-at "fi\\b") 'selection-end) + ((looking-at "::") 'option) + ((looking-at "[{(]") 'block) + ((looking-at "[})]") 'block-end) + (t nil)))) + +(defun promela-find-start-of-containing-comment (&optional limit) + "Return the start point of the containing comment block. +Stop at `limit' or beginning of buffer." + (let ((stop (or limit 1))) + (save-excursion + (while (and (>= (point) stop) + (nth 4 (promela-parse-partial-sexp))) + (re-search-backward comment-start-skip stop t)) + (point)))) + +(defun promela-find-start-of-containing-block (&optional limit) + "Return the start point of the containing `do', `if', `::' or +`{' block or containing comment. +Stop at `limit' or beginning of buffer." + (save-excursion + (skip-chars-forward " \t") + (let* ((type (promela-block-type-after)) + (stop (or limit + (save-excursion (promela-beginning-of-defun) (point)))) + (state (promela-parse-partial-sexp stop)) + (level (if (looking-at "\\(od\\|fi\\)\\b") + 2 + (if (zerop (nth 0 state)) 0 1)))) + ;;(message "find-start-of-containing-block: type: %s; level %d; stop %d" + ;; type level stop) + (while (and (> (point) stop) (not (zerop level))) + (re-search-backward + "\\({\\|}\\|::\\|\\b\\(do\\|od\\|if\\|fi\\)\\b\\)" + stop 'move) + ;;(message "looking from %d back-to %d" (point) stop) + (setq state (promela-parse-partial-sexp stop)) + (setq level (+ level + (cond ((or (nth 3 state) (nth 4 state)) 0) + ((and (= 1 level) (looking-at "::") + (not (equal type 'option))) -1) + ((looking-at "\\({\\|\\(do\\|if\\)\\b\\)") -1) + ((looking-at "\\(}\\|\\(od\\|fi\\)\\b\\)") +1) + (t 0))))) + (point)))) + +(defun promela-find-start-of-containing-block-or-comment (&optional limit) + "Return the start point of the containing comment or +the start of the containing `do', `if', `::' or `{' block. +Stop at limit or beginning of buffer." + (if (promela-inside-comment-p) + (promela-find-start-of-containing-comment limit) + (promela-find-start-of-containing-block limit))) + +;; ------------------------------------------------------------------------- +;; Debugging/testing + +;; (defun promela-mode-toggle-debug () +;; (interactive) +;; (make-local-variable 'debug-on-error) +;; (setq debug-on-error (not debug-on-error))) + +;;(defun promela-mode-revert-buffer () +;; (interactive) +;; (revert-buffer t t)) + +;; ------------------------------------------------------------------------- +;;###autoload + +(provide 'promela-mode) + + +;;---------------------------------------------------------------------- +;; Change History: +;; +;; $Log: promela-mode.el,v $ +;; Revision 1.11 2001/07/09 18:36:45 engstrom +;; - added comments on use of font-lock-maximum-decoration +;; - moved basic preprocess directive fontification to "level 2" +;; +;; Revision 1.10 2001/05/22 16:29:59 engstrom +;; - fixed error introduced in fontification levels stuff (xemacs only) +;; +;; Revision 1.9 2001/05/22 16:21:29 engstrom +;; - commented out the compilation / syntax check stuff for now +;; +;; Revision 1.8 2001/05/22 16:18:49 engstrom +;; - Munched history in preparation for first non-Honeywell release +;; - Added "levels" of fontification to be controlled by the std. variable: +;; 'font-lock-maximum-decoration' +;; +;; Revision 1.7 2001/04/20 01:41:46 engstrom +;; Revision 1.6 2001/04/06 23:57:18 engstrom +;; Revision 1.5 2001/04/04 20:04:15 engstrom +;; Revision 1.4 2001/03/15 02:22:18 engstrom +;; Revision 1.3 2001/03/09 19:39:51 engstrom +;; Revision 1.2 2001/03/01 18:07:47 engstrom +;; Revision 1.1 2001/02/01 xx:xx:xx engstrom +;; migrated to CVS versioning... +;; Pre-CVS-History: +;; 99-10-04 V0.4 EDE Fixed bug in end-of-block indentation +;; Simplified indentation code significantly +;; 99-09-2x V0.3 EDE Hacked on indentation more while at FM'99 +;; 99-09-16 V0.2 EDE Hacked, hacked, hacked on indentation +;; 99-04-01 V0.1 EDE Introduced (less-than) half-baked indentation +;; 98-11-05 V0.0 EDE Created - much code stolen from rexx-mode.el +;; Mostly just a fontification mode - +;; (indentation is HARD ;-) +;; +;; EOF promela-mode.el diff --git a/lisp/template.el b/lisp/template.el new file mode 100644 index 0000000..ea36c4b --- /dev/null +++ b/lisp/template.el @@ -0,0 +1,2609 @@ +;;; template.el --- use templates, decorate comments, auto-update buffers + +;; Copyright (C) 1995-2003 Free Software Foundation, Inc. +;; +;; Author: Christoph Wedler <wedler@users.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)) + + + +;;;;########################################################################## +;;;; 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) + + + +;;;;########################################################################## +;;;; 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))) + + + +;;;;########################################################################## +;;;; 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")))) + + + +;;;;########################################################################## +;;;; 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.love@dl.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 diff --git a/lisp/themes/color-themes-alex.el b/lisp/themes/color-themes-alex.el new file mode 100644 index 0000000..3f3795b --- /dev/null +++ b/lisp/themes/color-themes-alex.el @@ -0,0 +1,48 @@ +;; -*- self-compile-mode: t -*- + +(eval-when-compile + (require 'color-theme)) + +(defun color-theme-alex () + "Color theme by Alexander Sulfrian, created 2012-03-14." + (interactive) + (color-theme-install + '(color-theme-alex + ((foreground-color . "grey90") + (background-color . "black") + (background-mode . dark)) + (border ((t (:background "gray50")))) + (diff-removed ((t (:inherit diff-changed :foreground "red3")))) + (diff-added ((t (:inherit diff-changed :foreground "Lime green")))) + (diff-header ((t (:weight bold :background nil)))) + (fixed-pitch ((t (:family "terminus")))) + (font-lock-comment-face ((nil (:foreground "green3")))) + (font-lock-constant-face ((nil (:weight bold)))) + (font-lock-negation-char-face ((t (:foreground "red" :weight bold)))) + (font-lock-preprocessor-face ((t (:inherit font-lock-builtin-face :foreground "magenta")))) + (font-lock-string-face ((nil (:foreground "red2")))) + (font-lock-warning-face ((t (:foreground "Red" :weight bold)))) + (fringe ((t (:background "gray10")))) + (highlight ((nil (:background "grey10")))) + (linum ((t (:background "gray10" :foreground "gray50" :height 0.8)))) + (magit-item-highlight ((t (:background "gray10")))) + (mode-line ((t (:box (:line-width 1 :color "grey75"))))) + (mode-line-highlight ((((class color) (min-colors 88)) (:box (:line-width 2 :color "grey40" :style released-button))))) + (mode-line-inactive ((default (:inherit mode-line :foreground "gray60")) (nil nil))) + (region ((((class color) (min-colors 88) (background dark)) (:inverse-video t)))) + (scroll-bar ((t (:background "black" :foreground "gray25"))))))) + +(defun color-theme-alex-console () + "Color theme by Alexander Sulfrian for console, created 2012-03-14." + (interactive) + (color-theme-alex) + (color-theme-install + '(color-theme-alex-console + () + (default ((t (:background nil :foreground "white")))) + (linum ((t (:background nil :foreground "white" :box nil + :strike-through nil :overline nil :underline nil + :slant normal :weight normal)))) + (region ((nil (:inverse-video t))))))) + +(provide 'color-themes-alex) diff --git a/lisp/themes/color-themes-monokai-alex.el b/lisp/themes/color-themes-monokai-alex.el new file mode 100644 index 0000000..21bc4c3 --- /dev/null +++ b/lisp/themes/color-themes-monokai-alex.el @@ -0,0 +1,33 @@ +;; -*- self-compile-mode: t -*- + +(eval-when-compile + (require 'color-theme)) + +(defun color-theme-monokai-alex () + "Color theme by Alexander Sulfrian base on monokai" + (interactive) + (color-theme-monokai) + (let ((color-theme-is-cumulative t)) + (color-theme-install + '(color-theme-monokai-alex + ((background-color . "black") + (background-mode . dark)) + (font-lock-keyword-face ((t (:foreground "#66D9EF")))) + (font-lock-type-face ((t (:weight bold :slant italic :foreground "#66D9EF")))) + (linum ((t (:height 0.8 :inherit (default))))) + (scroll-bar ((t (:foreground "gray20" :background "black")))) + + (mode-line ((((class color) (min-colors 88)) + (:foreground "black" :background "grey75") + (t (:inverse-video t))))) + (mode-line-inactive (((default + (:inherit (mode-line))) + (((class color) (min-colors 88) + (background light)) + (:background "grey90" :foreground "grey20")) + (((class color) (min-colors 88) + (background dark)) + (:background "grey30" :foreground "grey80"))))) + )))) + +(provide 'color-themes-monokai-alex) diff --git a/lisp/winring.el b/lisp/winring.el new file mode 100644 index 0000000..baac31f --- /dev/null +++ b/lisp/winring.el @@ -0,0 +1,597 @@ +;;; winring.el --- Window configuration rings + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: 1997-1998 Barry A. Warsaw +;; Maintainer: bwarsaw@python.org +;; Created: March 1997 +;; Keywords: frames tools + +(defconst winring-version "3.5" + "winring version number.") + +;; 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 2, 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; 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 provides lightweight support for circular rings of +;; window configurations. A window configuration is the layout of +;; windows and associated buffers within a frame. There is always at +;; least one configuration on the ring, the current configuration. +;; You can create new configurations and cycle through the layouts in +;; either direction. You can also delete configurations from the ring +;; (except the last one of course!). Window configurations are named, +;; and you can jump to and delete named configurations. Display of +;; the current window configuration name in the mode line is only +;; supported as of Emacs 20.3 and XEmacs 21.0. +;; +;; Window configuration rings are frame specific. That is, each frame +;; has its own ring which can be cycled through independently of other +;; frames. This is the way I like it. +;; +;; You are always looking at the current window configuration for each +;; frame, which consists of the windows in the frame, the buffers in +;; those windows, and point in the current buffer. As you run +;; commands such as "C-x 4 b", "C-x 2", and "C-x 0" you are modifying +;; the current window configuration. When you jump to a new +;; configuration, the layout that existed before the jump is captured, +;; and the ring is rotated to the selected configuration. Window +;; configurations are captured with `current-window-configuration', +;; however winring also saves point for the current buffer. + +;; To use, make sure this file is on your `load-path' and put the +;; following in your .emacs file: +;; +;; (require 'winring) +;; (winring-initialize) +;; +;; Note that by default, this binds the winring keymap to the C-x 7 +;; prefix, but you can change this by setting the value of +;; `winring-keymap-prefix', before you call `winring-initialize'. +;; Note that this is a change from previous versions of winring; the +;; prefix used to be M-o but was changed on the suggestion of RMS. + +;; The following commands are defined: +;; +;; C-x 7 n -- Create a new window configuration. The new +;; configuration will contain a single buffer, the one +;; named in the variable `winring-new-config-buffer-name' +;; +;; With C-u, winring prompts for the name of the new +;; configuration. If you don't use C-u the function in +;; `winring-name-generator' will be called to get the +;; new configuration's name. +;; +;; C-x 7 2 -- Create a duplicate of the current window +;; configuration. C-u has the same semantics as with +;; "C-x 7 c". +;; +;; C-x 7 j -- Jump to a named configuration (prompts for the name). +;; +;; C-x 7 0 -- Kill the current window configuration and rotate to the +;; previous layout on the ring. You cannot delete the +;; last configuration in the ring. With C-u, prompts +;; for the name of the configuration to kill. +;; +;; C-x 7 o -- Go to the next configuration on the ring. +;; +;; C-x 7 p -- Go to the previous configuration on the ring. +;; +;; Note that the sequence `C-x 7 o C-x 7 p' is a no-op; +;; it leaves you in the same configuration you were in +;; before the sequence. +;; +;; C-x 7 r -- Rename the current window configuration. +;; +;; C-x 7 b -- Submit a bug report on winring. +;; +;; C-x 7 v -- Echo the winring version. + +;; As mentioned, window configuration names can be displayed in the +;; modeline, but this feature only works with Emacs 20.3 and XEmacs +;; 21.0. A patch for XEmacs 20.4 to support this feature is available +;; at the URL below. Note that the default value of +;; `winring-show-names' is currently nil by default because if your +;; X/Emacs doesn't have the necessary support, ugly things can happen +;; (no you won't crash your X/Emacs -- it just won't do what you +;; want). +;; +;; If your X/Emacs has the necessary support, you can turn on display +;; of window configuration names by setting `winring-show-names' to +;; t. If you don't like the position in the modeline where winring +;; names are shown, you can change this by passing in your own +;; modeline hacker function to `winring-initialize'. + +;;; Winring on the Web: +;; +;; The winring Web page (including the aforementioned XEmacs 20.4 +;; patch) is +;; +;; http://www.python.org/emacs/winring/ + +;;; History: +;; +;; A long long time ago there was a package called `wicos' written by +;; Heikki Suopanki, which was based on yet another earlier package +;; called `screens' also written by Suopanki. This in turn was based +;; on the Unix tty session manager `screen' (unrelated to Emacs) by +;; Oliver Laumann, Juergen Weigert, and Michael Schroeder. +;; +;; Wicos essentially provided fancy handling for window +;; configurations. I liked the basic ideas, but wicos broke with +;; later versions of Emacs and XEmacs. I re-implemented just the +;; functionality I wanted, simplifying things in the process, and +;; porting the code to run with XEmacs 19 and 20, and Emacs 20 (I +;; don't know if winring works in Emacs 19.34). +;; +;; Wicos used the M-o prefix which I've recently changed to C-x 7 as +;; the default, by suggestion of RMS. Wicos also had some support for +;; multiple frames, and saving configurations on all visible frames, +;; but it didn't work too well, and I like frame independent rings +;; better. +;; +;; I know of a few other related packages: +;; +;; - `escreen' by Noah Friedman. A much more ambitious package +;; that does Emacs window session management. Very cool, but I +;; wanted something more lightweight. +;; +;; - `wconfig' by Bob Weiner as part of Hyperbole. I think wconfig +;; is similar in spirit to winring; it seems to have also have +;; named window configurations, but not frame-specific window +;; rings. +;; +;; - `winner' by Ivar Rummelhoff. This package comes with Emacs +;; 20, and appears to differ from winring by providing undo/redo +;; semantics to window configuration changes. winner is a minor +;; mode and does seem to support frame-specific window rings. +;; +;; - `window-xemacs' by the XEmacs Development Team. It appears +;; that this package, which is specific to XEmacs (and perhaps +;; just XEmacs 20) implements stacks of window configurations +;; which are frame independent. + +;; Please feel free to email me if my rendition of history, or my +;; explanation of the related packages, is inaccurate. + +;;; Code: + +(require 'ring) + + +(defgroup winring nil + "Window configuration rings" + :prefix "winring-" + :group 'frames) + +(defcustom winring-ring-size 7 + "*Size of the window configuration ring." + :type 'integer + :group 'winring) + +(defcustom winring-prompt-on-create 'usually + "*When true, prompt for new configuration name on creation. +If not t and not nil, prompt for configuration name on creation, +except when creating the initial configuration on a new frame." + :type '(radio + (const :tag "Never prompt for configuration name" nil) + (const :tag "Always prompt for configuration name" t) + (const :tag "Prompt for all but initial configuration name" + usually) + ) + :group 'winring) + +(defcustom winring-new-config-buffer-name "*scratch*" + "*Name of the buffer to switch to when a new configuration is created." + :type 'string + :group 'winring) + +(defcustom winring-show-names nil + "*If non-nil, window configuration names are shown in the modeline. +If nil, the name is echoed in the minibuffer when switching window +configurations." + :type 'boolean + :group 'winring) + +(defcustom winring-name-generator 'winring-next-name + "*Function that generates new automatic window configuration names. +When a new window configuration is created with `winring-new-configuration', +and the user did not specify an explicit name, this function is called with +no arguments to get the new name. It must return a string." + :type 'function + :group 'winring) + +;; Not yet customized +(defvar winring-keymap-prefix "\C-x7" + "*Prefix key that the `winring-map' is placed on in the global keymap. +If you change this, you must do it before calling `winring-initialize'.") + + +;; Set up keymap +(defvar winring-map nil + "Keymap used for winring, window configuration rings.") +(if winring-map + nil + (setq winring-map (make-sparse-keymap)) + (define-key winring-map "b" 'winring-submit-bug-report) + (define-key winring-map "n" 'winring-new-configuration) + (define-key winring-map "2" 'winring-duplicate-configuration) + (define-key winring-map "j" 'winring-jump-to-configuration) + (define-key winring-map "0" 'winring-delete-configuration) + (define-key winring-map "o" 'winring-next-configuration) + (define-key winring-map "p" 'winring-prev-configuration) + (define-key winring-map "r" 'winring-rename-configuration) + (define-key winring-map "v" 'winring-version) + ) + + + +;; Winring names +(defvar winring-name nil + "The name of the currently displayed window configuration.") + +(defvar winring-name-index 1 + "Index used as a sequence number for new unnamed window configurations.") + +(defvar winring-name-history nil + "History variable for window configuration name prompts.") + +(defun winring-next-name () + (let ((name (format "%03d" winring-name-index))) + (setq winring-name-index (1+ winring-name-index)) + name)) + + + +;; Compatibility +(defun winring-set-frame-ring (frame ring) + (cond + ;; XEmacs + ((fboundp 'set-frame-property) + (set-frame-property frame 'winring-ring ring)) + ;; Emacs + ((fboundp 'modify-frame-parameters) + (modify-frame-parameters frame (list (cons 'winring-ring ring)))) + ;; Not supported + (t (error "This version of Emacs is not supported by winring")))) + +(defun winring-get-frame-ring (frame) + (cond + ;; XEmacs + ((fboundp 'frame-property) + (frame-property frame 'winring-ring)) + ;; Emacs 20 + ((fboundp 'frame-parameter) + (frame-parameter frame 'winring-ring)) + ;; Emacs 19.34 + ((fboundp 'frame-parameters) + (cdr (assq 'winring-ring (frame-parameters frame)))) + ;; Unsupported + (t (error "This version of Emacs is not supported by winring")))) + +(defun winring-create-frame-hook (frame) + ;; generate the name, but specify the newly created frame + (winring-set-name (and (eq winring-prompt-on-create t) + (read-string "Initial window configuration name? " + nil 'winring-name-history)) + frame)) + + +;; Utilities +(defun winring-set-name (&optional name frame) + "Set the window configuration name. +Optional NAME is the name to use; if not given, then +`winring-name-generator' is `funcall'd with no arguments to get the +generated name. Optional FRAME is the frame to set the name for; if +not given then the currently selected frame is used." + (let ((name (or name (funcall winring-name-generator))) + (frame (or frame (selected-frame)))) + (if (fboundp 'add-spec-to-specifier) + ;; The XEmacs way. Only supported in hacked 20.4 or 21.0 + (add-spec-to-specifier winring-name name frame) + ;; the Emacs way. Only supported in Emacs 20.3 + (setq winring-name name) + (modify-frame-parameters frame (list (cons 'winring-name name))) + )) + (if (not winring-show-names) + (message "Switching to window configuration: %s" name))) + +(defun winring-get-ring () + (let* ((frame (selected-frame)) + (ring (winring-get-frame-ring frame))) + (when (not ring) + (setq ring (make-ring winring-ring-size)) + (winring-set-frame-ring frame ring)) + ring)) + +(defsubst winring-name-of (config) + (car config)) + +(defsubst winring-conf-of (config) + (car (cdr config))) + +(defsubst winring-point-of (config) + (nth 2 config)) + +(defsubst winring-name-of-current () + (if (fboundp 'specifier-instance) + ;; In XEmacs, this variable holds a specifier which + ;; must be instanced to get the current + ;; configuration name. + (specifier-instance winring-name) + ;; In Emacs, just use the variable's string value + ;; directly, since the `displayed' value is kept as a + ;; frame parameter + winring-name)) + +(defun winring-save-current-configuration (&optional at-front) + (let* ((ring (winring-get-ring)) + (name (winring-name-of-current)) + (here (point)) + (conf (list name (current-window-configuration) here))) + (if at-front + (ring-insert-at-beginning ring conf) + (ring-insert ring conf)))) + +(defun winring-restore-configuration (item) + (let ((conf (winring-conf-of item)) + (name (winring-name-of item)) + (here (winring-point-of item))) + (set-window-configuration conf) + ;; current-window-configuration does not save point in current + ;; window. That sucks! + (goto-char here) + (winring-set-name name)) + (force-mode-line-update)) + +(defun winring-complete-name () + (let* ((ring (winring-get-ring)) + (n (1- (ring-length ring))) + (current (winring-name-of-current)) + (table (list (cons current -1))) + name) + ;; populate the completion table + (while (<= 0 n) + (setq table (cons (cons (winring-name-of (ring-ref ring n)) n) table) + n (1- n))) + (setq name (completing-read + (format "Window configuration name (%s): " current) + table nil 'must nil 'winring-name-history)) + (if (string-equal name "") + (setq name current)) + (cdr (assoc name table)))) + +(defun winring-read-name (prompt) + (let* ((ring (winring-get-ring)) + (n (1- (ring-length ring))) + (table (list (winring-name-of-current))) + name) + ;; get the list of all the names in the ring + (while (<= 0 n) + (setq table (cons (winring-name-of (ring-ref ring n)) table) + n (1- n))) + (setq name (read-string prompt nil 'winring-name-history)) + (if (member name table) + (error "Window configuration name already in use: %s" name)) + name)) + + +;; Commands + +;;;###autoload +(defun winring-new-configuration (&optional arg) + "Save the current window configuration and create an empty new one. +The buffer shown in the new empty configuration is defined by +`winring-new-config-buffer-name'. + +With \\[universal-argument] prompt for the new configuration's name. +Otherwise, the function in `winring-name-generator' will be called to +get the new configuration's name." + (interactive "P") + (let ((name (and (or arg winring-prompt-on-create) + (winring-read-name "New window configuration name? ")))) + ;; Empty string is not allowed + (if (string-equal name "") + (setq name (funcall winring-name-generator))) + (winring-save-current-configuration) + (delete-other-windows) + (switch-to-buffer winring-new-config-buffer-name) + (winring-set-name name))) + +;;;###autoload +(defun winring-duplicate-configuration (&optional arg) + "Push the current window configuration on the ring, and duplicate it. + +With \\[universal-argument] prompt for the new configuration's name. +Otherwise, the function in `winring-name-generator' will be called to +get the new configuration's name." + (interactive "P") + (let ((name (and (or arg winring-prompt-on-create) + (winring-read-name "New window configuration name? ")))) + ;; Empty string is not allowed + (if (string-equal name "") + (setq name (funcall winring-name-generator))) + (winring-save-current-configuration) + (winring-set-name name))) + +;;;###autoload +(defun winring-next-configuration () + "Switch to the next window configuration for this frame." + (interactive) + (let ((next (ring-remove (winring-get-ring)))) + (winring-save-current-configuration) + (winring-restore-configuration next))) + +;;;###autoload +(defun winring-prev-configuration () + "Switch to the previous window configuration for this frame." + (interactive) + (let ((prev (ring-remove (winring-get-ring) 0))) + (winring-save-current-configuration 'at-front) + (winring-restore-configuration prev))) + +;;;###autoload +(defun winring-jump-to-configuration () + "Go to the named window configuration." + (interactive) + (let* ((ring (winring-get-ring)) + (index (winring-complete-name)) + item) + ;; if the current configuration was chosen, winring-complete-name + ;; returns -1 + (when (<= 0 index) + (setq item (ring-remove ring index)) + (winring-save-current-configuration) + (winring-restore-configuration item)) + )) + +;;;###autoload +(defun winring-delete-configuration (&optional arg) + "Delete the current configuration and switch to the next one. +With \\[universal-argument] prompt for named configuration to delete." + (interactive "P") + (let ((ring (winring-get-ring)) + index) + (if (or (not arg) + (> 0 (setq index (winring-complete-name)))) + ;; remove the current one, so install the next one + (winring-restore-configuration (ring-remove ring)) + ;; otherwise, remove the named one but don't change the current config + (ring-remove ring index) + ))) + +;;;###autoload +(defun winring-rename-configuration (name) + "Rename the current configuration to NAME." + (interactive "sNew window configuration name? ") + (winring-set-name name)) + + + +(defconst winring-help-address "bwarsaw@python.org" + "Address accepting bug report submissions.") + +(defun winring-version () + "Echo the current version of winring in the minibuffer." + (interactive) + (message "Using winring version %s" winring-version) + ;;(setq zmacs-region-stays t) + ) + +(defun winring-submit-bug-report (comment-p) + "Submit via mail a bug report on winring. +With \\[universal-argument] just send any type of comment." + (interactive + (list (not (y-or-n-p + "Is this a bug report? (hit `n' to send other comments) ")))) + (let ((reporter-prompt-for-summary-p (if comment-p + "(Very) brief summary: " + t))) + (require 'reporter) + (reporter-submit-bug-report + winring-help-address ;address + (concat "winring " winring-version) ;pkgname + ;; varlist + (if comment-p nil + '(winring-ring-size + winring-new-config-buffer-name + winring-show-names + winring-name-generator + winring-keymap-prefix)) + nil ;pre-hooks + nil ;post-hooks + "Dear Barry,") ;salutation + (if comment-p nil + (set-mark (point)) + (insert +"Please replace this text with a description of your problem.\n\ +The more accurately and succinctly you can describe the\n\ +problem you are encountering, the more likely I can fix it\n\ +in a timely way.\n\n") + (exchange-point-and-mark) + ;;(setq zmacs-region-stays t) + ))) + + + +;; Initialization. This is completely different b/w Emacs and XEmacs. +;; The Emacs 20.3 way is to create a frame-local variable (this is a +;; new feature with Emacs 20.3), and save the config name as a frame +;; property. +;; +;; In XEmacs 21.0 (a.k.a. 20.5), you create a generic specifier, and +;; save the config name as an instantiator over the current frame +;; locale. + +;; Be sure to do this only once +(defvar winring-initialized nil) + +(defun winring-initialize (&optional hack-modeline-function) + (unless winring-initialized + ;; + ;; Create the variable that holds the window configuration name + ;; + (cond + ;; The Emacs 20.3 way: frame-local variables + ((fboundp 'make-variable-frame-local) + (make-variable-frame-local 'winring-name)) + ;; The XEmacs 21 way: specifiers + ((fboundp 'make-specifier) + (setq winring-name (make-specifier 'generic))) + ;; Not supported in older X/Emacsen + (t nil)) + ;; + ;; Glom the configuration name into the mode-line. I've + ;; experimented with a couple of different locations, including + ;; for Emacs 20.3 mode-line-frame-identification, and for XEmacs, + ;; just splicing it before the modeline-buffer-identification. + ;; Sticking it on the very left side of the modeline, even before + ;; mode-line-modified seems like the most useful and + ;; cross-compatible place. + ;; + ;; Note that you can override the default hacking of the modeline + ;; by passing in your own `hack-modeline-function'. + ;; + (if hack-modeline-function + (funcall hack-modeline-function) + ;; Else, default insertion hackery + (let ((format (list 'winring-show-names + '("<" winring-name "> "))) + (splice (cdr mode-line-format))) + (setcar splice (list format (car splice))))) + ;; + ;; We need to add a hook so that all newly created frames get + ;; initialized properly. Again, different for Emacs and XEmacs. + ;; + (if (boundp 'create-frame-hook) + ;; XEmacs + (add-hook 'create-frame-hook 'winring-create-frame-hook) + ;; better be Emacs! + (add-hook 'after-make-frame-functions 'winring-create-frame-hook)) + ;; + ;; Now set the initial configuration name on the initial frame... + (winring-create-frame-hook (selected-frame)) + ;; ...the keymap... + (global-set-key winring-keymap-prefix winring-map) + ;; ...and the init fence + (setq winring-initialized t))) + + + +(provide 'winring) +;;; winring.el ends here |